diff --git a/Tests/Fs/503.html b/Tests/Fs/503.html new file mode 100644 index 0000000..0ec2380 --- /dev/null +++ b/Tests/Fs/503.html @@ -0,0 +1 @@ +Server temporarily non accessible. \ No newline at end of file diff --git a/Tests/Fs/Mods/A/eula.1028.txt b/Tests/Fs/Mods/A/eula.1028.txt new file mode 100644 index 0000000..0966a6c Binary files /dev/null and b/Tests/Fs/Mods/A/eula.1028.txt differ diff --git a/Tests/Fs/Mods/A/vcredist.bmp b/Tests/Fs/Mods/A/vcredist.bmp new file mode 100644 index 0000000..e69de29 diff --git a/Tests/Fs/Mods/B/vcredist.bmp b/Tests/Fs/Mods/B/vcredist.bmp new file mode 100644 index 0000000..a019e73 Binary files /dev/null and b/Tests/Fs/Mods/B/vcredist.bmp differ diff --git a/Tests/Fs/Mods/FullyVirtual/Hobbots/mms.cfg b/Tests/Fs/Mods/FullyVirtual/Hobbots/mms.cfg new file mode 100644 index 0000000..7908f47 --- /dev/null +++ b/Tests/Fs/Mods/FullyVirtual/Hobbots/mms.cfg @@ -0,0 +1,2 @@ +SilentAutoUpdateEnable=1 +AutoUpdateDisable=0 diff --git a/Tests/Fs/default b/Tests/Fs/default new file mode 100644 index 0000000..2688479 --- /dev/null +++ b/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; + } +} \ No newline at end of file diff --git a/Tests/VfsApiDiggerTest.pas b/Tests/VfsApiDiggerTest.pas new file mode 100644 index 0000000..b2ed301 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/Tests/VfsBaseTest.pas b/Tests/VfsBaseTest.pas new file mode 100644 index 0000000..9ce9ba7 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/Tests/VfsOpenFilesTest.pas b/Tests/VfsOpenFilesTest.pas new file mode 100644 index 0000000..ebea9f8 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/Tests/VfsUtilsTest.pas b/Tests/VfsUtilsTest.pas new file mode 100644 index 0000000..412204b --- /dev/null +++ b/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. \ No newline at end of file diff --git a/Vfs.dproj.local b/Vfs.dproj.local new file mode 100644 index 0000000..b3811b7 --- /dev/null +++ b/Vfs.dproj.local @@ -0,0 +1,2 @@ + + diff --git a/Vfs.drc b/Vfs.drc new file mode 100644 index 0000000..4293adf --- /dev/null +++ b/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. +*/ + diff --git a/VfsApiDigger.pas b/VfsApiDigger.pas new file mode 100644 index 0000000..27585f0 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/VfsBase.pas b/VfsBase.pas index 9b51d23..94637e4 100644 --- a/VfsBase.pas +++ b/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); -function ResetVfs: boolean; +function GetThreadVfsDisabler: TThreadVfsDisabler; + +(* 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; @@ -96,9 +112,6 @@ var Represents the whole cached virtual file system contents. *) {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,31 +262,93 @@ begin end; end; // .procedure BuildVfsItemsTree -procedure RunVfs (DirListingOrder: TDirListingSortType); +function RunVfs (DirListingOrder: TDirListingSortType): boolean; begin - with VfsCritSection do begin - Enter; + result := not DisableVfsForThisThread; - if not VfsIsRunning then begin - BuildVfsItemsTree(); - SortVfsDirListings(DirListingOrder); - VfsIsRunning := true; + if result then begin + with VfsCritSection do begin + Enter; + + if not VfsIsRunning then begin + BuildVfsItemsTree(); + SortVfsDirListings(DirListingOrder); + VfsIsRunning := true; + end; + + Leave; end; - - Leave; end; -end; // .procedure RunVfs +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; - VfsItems.Clear(); + result := FindVfsItemByNormalizedPath(AbsVirtPath, VfsItem) and VfsItem.IsDir; + + 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; + end; // .if +end; // .function GetVfsDirInfo procedure CopyFileInfoWithoutNames (var Src, Dest: WinNative.FILE_ID_BOTH_DIR_INFORMATION); begin diff --git a/VfsOpenFiles.pas b/VfsOpenFiles.pas new file mode 100644 index 0000000..e28e637 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/VfsTest.dpr b/VfsTest.dpr index 98be871..702b9eb 100644 --- a/VfsTest.dpr +++ b/VfsTest.dpr @@ -2,8 +2,10 @@ program VfsTest; uses TestFramework, GuiTestRunner, - VfsUtils, VfsBase, VfsDebug, VfsExport, - VfsDebugTest; + VfsUtils, VfsBase, VfsDebug, + VfsApiDigger, VfsExport, VfsOpenFiles, + VfsDebugTest, VfsUtilsTest, VfsBaseTest, + VfsApiDiggerTest, VfsOpenFilesTest; begin TGUITestRunner.RunRegisteredTests; diff --git a/VfsTest.dproj b/VfsTest.dproj index 0c7f577..b61cad3 100644 --- a/VfsTest.dproj +++ b/VfsTest.dproj @@ -27,7 +27,9 @@ Delphi.Personality VCLApplication -FalseTrueFalseFalseFalse1000FalseFalseFalseFalseFalse104912511.0.0.01.0.0.0VfsTest.dpr +FalseTrueFalseFalseFalse1000FalseFalseFalseFalseFalse104912511.0.0.01.0.0.0VfsTest.dpr + + @@ -36,8 +38,7 @@ Microsoft Office 2000 Sample Automation Server Wrapper Components Microsoft Office XP Sample Automation Server Wrapper Components - - + diff --git a/VfsUtils.pas b/VfsUtils.pas index bc19da0..12b6d23 100644 --- a/VfsUtils.pas +++ b/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; @@ -319,7 +376,7 @@ var begin FilePathU.AssignExistingStr(NtAbsPath); ObjAttrs.Init(@FilePathU); - + result := WinNative.NtOpenFile(@hFile, AccessMode, @ObjAttrs, @IoStatusBlock, FILE_SHARE_READ or FILE_SHARE_WRITE, ord(OpenMode) or FILE_SYNCHRONOUS_IO_NONALERT) = WinNative.STATUS_SUCCESS; if result then begin @@ -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. \ No newline at end of file