Added crucial VFS modules and a few working tests for them

Tests/Fs/503.html

@@ -0,0 +1 @@
+Server temporarily non accessible.

Tests/Fs/Mods/FullyVirtual/Hobbots/mms.cfg

@@ -0,0 +1,2 @@
+SilentAutoUpdateEnable=1
+AutoUpdateDisable=0

Tests/Fs/default

@@ -0,0 +1,13 @@
+server {
+    #listen 80 default;
+    #server_name localhost;
+    #deny all;
+    access_log off;
+
+    location / {
+        proxy_set_header X-Real-IP $remote_addr;
+        proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for;
+        proxy_set_header Host $host;
+        proxy_pass http://127.0.0.1:8080;
+    }
+}

Tests/VfsApiDiggerTest.pas

@@ -0,0 +1,49 @@
+unit VfsApiDiggerTest;
+
+(***)  interface  (***)
+
+uses
+  Windows, SysUtils, TestFramework,
+  Utils, WinUtils, DataLib,
+  VfsApiDigger;
+
+type
+  TestApiDigger = class (TTestCase)
+   published
+    procedure DetermineRealApiAddress;
+  end;
+
+
+(***)  implementation  (***)
+
+
+procedure TestApiDigger.DetermineRealApiAddress;
+type
+  TGetCurrentProcessId = function (): integer; stdcall;
+
+var
+  Kernel32Handle:   THandle;
+  KernelBaseHandle: THandle;
+  NormalProc:       TGetCurrentProcessId;
+  RealProc:         TGetCurrentProcessId;
+  TestProc:         TGetCurrentProcessId;
+
+begin
+  Kernel32Handle   := Windows.GetModuleHandle('kernel32.dll');
+  KernelBaseHandle := Windows.GetModuleHandle('kernelbase.dll');
+
+  if (Kernel32Handle <> 0) and (KernelBaseHandle <> 0) then begin
+    NormalProc := Windows.GetProcAddress(Kernel32Handle, 'GetCurrentProcessId');
+    RealProc   := Windows.GetProcAddress(KernelBaseHandle, 'GetCurrentProcessId');
+
+    if (@NormalProc <> nil) and (@RealProc <> nil) then begin
+      VfsApiDigger.FindOutRealSystemApiAddrs([Kernel32Handle]);
+      TestProc := VfsApiDigger.GetRealProcAddress(Kernel32Handle, 'GetCurrentProcessId');
+      Check(@TestProc = @RealProc, Format('Failed to get real api address. Normal address: %x, Real address: %x, Got address: %x', [Int(@NormalProc), Int(@RealProc), Int(@TestProc)]));
+    end;
+  end;
+end;
+
+begin
+  RegisterTest(TestApiDigger.Suite);
+end.

Tests/VfsBaseTest.pas

@@ -0,0 +1,69 @@
+unit VfsBaseTest;
+
+(***)  interface  (***)
+
+uses
+  SysUtils, TestFramework,
+  Utils, WinUtils,
+  VfsUtils, VfsBase;
+
+type
+  TestBase = class (TTestCase)
+   protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+
+   published
+    procedure TestVirtualDirMapping;
+  end;
+
+(***)  implementation  (***)
+
+
+procedure TestBase.SetUp;
+begin
+  VfsBase.ResetVfs();
+end;
+
+procedure TestBase.TearDown;
+begin
+  VfsBase.ResetVfs();
+end;
+
+procedure TestBase.TestVirtualDirMapping;
+var
+  DirListing: TDirListing;
+  DirInfo:    TNativeFileInfo;
+  RootDir:    string;
+  FileInfo:   TFileInfo;
+  i:          integer;
+
+begin
+  DirListing := TDirListing.Create;
+  FileInfo   := nil;
+  // * * * * * //
+  RootDir := SysUtils.ExtractFileDir(WinUtils.GetExePath) + '\Tests\Fs';
+  VfsBase.MapDir(RootDir, RootDir + '\Mods\B', DONT_OVERWRITE_EXISTING);
+  VfsBase.MapDir(RootDir, RootDir + '\Mods\A', DONT_OVERWRITE_EXISTING);
+  VfsBase.RunVfs(SORT_FIFO);
+  VfsBase.GetVfsDirInfo(RootDir, '*', DirInfo, DirListing);
+
+  DirListing.Rewind;
+  Check(DirListing.GetDebugDump() = 'vcredist.bmp'#13#10'eula.1028.txt', 'Invalid virtual directoring listing. Got: ' + DirListing.GetDebugDump());
+
+  DirListing.Rewind;
+  
+  for i := 0 to DirListing.Count - 1 do begin
+    DirListing.GetNextItem(FileInfo);
+
+    if FileInfo.Data.FileName = 'vcredist.bmp' then begin
+      Check(FileInfo.Data.GetFileSize() = 5686, 'File from A mod must not override same file from B mod');
+    end;
+  end;
+  // * * * * * //
+  SysUtils.FreeAndNil(DirListing);
+end;
+
+begin
+  RegisterTest(TestBase.Suite);
+end.

Tests/VfsOpenFilesTest.pas

@@ -0,0 +1,69 @@
+unit VfsOpenFilesTest;
+
+(***)  interface  (***)
+
+uses
+  Windows, SysUtils, TestFramework,
+  Utils, WinUtils, DataLib,
+  VfsBase, VfsUtils, VfsOpenFiles;
+
+type
+  TestOpenFiles = class (TTestCase)
+   protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+
+   published
+    procedure GetCombinedDirListing;
+  end;
+
+
+(***)  implementation  (***)
+
+
+procedure TestOpenFiles.SetUp;
+begin
+  VfsBase.ResetVfs();
+end;
+
+procedure TestOpenFiles.TearDown;
+begin
+  VfsBase.ResetVfs();
+end;
+
+procedure TestOpenFiles.GetCombinedDirListing;
+const
+  VALID_FULLY_VIRT_DIR_LISTING = 'mms.cfg'#13#10'.'#13#10'..';
+  VALID_COMBINED_LISTING       = 'Hobbots'#13#10'vcredist.bmp'#13#10'.'#13#10'..'#13#10'503.html'#13#10'default'#13#10'Mods';
+
+var
+{O} OpenedFile: VfsOpenFiles.TOpenedFile;
+    DirPath:    WideString;
+    RootDir:    string;
+
+begin
+  OpenedFile := nil;
+  // * * * * * //
+  RootDir := SysUtils.ExtractFileDir(WinUtils.GetExePath) + '\Tests\Fs';
+  VfsBase.MapDir(RootDir, RootDir + '\Mods\FullyVirtual', DONT_OVERWRITE_EXISTING);
+  VfsBase.MapDir(RootDir, RootDir + '\Mods\B', DONT_OVERWRITE_EXISTING);
+  VfsBase.RunVfs(SORT_FIFO);
+
+  DirPath    := VfsUtils.NormalizePath(RootDir + '\Hobbots');
+  OpenedFile := VfsOpenFiles.TOpenedFile.Create(777, DirPath);
+  OpenedFile.FillDirListing('*');
+  Check(OpenedFile.DirListing <> nil, 'Directory listing must be assigned');
+  Check(OpenedFile.DirListing.GetDebugDump() = VALID_FULLY_VIRT_DIR_LISTING, 'Invalid listing for fully virtual directory "' + DirPath + '". Got: ' + OpenedFile.DirListing.GetDebugDump());
+  FreeAndNil(OpenedFile);
+
+  OpenedFile := VfsOpenFiles.TOpenedFile.Create(888, RootDir);
+  OpenedFile.FillDirListing('*');
+  Check(OpenedFile.DirListing <> nil, 'Directory listing must be assigned');
+  Check(OpenedFile.DirListing.GetDebugDump() = VALID_COMBINED_LISTING, 'Invalid combined listing for directory "' + RootDir + '". Got: ' + OpenedFile.DirListing.GetDebugDump());
+  // * * * * * //
+  SysUtils.FreeAndNil(OpenedFile);
+end;
+
+begin
+  RegisterTest(TestOpenFiles.Suite);
+end.

Tests/VfsUtilsTest.pas

@@ -0,0 +1,68 @@
+unit VfsUtilsTest;
+
+(***)  interface  (***)
+
+uses
+  SysUtils, TestFramework,
+  Utils, WinUtils, DataLib,
+  VfsUtils;
+
+type
+  TestUtils = class (TTestCase)
+   published
+    procedure TestNativeDirScanning;
+    procedure TestGetDirectoryListing;
+  end;
+
+
+(***)  implementation  (***)
+
+
+procedure TestUtils.TestNativeDirScanning;
+var
+  RootDir:     string;
+  FileInfo:    VfsUtils.TNativeFileInfo;
+  DirItems:    DataLib.TStrList;
+  DirContents: string;
+
+begin
+  DirItems := DataLib.NewStrList(not Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE);
+  // * * * * * //
+  RootDir := SysUtils.ExtractFileDir(WinUtils.GetExePath) + '\Tests\Fs';
+
+  with SysScanDir(RootDir, '*') do begin
+    while IterNext(FileInfo.FileName, @FileInfo.Base) do begin
+      DirItems.Add(FileInfo.FileName);
+    end;
+  end;
+
+  DirItems.Sort;
+  DirContents := DirItems.ToText(#13#10);
+  Check(DirContents = '.'#13#10'..'#13#10'503.html'#13#10'default'#13#10'Mods', 'Invalid directory listing. Got:'#13#10 + DirContents);
+  // * * * * * //
+  SysUtils.FreeAndNil(DirItems);
+end; // .procedure TestNativeDirScanning
+
+procedure TestUtils.TestGetDirectoryListing;
+var
+  DirListing: VfsUtils.TDirListing;
+  Exclude:    DataLib.TDict {of not nil};
+  RootDir:    string;
+ 
+begin
+  DirListing := VfsUtils.TDirListing.Create;
+  Exclude    := DataLib.NewDict(not Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE);
+  // * * * * * //
+  RootDir := SysUtils.ExtractFileDir(WinUtils.GetExePath) + '\Tests\Fs';
+  Exclude[VfsUtils.WideStrToCaselessKey('..')] := Ptr(1);
+
+  VfsUtils.GetDirectoryListing(RootDir, '*', Exclude, DirListing);
+  Check(DirListing.GetDebugDump() = '.'#13#10'503.html'#13#10'default'#13#10'Mods', 'Invalid directory listing. Got:'#13#10 + DirListing.GetDebugDump());
+  // * * * * * //
+  SysUtils.FreeAndNil(DirListing);
+  SysUtils.FreeAndNil(Exclude);
+end; // .procedure TestUtils.TestGetDirectoryListing
+
+begin
+  RegisterTest(TestUtils.Suite);
+end.

Vfs.dproj.local

@@ -0,0 +1,2 @@
+<?xml version="1.0" encoding="utf-8"?>
+<BorlandProject/>

Vfs.drc

@@ -0,0 +1,10 @@
+/* VER185
+  Generated by the CodeGear Delphi Pascal Compiler
+  because -GD or --drc was supplied to the compiler.
+
+  This file contains compiler-generated resources that
+  were bound to the executable.
+  If this file is empty, then no compiler-generated
+  resources were bound to the produced executable.
+*/
+

VfsApiDigger.pas

@@ -0,0 +1,164 @@
+unit VfsApiDigger;
+(*
+  Description: Provides means for detecting real WinAPI functions addresses, bypassing proxy dlls and
+               other low level code routines.
+*)
+
+
+(***)  interface  (***)
+
+uses
+  SysUtils, Windows,
+  Utils, DataLib, PatchForge;
+
+
+(* Determines real exported API addresses for all specified DLL handles. If DLL imports function
+   with the same name, as the exported one, then imported one is treated as real function.
+   Example: kernel32.ReadProcessMemory can be a bridge to imported kernelbase.ReadProcessMemory.
+   If DLL handle was processed earlier, it's skipped *)
+procedure FindOutRealSystemApiAddrs (const DllHandles: array of integer);
+
+(* Returns real code address, bypassing possibly nested simple redirection stubs like JMP [...] or JMP XXX. *)
+function GetRealAddress (CodeOrRedirStub: pointer): {n} pointer;
+
+(* Enhanced version of kernel32.GetProcAddress, traversing bridge chains and using info, gained by FindOutRealSystemApiAddrs earlier *)
+function GetRealProcAddress (DllHandle: integer; const ProcName: string): {n} pointer;
+
+
+(***)  implementation  (***)
+
+
+var
+(* Map of DLL handle => API name => Real api address *)
+{O} DllRealApiAddrs: {O} TObjDict {OF TDict};
+
+
+procedure FindOutRealSystemApiAddrs (const DllHandles: array of integer);
+const
+  PE_SIGNATURE_LEN = 4;
+
+type
+  PImageImportDirectory = ^TImageImportDirectory;
+  TImageImportDirectory = packed record
+    RvaImportLookupTable:  integer;
+    TimeDateStamp:         integer;
+    ForwarderChain:        integer;
+    RvaModuleName:         integer;
+    RvaImportAddressTable: integer;
+  end;
+
+  PHintName = ^THintName;
+  THintName = packed record
+    Hint: word;
+    Name: array [0..MAXLONGINT - 5] of char;
+  end;
+
+var
+  ImportDirInfo:     PImageDataDirectory;
+  ImportDir:         PImageImportDirectory;
+  ImportLookupTable: Utils.PEndlessIntArr;
+  ImportAddrTable:   Utils.PEndlessIntArr;
+  DllApiRedirs:      {U} TDict {of pointer};
+  DllHandle:         integer;
+  i, j:              integer;
+
+begin
+  ImportDirInfo     := nil;
+  ImportDir         := nil;
+  ImportLookupTable := nil;
+  ImportAddrTable   := nil;
+  DllApiRedirs      := nil;
+  // * * * * * //
+  for i := 0 to high(DllHandles) do begin
+    DllHandle     := DllHandles[i];
+    ImportDirInfo := @PImageOptionalHeader(DllHandle + PImageDosHeader(DllHandle)._lfanew + PE_SIGNATURE_LEN + sizeof(TImageFileHeader)).DataDirectory[1];
+    DllApiRedirs  := DllRealApiAddrs[Ptr(DllHandle)];
+
+    if DllApiRedirs = nil then begin
+      DllApiRedirs                    := DataLib.NewDict(NOT Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE);
+      DllRealApiAddrs[Ptr(DllHandle)] := DllApiRedirs;
+
+      // Found valid import directory in Win32 PE
+      if ((ImportDirInfo.Size > 0) and (ImportDirInfo.VirtualAddress <> 0)) then begin
+        ImportDir := pointer(DllHandle + integer(ImportDirInfo.VirtualAddress));
+
+        while ImportDir.RvaImportLookupTable <> 0 do begin
+          ImportLookupTable := pointer(DllHandle + ImportDir.RvaImportLookupTable);
+          ImportAddrTable   := pointer(DllHandle + ImportDir.RvaImportAddressTable);
+
+          j := 0;
+
+          while (j >= 0) and (ImportLookupTable[j] <> 0) do begin
+            if ImportLookupTable[j] > 0 then begin
+              DllApiRedirs[pchar(@PHintName(DllHandle + ImportLookupTable[j]).Name)] := Ptr(ImportAddrTable[j]);
+            end;
+
+            Inc(j);
+          end;
+
+          Inc(ImportDir);
+        end; // .while
+      end; // .if
+    end; // .if
+  end; // .for
+end; // .procedure FindOutRealSystemApiAddrs
+
+function GetRealAddress (CodeOrRedirStub: pointer): {n} pointer;
+const
+ MAX_DEPTH = 100;
+
+var
+  Depth: integer;
+
+begin
+  {!} Assert(CodeOrRedirStub <> nil);
+  result := CodeOrRedirStub;
+  Depth  := 0;
+
+  while Depth < MAX_DEPTH do begin
+    // JMP DWORD [PTR]
+    if pword(result)^ = PatchForge.OPCODE_JMP_PTR_CONST32 then begin
+      result := ppointer(integer(result) + sizeof(word))^;
+    // JXX SHORT CONST8
+    end else if PatchForge.IsShortJumpConst8Opcode(pbyte(result)^) then begin
+      result := pointer(integer(result) + sizeof(byte) + pshortint(integer(result) + sizeof(byte))^);
+    // JMP NEAR CONST32
+    end else if pbyte(result)^ = PatchForge.OPCODE_JMP_CONST32 then begin
+      result := pointer(integer(result) + sizeof(PatchForge.TJumpCall32Rec) + pinteger(integer(result) + sizeof(byte))^);
+    // JXX (conditional) NEAR CONST32
+    end else if PatchForge.IsNearJumpConst32Opcode(pword(result)^) then begin
+      result := pointer(integer(result) + sizeof(word) + sizeof(integer) + pinteger(integer(result) + sizeof(word))^);
+    // Regular code
+    end else begin
+      break;
+    end; // .else
+
+    Inc(Depth);
+  end; // .while
+end; // .function GetRealAddress
+
+function GetRealProcAddress (DllHandle: integer; const ProcName: string): {n} pointer;
+var
+{Un} DllApiRedirs: {U} TDict {OF pointer};
+
+begin
+  DllApiRedirs := DllRealApiAddrs[Ptr(DllHandle)];
+  result       := nil;
+  // * * * * * //
+
+  if DllApiRedirs <> nil then begin
+    result := DllApiRedirs[ProcName];
+  end;
+
+  if result = nil then begin
+    result := Windows.GetProcAddress(DllHandle, pchar(ProcName));
+  end;
+
+  if result <> nil then begin
+    result := GetRealAddress(result);
+  end;
+end; // .function GetRealProcAddress
+
+begin
+  DllRealApiAddrs := DataLib.NewObjDict(Utils.OWNS_ITEMS);
+end.

VfsBase.pas

@@ -22,6 +22,9 @@ type
   TList    = Lists.TList;
 
 const
+  OVERWRITE_EXISTING      = true;
+  DONT_OVERWRITE_EXISTING = false;
+
   AUTO_PRIORITY                = MAXLONGINT div 2;
   INITIAL_OVERWRITING_PRIORITY = AUTO_PRIORITY + 1;
   INITIAL_ADDING_PRIORITY      = AUTO_PRIORITY - 1;
@@ -76,11 +79,24 @@ type
     procedure RestoreVfsForThread;
   end;
 
+var
+  (* Global VFS access synchronizer *)
+  VfsCritSection: Concur.TCritSection;
+
 
 function GetThreadVfsDisabler: TThreadVfsDisabler;
-procedure RunVfs (DirListingOrder: TDirListingSortType);
+
+(* Runs VFS. Higher level API must install hooks in VfsCritSection protected area *)
+function RunVfs (DirListingOrder: TDirListingSortType): boolean;
+
+(* Stops VFS and clears all mappings *)
 function ResetVfs: boolean;
 
+(* Returns real path for VFS item by its absolute virtual path or empty string. Optionally returns file info structure *)
+function GetVfsItemRealPath (const AbsVirtPath: WideString; {n} FileInfo: PNativeFileInfo = nil): WideString;
+
+(* Returns virtual directory info. Adds virtual entries to specified directory listing container *)
+function GetVfsDirInfo (const AbsVirtPath, Mask: WideString; {OUT} var DirInfo: TNativeFileInfo; DirListing: TDirListing): boolean;
 
 (* Maps real directory contents to virtual path. Target must exist for success *)
 function MapDir (const VirtPath, RealPath: WideString; OverwriteExisting: boolean; Flags: integer = 0): boolean;
@@ -97,9 +113,6 @@ var
 *)
 {O} VfsItems: {O} TDict {OF TVfsItem};
   
-  (* Global VFS access synchronizer *)
-  VfsCritSection: Concur.TCritSection;
-  
   (* Global VFS state indicator. If false, all VFS search operations must fail *)
   VfsIsRunning: boolean = false;
     
@@ -166,32 +179,6 @@ begin
   VfsCritSection.Leave;
 end;
 
-(* Packs lower cased WideString bytes into AnsiString buffer *)
-function WideStrToCaselessKey (const Str: WideString): string;
-var
-  ProcessedPath: WideString;
-
-begin
-  result := '';
-
-  if Str <> '' then begin
-    ProcessedPath := StrLib.WideLowerCase(Str);
-    SetLength(result, Length(ProcessedPath) * sizeof(ProcessedPath[1]) div sizeof(result[1]));
-    Utils.CopyMem(Length(result) * sizeof(result[1]), PWideChar(ProcessedPath), PChar(result));
-  end;
-end;
-
-(* The opposite of WideStrToKey *)
-function UnpackPath (const PackedPath: string): WideString;
-begin
-  result := '';
-
-  if PackedPath <> '' then begin
-    SetLength(result, Length(PackedPath) * sizeof(PackedPath[1]) div sizeof(result[1]));
-    Utils.CopyMem(Length(result) * sizeof(result[1]), pchar(PackedPath), PWideChar(result));
-  end;
-end;
-
 function CompareVfsItemsByPriorityDescAndNameAsc (Item1, Item2: integer): integer;
 begin
   result := TVfsItem(Item2).Priority - TVfsItem(Item1).Priority;
@@ -266,7 +253,7 @@ begin
   // * * * * * //
   with DataLib.IterateDict(VfsItems) do begin
     while IterNext() do begin
-      AbsDirPath := StrLib.ExtractDirPathW(UnpackPath(IterKey));
+      AbsDirPath := StrLib.ExtractDirPathW(CaselessKeyToWideStr(IterKey));
 
       if FindVfsItemByNormalizedPath(AbsDirPath, DirVfsItem) then begin
         DirVfsItem.Children.Add(IterValue);
@@ -275,8 +262,11 @@ begin
   end;
 end; // .procedure BuildVfsItemsTree
 
-procedure RunVfs (DirListingOrder: TDirListingSortType);
+function RunVfs (DirListingOrder: TDirListingSortType): boolean;
 begin
+  result := not DisableVfsForThisThread;
+
+  if result then begin
     with VfsCritSection do begin
       Enter;
 
@@ -288,18 +278,77 @@ begin
 
       Leave;
     end;
-end; // .procedure RunVfs
+  end;
+end; // .function RunVfs
 
 function ResetVfs: boolean;
 begin
+  result := not DisableVfsForThisThread;
+
+  if result then begin
+    with VfsCritSection do begin
+      Enter;
+      VfsIsRunning := false;
+      VfsItems.Clear();
+      Leave;
+    end;
+  end;
+end;
+
+(* Returns real path for vfs item by its absolute virtual path or empty string. Optionally returns file info structure *)
+function GetVfsItemRealPath (const AbsVirtPath: WideString; {n} FileInfo: PNativeFileInfo = nil): WideString;
+var
+{n} VfsItem: TVfsItem;
+
+begin
+  VfsItem := nil;
+  result  := '';
+  // * * * * * //
+  if EnterVfs then begin
+    if FindVfsItemByNormalizedPath(AbsVirtPath, VfsItem) then begin
+      result := VfsItem.RealPath;
+
+      if FileInfo <> nil then begin
+        FileInfo^ := VfsItem.Info;
+      end;
+    end;
+
+    LeaveVfs;
+  end; // .if
+end; // .function GetVfsItemRealPath
+
+function GetVfsDirInfo (const AbsVirtPath, Mask: WideString; {OUT} var DirInfo: TNativeFileInfo; DirListing: TDirListing): boolean;
+var
+{n} VfsItem:        TVfsItem;
+    NormalizedMask: WideString;
+    i:              integer;
+
+begin
+  {!} Assert(DirListing <> nil);
+  VfsItem := nil;
+  // * * * * * //
   result := EnterVfs;
 
   if result then begin
-    VfsIsRunning := false;
+    result := FindVfsItemByNormalizedPath(AbsVirtPath, VfsItem) and VfsItem.IsDir;
-    VfsItems.Clear();
+
+    if result then begin
+      DirInfo := VfsItem.Info;
+
+      if VfsItem.Children <> nil then begin
+        NormalizedMask := StrLib.WideLowerCase(Mask);
+
+        for i := 0 to VfsItem.Children.Count - 1 do begin
+          if StrLib.MatchW(TVfsItem(VfsItem.Children[i]).SearchName, NormalizedMask) then begin
+            DirListing.AddItem(@TVfsItem(VfsItem.Children[i]).Info);
+          end;
+        end;
+      end; // .if
+    end; // .if
+
     LeaveVfs;
-  end;
+  end; // .if
-end;
+end; // .function GetVfsDirInfo
 
 procedure CopyFileInfoWithoutNames (var Src, Dest: WinNative.FILE_ID_BOTH_DIR_INFORMATION);
 begin

VfsOpenFiles.pas

@@ -0,0 +1,172 @@
+unit VfsOpenFiles;
+(*
+  Author:      Alexander Shostak aka Berserker aka EtherniDee.
+  Description: Provides concurrent storage for additional information for each file handle,
+               fully integrated to file handles life cycle.
+               The unit works independently of other VFS subsystems, guaranteeing relative paths
+               resolution capability (conversion of directory handle into directory path).
+               Most NT file APIs can work with pairs of [hDir, RelativePath] (@see WinNative.TObjectAttributes).
+*)
+
+
+(***)  interface  (***)
+
+uses
+  Windows, SysUtils,
+  Utils, Concur, DataLib, StrLib,
+  VfsUtils, VfsBase;
+
+type
+  (* Import *)
+  TVfsItem = VfsBase.TVfsItem;
+
+type
+  (* Extra information for file handle. Working with structure must be protected by corresponding critical section *)
+  TOpenedFile = class
+   public
+    (* Handle for either virtual or real path *)
+    hFile: Windows.THandle;
+
+    (* Virtual path to file (path given to NtCreate API) *)
+    AbsPath: WideString;
+
+    (* Directory listing (both real and virtual children). Created on the fly on FillDirListing call *)
+    {On} DirListing: VfsUtils.TDirListing;
+
+    constructor Create (hFile: Windows.THandle; const AbsPath: WideString);
+    destructor Destroy; override;
+
+    (* Makes complete directory listing, including real and virtual items. Does nothing if listing already exists *)
+    procedure FillDirListing (const Mask: WideString);
+  end; // .class TOpenedFile
+
+var
+  OpenFilesCritSection: Concur.TCritSection;
+
+
+(* Returns absolute virtual/real path to opened file by its handle in a thread-safe way. Empty string on failure. The result path is the one, passed to open file API *)
+function GetOpenedFilePath (hFile: Windows.THandle): WideString;
+
+(* Atomically replaces TOpenedFile record for given file handle *)
+procedure SetOpenedFileInfo (hFile: Windows.THandle; {On} OpenedFile: TOpenedFile);
+
+(* Atomically deletes TOpenedFile information by file handle *)
+procedure DeleteOpenedFileInfo (hFile: Windows.THandle);
+
+
+(***)  implementation  (***)
+
+
+var
+(* Map of all tracked file handles => TOpenedFile. Protected by corresponding critical section *)
+{O} OpenedFiles: {O} TObjDict {of TOpenedFile};
+
+
+constructor TOpenedFile.Create (hFile: Windows.THandle; const AbsPath: WideString);
+begin
+  Self.hFile   := hFile;
+  Self.AbsPath := AbsPath;
+end;
+
+destructor TOpenedFile.Destroy;
+begin
+  FreeAndNil(Self.DirListing);
+end;
+
+procedure TOpenedFile.FillDirListing (const Mask: WideString);
+var
+{On} ExcludedItems:  {U} TDict {OF not nil};
+     VfsItemFound:   boolean;
+     NumVfsChildren: integer;
+     DirInfo:        TNativeFileInfo;
+     ParentDirInfo:  TNativeFileInfo;
+     DirItem:        TFileInfo;
+     i:              integer;
+
+begin
+  ExcludedItems := nil;
+  // * * * * * //
+  if Self.DirListing <> nil then begin
+    exit;
+  end;
+
+  Self.DirListing := TDirListing.Create;
+  VfsItemFound    := VfsBase.GetVfsDirInfo(Self.AbsPath, Mask, DirInfo, Self.DirListing);
+  ExcludedItems   := DataLib.NewDict(not Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE);
+
+  if VfsItemFound then begin
+    while DirListing.GetNextItem(DirItem) do begin
+      ExcludedItems[WideStrToCaselessKey(DirItem.Data.FileName)] := Ptr(1);
+    end;
+
+    Self.DirListing.Rewind;
+  end;
+
+  // Add real items
+  NumVfsChildren := Self.DirListing.Count;
+
+  with VfsBase.GetThreadVfsDisabler do begin
+    DisableVfsForThread;
+    VfsUtils.GetDirectoryListing(Self.AbsPath, Mask, ExcludedItems, Self.DirListing);
+    RestoreVfsForThread;
+  end;
+
+  // No real items added, maybe there is a need to add '.' and/or '..' manually
+  if VfsItemFound and (Self.DirListing.Count = NumVfsChildren) then begin
+    if StrLib.MatchW('.', Mask) then begin
+      Self.DirListing.AddItem(@DirInfo, '.');
+    end;
+
+    if StrLib.MatchW('..', Mask) and VfsUtils.GetFileInfo(Self.AbsPath + '\..', ParentDirInfo) then begin
+      Self.DirListing.AddItem(@ParentDirInfo, '..');
+    end;
+  end;
+  // * * * * * //
+  SysUtils.FreeAndNil(ExcludedItems);
+end; // .procedure TOpenedFile.FillDirListing
+
+function GetOpenedFilePath (hFile: Windows.THandle): WideString;
+var
+{n} OpenedFile: TOpenedFile;
+
+begin
+  OpenedFile := nil;
+  result     := '';
+  // * * * * * //
+  with OpenFilesCritSection do begin
+    Enter;
+
+    OpenedFile := OpenedFiles[pointer(hFile)];
+
+    if OpenedFile <> nil then begin
+      result := OpenedFile.AbsPath;
+    end;
+
+    Leave;
+  end;
+end; // .function GetOpenedFilePath
+
+procedure SetOpenedFileInfo (hFile: Windows.THandle; {On} OpenedFile: TOpenedFile);
+begin
+  with OpenFilesCritSection do begin
+    Enter;
+    OpenedFiles[pointer(hFile)] := OpenedFile; OpenedFile := nil;
+    Leave;
+  end;
+  // * * * * * //
+  SysUtils.FreeAndNil(OpenedFile);
+end;
+
+procedure DeleteOpenedFileInfo (hFile: Windows.THandle);
+begin
+  with OpenFilesCritSection do begin
+    Enter;
+    OpenedFiles.DeleteItem(pointer(hFile));
+    Leave;
+  end;
+end;
+
+begin
+  OpenFilesCritSection.Init;
+  OpenedFiles := DataLib.NewObjDict(Utils.OWNS_ITEMS);
+end.

VfsTest.dpr

@@ -2,8 +2,10 @@ program VfsTest;
 
 uses
   TestFramework, GuiTestRunner,
-  VfsUtils, VfsBase, VfsDebug, VfsExport,
+  VfsUtils, VfsBase, VfsDebug,
-  VfsDebugTest;
+  VfsApiDigger, VfsExport, VfsOpenFiles,
+  VfsDebugTest, VfsUtilsTest, VfsBaseTest,
+  VfsApiDiggerTest, VfsOpenFilesTest;
 
 begin
   TGUITestRunner.RunRegisteredTests;

VfsTest.dproj

@@ -34,10 +34,11 @@
       
       
       
+      
+      
       <Excluded_Packages Name="$(BDS)\bin\dcloffice2k100.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
       <Excluded_Packages Name="$(BDS)\bin\dclofficexp100.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
-    </Excluded_Packages>
+    </Excluded_Packages></Delphi.Personality></BorlandProject></BorlandProject>
-  </Delphi.Personality></BorlandProject></BorlandProject>
   </ProjectExtensions>
   <Import Project="$(MSBuildBinPath)\Borland.Delphi.Targets" />
   <ItemGroup>

VfsUtils.pas

@@ -58,13 +58,15 @@ type
 
     function  IsEnd: boolean;
     procedure AddItem ({U} FileInfo: PNativeFileInfo; const FileName: WideString = ''; const InsertBefore: integer = High(integer));
-    function  GetNextItem ({OUT} var Res: TFileInfo): boolean;
+    function  GetNextItem ({OUT} var {U} Res: TFileInfo): boolean;
     procedure Rewind;
 
     (* Always seeks as close as possible *)
     function Seek (SeekInd: integer): boolean;
     function SeekRel (RelInd: integer): boolean;
 
+    function GetDebugDump: string;
+
     property FileInd: integer read fFileInd;
     property Count:   integer read GetCount;
   end; // .class TDirListing
@@ -95,6 +97,11 @@ type
     function IterNext ({OUT} var FileName: WideString; {n} FileInfo: WinNative.PFILE_ID_BOTH_DIR_INFORMATION = nil): boolean;
   end; // .class TSysDirScanner
 
+(* Packs lower cased WideString bytes into AnsiString buffer *)
+function WideStrToCaselessKey (const Str: WideString): string;
+
+(* The opposite of WideStrToKey *)
+function CaselessKeyToWideStr (const CaselessKey: string): WideString;
 
 (* Returns expanded unicode path, preserving trailing delimiter, or original path on error *)
 function ExpandPath (const Path: WideString): WideString;
@@ -117,7 +124,7 @@ function StripNtAbsPathPrefix (const Path: WideString): WideString;
 function SaveAndRet (Res: integer; out ResCopy): integer;
 
 (* Opens file/directory using absolute NT path and returns success flag *)
-function SysOpenFile (const NtAbsPath: WideString; {OUT} var Res: Windows.THandle; const OpenMode: TSysOpenFileMode = OPEN_AS_ANY; const AccessMode: integer = Int(GENERIC_READ) or SYNCHRONIZE): boolean;
+function SysOpenFile (const NtAbsPath: WideString; {OUT} var Res: Windows.THandle; const OpenMode: TSysOpenFileMode = OPEN_AS_ANY; const AccessMode: ACCESS_MASK = GENERIC_READ or SYNCHRONIZE): boolean;
 
 (* Returns TNativeFileInfo record for single file/directory. Short names and files indexes/ids in the result are always empty. *)
 function GetFileInfo (const FilePath: WideString; {OUT} var Res: TNativeFileInfo): boolean;
@@ -125,9 +132,44 @@ function GetFileInfo (const FilePath: WideString; {OUT} var Res: TNativeFileInfo
 function SysScanDir (const hDir: Windows.THandle; const Mask: WideString): ISysDirScanner; overload;
 function SysScanDir (const DirPath, Mask: WideString): ISysDirScanner; overload;
 
+(* Scans specified directory and adds sorted entries to directory listing. Optionally exclude names from Exclude dictionary.
+   Excluded items must be preprocessed via WideStringToCaselessKey routine *)
+procedure GetDirectoryListing (const SearchPath, FileMask: WideString; {Un} Exclude: TDict {OF CaselessKey => not NIL}; DirListing: TDirListing);
+
 (***)  implementation  (***)
 
 
+type
+  TDirListingItem = class
+    SearchName: WideString;
+    Info:       TNativeFileInfo;
+  end;
+
+
+function WideStrToCaselessKey (const Str: WideString): string;
+var
+  ProcessedPath: WideString;
+
+begin
+  result := '';
+
+  if Str <> '' then begin
+    ProcessedPath := StrLib.WideLowerCase(Str);
+    SetLength(result, Length(ProcessedPath) * sizeof(ProcessedPath[1]) div sizeof(result[1]));
+    Utils.CopyMem(Length(result) * sizeof(result[1]), PWideChar(ProcessedPath), PChar(result));
+  end;
+end;
+
+function CaselessKeyToWideStr (const CaselessKey: string): WideString;
+begin
+  result := '';
+
+  if CaselessKey <> '' then begin
+    SetLength(result, Length(CaselessKey) * sizeof(CaselessKey[1]) div sizeof(result[1]));
+    Utils.CopyMem(Length(result) * sizeof(result[1]), pchar(CaselessKey), PWideChar(result));
+  end;
+end;
+
 function ExpandPath (const Path: WideString): WideString;
 var
   BufLen:         integer;
@@ -309,7 +351,22 @@ begin
   result := Self.Seek(Self.fFileInd + RelInd);    
 end;
 
-function SysOpenFile (const NtAbsPath: WideString; {OUT} var Res: Windows.THandle; const OpenMode: TSysOpenFileMode = OPEN_AS_ANY; const AccessMode: integer = Int(GENERIC_READ) or SYNCHRONIZE): boolean;
+function TDirListing.GetDebugDump: string;
+var
+  FileNames: Utils.TArrayOfStr;
+  i:         integer;
+
+begin
+  SetLength(FileNames, Self.fFileList.Count);
+
+  for i := 0 to Self.fFileList.Count - 1 do begin
+    FileNames[i] := TFileInfo(Self.fFileList[i]).Data.FileName;
+  end;
+
+  result := StrLib.Join(FileNames, #13#10);
+end;
+
+function SysOpenFile (const NtAbsPath: WideString; {OUT} var Res: Windows.THandle; const OpenMode: TSysOpenFileMode = OPEN_AS_ANY; const AccessMode: ACCESS_MASK = GENERIC_READ or SYNCHRONIZE): boolean;
 var
   FilePathU:     WinNative.UNICODE_STRING;
   hFile:         Windows.THandle;
@@ -478,4 +535,50 @@ begin
   result := TSysDirScanner.Create(DirPath, Mask);
 end;
 
+function CompareFileItemsByNameAsc (Item1, Item2: integer): integer;
+begin
+  result := StrLib.CompareBinStringsW(TDirListingItem(Item1).SearchName, TDirListingItem(Item2).SearchName);
+
+  if result = 0 then begin
+    result := StrLib.CompareBinStringsW(TDirListingItem(Item1).Info.FileName, TDirListingItem(Item2).Info.FileName);
+  end;
+end;
+
+procedure SortDirListing ({U} List: TList {OF TDirListingItem});
+begin
+  List.CustomSort(CompareFileItemsByNameAsc);
+end;
+
+procedure GetDirectoryListing (const SearchPath, FileMask: WideString; {Un} Exclude: TDict {OF CaselessKey => not NIL}; DirListing: TDirListing);
+var
+{O} Items: {O} TList {OF TDirListingItem};
+{O} Item:  {O} TDirListingItem;
+    i:     integer;
+
+begin
+  {!} Assert(DirListing <> nil);
+  // * * * * * //
+  Items := DataLib.NewList(Utils.OWNS_ITEMS);
+  Item  := TDirListingItem.Create;
+  // * * * * * //
+  with VfsUtils.SysScanDir(SearchPath, FileMask) do begin
+    while IterNext(Item.Info.FileName, @Item.Info.Base) do begin     
+      if (Exclude = nil) or (Exclude[WideStrToCaselessKey(Item.Info.FileName)] = nil) then begin
+        Item.SearchName := StrLib.WideLowerCase(Item.Info.FileName);
+        Items.Add(Item); Item := nil;
+        Item := TDirListingItem.Create;
+      end;
+    end;
+  end;
+
+  SortDirListing(Items);
+
+  for i := 0 to Items.Count - 1 do begin
+    DirListing.AddItem(@TDirListingItem(Items[i]).Info);
+  end;
+  // * * * * * //
+  SysUtils.FreeAndNil(Items);
+  SysUtils.FreeAndNil(Item);
+end; // .procedure GetDirectoryListing
+
 end.