├── Tests ├── Fs │ ├── Mods │ │ ├── A │ │ │ ├── vcredist.bmp │ │ │ └── eula.1028.txt │ │ ├── Apache │ │ │ └── 503.html │ │ ├── FullyVirtual_2 │ │ │ └── Hobbots │ │ │ │ └── mms.cfg │ │ ├── FullyVirtual │ │ │ └── Hobbots │ │ │ │ └── mms.cfg │ │ └── B │ │ │ └── vcredist.bmp │ ├── 503.html │ └── default ├── VfsMatchingTest.pas ├── VfsApiDiggerTest.pas ├── VfsTestHelper.pas ├── VfsDebugTest.pas ├── VfsBaseTest.pas ├── VfsOpenFilesTest.pas ├── VfsUtilsTest.pas └── VfsIntegratedTest.pas ├── Vfs.dproj.local ├── VfsTest.dproj.local ├── verpatch.exe ├── .gitignore ├── update_version.bat ├── Vfs.dpr ├── _update_dll.bat ├── _TODO_.txt ├── README.md ├── VfsTest.dpr ├── VfsDebug.pas ├── VfsImport.pas ├── VfsTest.dproj ├── Vfs.dproj ├── VfsExport.pas ├── VfsApiDigger.pas ├── VfsPatching.pas ├── VfsOpenFiles.pas ├── VfsControl.pas ├── VfsMatching.pas ├── Vfs.drc ├── VfsWatching.pas ├── VfsTest.drc ├── VfsUtils.pas ├── VfsBase.pas └── VfsHooks.pas /Tests/Fs/Mods/A/vcredist.bmp: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /Tests/Fs/503.html: -------------------------------------------------------------------------------- 1 | Server temporarily non accessible. -------------------------------------------------------------------------------- /Tests/Fs/Mods/Apache/503.html: -------------------------------------------------------------------------------- 1 | Please, call us later. -------------------------------------------------------------------------------- /Vfs.dproj.local: -------------------------------------------------------------------------------- 1 | 2 | 3 | -------------------------------------------------------------------------------- /Tests/Fs/Mods/FullyVirtual_2/Hobbots/mms.cfg: -------------------------------------------------------------------------------- 1 | It was a pleasure to override you, friend! -------------------------------------------------------------------------------- /VfsTest.dproj.local: -------------------------------------------------------------------------------- 1 | 2 | 3 | -------------------------------------------------------------------------------- /verpatch.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CloudDelphi/Virtual-File-System/HEAD/verpatch.exe -------------------------------------------------------------------------------- /Tests/Fs/Mods/FullyVirtual/Hobbots/mms.cfg: -------------------------------------------------------------------------------- 1 | SilentAutoUpdateEnable=1 2 | AutoUpdateDisable=0 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.dcu 2 | *.exe 3 | *.dll 4 | *.ini 5 | *.identcache 6 | *.map 7 | *.res 8 | _LOG_.txt 9 | __history/ -------------------------------------------------------------------------------- /update_version.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | cls 3 | echo Version (X.X.X.X [Text]): 4 | set /P v= 5 | verpatch vfs.dll "%v%" /va -------------------------------------------------------------------------------- /Tests/Fs/Mods/B/vcredist.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CloudDelphi/Virtual-File-System/HEAD/Tests/Fs/Mods/B/vcredist.bmp -------------------------------------------------------------------------------- /Tests/Fs/Mods/A/eula.1028.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/CloudDelphi/Virtual-File-System/HEAD/Tests/Fs/Mods/A/eula.1028.txt -------------------------------------------------------------------------------- /Vfs.dpr: -------------------------------------------------------------------------------- 1 | library Vfs; 2 | (* 3 | Author: Alexander Shostak aka Berserker aka EtherniDee. 4 | *) 5 | 6 | uses VfsExport; 7 | 8 | {$R *.RES} 9 | 10 | begin 11 | System.IsMultiThread := true; 12 | end. 13 | -------------------------------------------------------------------------------- /_update_dll.bat: -------------------------------------------------------------------------------- 1 | @echo off 2 | :start 3 | cls 4 | set h3dir=D:\Heroes 3 5 | copy /Y Vfs.dll "%h3dir%\vfs.dll" 6 | copy /Y Vfs.map "%h3dir%\Vfs.map" 7 | php "%h3dir%\Tools\ExeMapCompiler\compile.phc" "vfs.map" "%h3dir%/DebugMaps" 8 | echo. 9 | echo. 10 | echo %date% %time% 11 | echo. 12 | pause 13 | goto start -------------------------------------------------------------------------------- /Tests/Fs/default: -------------------------------------------------------------------------------- 1 | server { 2 | #listen 80 default; 3 | #server_name localhost; 4 | #deny all; 5 | access_log off; 6 | 7 | location / { 8 | proxy_set_header X-Real-IP $remote_addr; 9 | proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for; 10 | proxy_set_header Host $host; 11 | proxy_pass http://127.0.0.1:8080; 12 | } 13 | } -------------------------------------------------------------------------------- /_TODO_.txt: -------------------------------------------------------------------------------- 1 | UTF-8 Logging 2 | 3 | Editor/Development mode: 4 | Separate thread with FindFirstChangeNotificationA/FindNextChangeNotification on mods root dir + WaitForSingleObject 5 | + ResetVfs + BlockVfs + MapDir for each cached mapped directory + RunVfs. 6 | We will need some API like RefreshVfs. 7 | 8 | Add ANSI versions of exported API. 9 | 10 | Write VfsImport.pas nad vfs_import.c -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VFS (Virtual File System) 2 | Add Virtual File System support to your project. Implement Mods directory support in 2 lines of code. 3 | Virtually copies contents of any directory into any directory. Copied contents is available in read-only mode. 4 | 5 | ## Example: 6 | ```delphi 7 | VfsImport.MapModsFromListA('D:\Game', 'D:\Game\Mods', 'D:\Game\Mods\list.txt'); 8 | VfsImport.RunVfs(VfsImport.SORT_FIFO); 9 | ``` 10 | -------------------------------------------------------------------------------- /VfsTest.dpr: -------------------------------------------------------------------------------- 1 | program VfsTest; 2 | 3 | uses 4 | TestFramework, GuiTestRunner, 5 | VfsUtils, VfsBase, VfsDebug, 6 | VfsApiDigger, VfsExport, VfsOpenFiles, 7 | VfsHooks, VfsControl, VfsMatching, 8 | VfsTestHelper, VfsMatchingTest, 9 | VfsDebugTest, VfsUtilsTest, VfsBaseTest, 10 | VfsOpenFilesTest, VfsIntegratedTest; 11 | 12 | begin 13 | System.IsMultiThread := true; 14 | VfsTestHelper.InitConsole; 15 | TGUITestRunner.RunRegisteredTests; 16 | end. 17 | -------------------------------------------------------------------------------- /Tests/VfsMatchingTest.pas: -------------------------------------------------------------------------------- 1 | unit VfsMatchingTest; 2 | 3 | (***) interface (***) 4 | 5 | uses 6 | SysUtils, TestFramework, 7 | Utils, VfsMatching; 8 | 9 | type 10 | TestMatching = class (TTestCase) 11 | published 12 | procedure TestMatchPattern; 13 | end; 14 | 15 | (***) implementation (***) 16 | 17 | 18 | procedure TestMatching.TestMatchPattern (); 19 | begin 20 | Check(VfsMatching.MatchPattern('Nice picture.bak.bmp', '<.b?p>'), '{1}'); 21 | CheckFalse(VfsMatching.MatchPattern('Nice picture.bak.bmp', '<.b?mp>'), '{2}'); 22 | Check(VfsMatching.MatchPattern('this abb is a long abba story.txt', '*abba*.>xt>>>'), '{3}'); 23 | Check(VfsMatching.MatchPattern('what a brave', '*??r*<"""'), '{4}'); 24 | Check(VfsMatching.MatchPattern('.', '*<<*""">>>*<<""'), '{5}'); 25 | Check(VfsMatching.MatchPattern('', ''), '{6}'); 26 | CheckFalse(VfsMatching.MatchPattern('opportunity.png', '*p'), '{7}'); 27 | Check(VfsMatching.MatchPattern('opportunity.png', '*p*'), '{8}'); 28 | Check(VfsMatching.MatchPattern('', '*'), '{9}'); 29 | Check(VfsMatching.MatchPattern('.?.', '*'), '{10}'); 30 | Check(VfsMatching.MatchPattern('its the last hero of the night.docx', '*the*hero<.doc?'), '{11}'); 31 | end; 32 | 33 | begin 34 | RegisterTest(TestMatching.Suite); 35 | end. -------------------------------------------------------------------------------- /Tests/VfsApiDiggerTest.pas: -------------------------------------------------------------------------------- 1 | unit VfsApiDiggerTest; 2 | 3 | (***) interface (***) 4 | 5 | uses 6 | Windows, SysUtils, TestFramework, 7 | Utils, WinUtils, DataLib, 8 | VfsApiDigger; 9 | 10 | type 11 | TestApiDigger = class (TTestCase) 12 | published 13 | procedure DetermineRealApiAddress; 14 | end; 15 | 16 | 17 | (***) implementation (***) 18 | 19 | 20 | procedure TestApiDigger.DetermineRealApiAddress; 21 | type 22 | TGetCurrentProcessId = function (): integer; stdcall; 23 | 24 | var 25 | Kernel32Handle: THandle; 26 | KernelBaseHandle: THandle; 27 | NormalProc: TGetCurrentProcessId; 28 | RealProc: TGetCurrentProcessId; 29 | TestProc: TGetCurrentProcessId; 30 | 31 | begin 32 | Kernel32Handle := Windows.GetModuleHandle('kernel32.dll'); 33 | KernelBaseHandle := Windows.GetModuleHandle('kernelbase.dll'); 34 | 35 | if (Kernel32Handle <> 0) and (KernelBaseHandle <> 0) then begin 36 | NormalProc := Windows.GetProcAddress(Kernel32Handle, 'GetCurrentProcessId'); 37 | RealProc := Windows.GetProcAddress(KernelBaseHandle, 'GetCurrentProcessId'); 38 | 39 | if (@NormalProc <> nil) and (@RealProc <> nil) then begin 40 | VfsApiDigger.FindOutRealSystemApiAddrs([Kernel32Handle]); 41 | TestProc := VfsApiDigger.GetRealProcAddress(Kernel32Handle, 'GetCurrentProcessId'); 42 | 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)])); 43 | end; 44 | end; 45 | end; 46 | 47 | begin 48 | RegisterTest(TestApiDigger.Suite); 49 | end. -------------------------------------------------------------------------------- /Tests/VfsTestHelper.pas: -------------------------------------------------------------------------------- 1 | unit VfsTestHelper; 2 | (* 3 | 4 | *) 5 | 6 | 7 | (***) interface (***) 8 | 9 | uses 10 | SysUtils, Windows, 11 | Utils, WinUtils, StrLib; 12 | 13 | (* Initializes debug console *) 14 | procedure InitConsole; 15 | 16 | (* Returns absolute path to directory with test contents *) 17 | function GetTestsRootDir: WideString; 18 | 19 | 20 | (***) implementation (***) 21 | 22 | 23 | procedure InitConsole; 24 | var 25 | Rect: TSmallRect; 26 | BufSize: TCoord; 27 | hIn: THandle; 28 | hOut: THandle; 29 | 30 | begin 31 | AllocConsole; 32 | SetConsoleCP(GetACP); 33 | SetConsoleOutputCP(GetACP); 34 | hIn := GetStdHandle(STD_INPUT_HANDLE); 35 | hOut := GetStdHandle(STD_OUTPUT_HANDLE); 36 | pinteger(@System.Input)^ := hIn; 37 | pinteger(@System.Output)^ := hOut; 38 | BufSize.x := 120; 39 | BufSize.y := 1000; 40 | SetConsoleScreenBufferSize(hOut, BufSize); 41 | Rect.Left := 0; 42 | Rect.Top := 0; 43 | Rect.Right := 120 - 1; 44 | Rect.Bottom := 50 - 1; 45 | SetConsoleWindowInfo(hOut, true, Rect); 46 | SetConsoleTextAttribute(hOut, (0 shl 4) or $0F); 47 | end; // .procedure InitConsole; 48 | 49 | function GetTestsRootDir: WideString; 50 | var 51 | Caret: PWideChar; 52 | 53 | begin 54 | result := WinUtils.GetExePath; 55 | {!} Assert(result <> '', 'Failed to get full path to current executable file'); 56 | 57 | result := StrLib.ExtractDirPathW(WinUtils.GetExePath); 58 | {!} Assert(result <> '', 'Failed to extract executable file directory path'); 59 | 60 | if result[Length(result)] <> '\' then begin 61 | result := result + '\Tests\Fs'; 62 | end else begin 63 | result := result + 'Tests\Fs'; 64 | end; 65 | end; // .function GetTestsRootDir 66 | 67 | end. -------------------------------------------------------------------------------- /Tests/VfsDebugTest.pas: -------------------------------------------------------------------------------- 1 | unit VfsDebugTest; 2 | {$ASSERTIONS ON} 3 | 4 | (***) interface (***) 5 | 6 | uses 7 | SysUtils, TestFramework, 8 | Utils, VfsDebug; 9 | 10 | type 11 | TestDebug = class (TTestCase) 12 | private 13 | procedure TestAssertHandler; 14 | 15 | published 16 | procedure TestLogging; 17 | end; 18 | 19 | (***) implementation (***) 20 | 21 | 22 | var 23 | LogContents: string; 24 | 25 | procedure ClearLog; 26 | begin 27 | LogContents := ''; 28 | end; 29 | 30 | function GetLog: string; 31 | begin 32 | result := LogContents; 33 | end; 34 | 35 | procedure WriteLog (const Operation, Message: pchar); stdcall; 36 | begin 37 | LogContents := LogContents + Operation + ';' + Message; 38 | end; 39 | 40 | procedure TestDebug.TestAssertHandler (); 41 | var 42 | Raised: boolean; 43 | 44 | begin 45 | Raised := false; 46 | 47 | try 48 | System.Assert(false, 'Some assertion message'); 49 | except 50 | on E: VfsDebug.EAssertFailure do Raised := true; 51 | end; 52 | 53 | Check(Raised, 'Assertion should raise EAssertFailure exception'); 54 | end; 55 | 56 | procedure TestDebug.TestLogging; 57 | var 58 | PrevLoggingProc: VfsDebug.TLoggingProc; 59 | 60 | begin 61 | PrevLoggingProc := Ptr(1); 62 | // * * * * * // 63 | try 64 | ClearLog; 65 | PrevLoggingProc := VfsDebug.SetLoggingProc(@WriteLog); 66 | VfsDebug.WriteLog('TestOperation', 'TestMessage'); 67 | Check(GetLog() = 'TestOperation;TestMessage', 'Custom logging proc should have written certain message to log'); 68 | VfsDebug.SetLoggingProc(PrevLoggingProc); 69 | 70 | ClearLog; 71 | VfsDebug.SetLoggingProc(nil); 72 | VfsDebug.WriteLog('TestOperation', 'TestMessage'); 73 | Check(GetLog() = '', 'Nil logging proc must not write anything to log'); 74 | VfsDebug.SetLoggingProc(PrevLoggingProc); 75 | finally 76 | if @PrevLoggingProc <> Ptr(1) then begin 77 | VfsDebug.SetLoggingProc(PrevLoggingProc); 78 | end; 79 | end; // .try 80 | end; // .procedure TestDebug.TestLogging 81 | 82 | begin 83 | RegisterTest(TestDebug.Suite); 84 | end. -------------------------------------------------------------------------------- /Tests/VfsBaseTest.pas: -------------------------------------------------------------------------------- 1 | unit VfsBaseTest; 2 | 3 | (***) interface (***) 4 | 5 | uses 6 | SysUtils, TestFramework, 7 | Utils, WinUtils, 8 | VfsUtils, VfsBase, VfsTestHelper; 9 | 10 | type 11 | TestBase = class (TTestCase) 12 | protected 13 | procedure SetUp; override; 14 | procedure TearDown; override; 15 | 16 | published 17 | procedure TestVirtualDirMapping; 18 | end; 19 | 20 | (***) implementation (***) 21 | 22 | 23 | procedure TestBase.SetUp; 24 | begin 25 | VfsBase.ResetVfs(); 26 | end; 27 | 28 | procedure TestBase.TearDown; 29 | begin 30 | VfsBase.ResetVfs(); 31 | end; 32 | 33 | procedure TestBase.TestVirtualDirMapping; 34 | var 35 | DirListing: TDirListing; 36 | DirInfo: TNativeFileInfo; 37 | RootDir: WideString; 38 | FileInfo: TFileInfo; 39 | i: integer; 40 | 41 | begin 42 | DirListing := TDirListing.Create; 43 | FileInfo := nil; 44 | // * * * * * // 45 | RootDir := VfsTestHelper.GetTestsRootDir; 46 | VfsBase.MapDir(RootDir, VfsUtils.MakePath([RootDir, 'Mods\B']), DONT_OVERWRITE_EXISTING); 47 | VfsBase.MapDir(RootDir, VfsUtils.MakePath([RootDir, 'Mods\A']), DONT_OVERWRITE_EXISTING); 48 | VfsBase.RunVfs(SORT_FIFO); 49 | 50 | VfsBase.PauseVfs; 51 | VfsBase.GetVfsDirInfo(RootDir, '*', DirInfo, DirListing); 52 | DirListing.Rewind; 53 | CheckEquals('', DirListing.GetDebugDump(), 'Virtual directory listing must be empty when VFS is paused'); 54 | 55 | VfsBase.RunVfs(SORT_FIFO); 56 | VfsBase.GetVfsDirInfo(RootDir, '*', DirInfo, DirListing); 57 | DirListing.Rewind; 58 | CheckEquals('vcredist.bmp'#13#10'eula.1028.txt', DirListing.GetDebugDump(), 'Invalid virtual directoring listing'); 59 | 60 | DirListing.Rewind; 61 | 62 | for i := 0 to DirListing.Count - 1 do begin 63 | DirListing.GetNextItem(FileInfo); 64 | 65 | if FileInfo.Data.FileName = 'vcredist.bmp' then begin 66 | CheckEquals(5686, FileInfo.Data.GetFileSize(), 'File from A mod must not override same file from B mod'); 67 | end; 68 | end; 69 | // * * * * * // 70 | SysUtils.FreeAndNil(DirListing); 71 | end; 72 | 73 | begin 74 | RegisterTest(TestBase.Suite); 75 | end. -------------------------------------------------------------------------------- /VfsDebug.pas: -------------------------------------------------------------------------------- 1 | unit VfsDebug; 2 | (* 3 | Author: Alexander Shostak aka Berserker aka Ethernidee. 4 | Description: Provides logging and debugging capabilities for VFS project. 5 | *) 6 | 7 | 8 | (***) interface (***) 9 | 10 | uses 11 | Windows, SysUtils, 12 | Utils, StrLib, Concur, DlgMes; 13 | 14 | type 15 | TLoggingProc = procedure (Operation, Message: pchar); stdcall; 16 | 17 | EAssertFailure = class (Exception) 18 | end; 19 | 20 | 21 | function SetLoggingProc ({n} Handler: TLoggingProc): {n} TLoggingProc; stdcall; 22 | procedure WriteLog (const Operation, Message: string); 23 | procedure WriteLog_ (const Operation, Message: pchar); stdcall; 24 | 25 | 26 | var 27 | (* For external non-100% reliable fast checks of logging subsystem state *) 28 | LoggingEnabled: boolean = false; 29 | 30 | 31 | (***) implementation (***) 32 | 33 | 34 | var 35 | LogCritSection: Concur.TCritSection; 36 | {n} LoggingProc: TLoggingProc; 37 | 38 | 39 | function SetLoggingProc ({n} Handler: TLoggingProc): {n} TLoggingProc; stdcall; 40 | begin 41 | with LogCritSection do begin 42 | Enter; 43 | result := @LoggingProc; 44 | LoggingProc := Handler; 45 | LoggingEnabled := @LoggingProc <> nil; 46 | Leave; 47 | end; 48 | end; 49 | 50 | procedure WriteLog (const Operation, Message: string); 51 | begin 52 | WriteLog_(pchar(Operation), pchar(Message)); 53 | end; 54 | 55 | procedure WriteLog_ (const Operation, Message: pchar); 56 | begin 57 | if LoggingEnabled then begin 58 | with LogCritSection do begin 59 | Enter; 60 | 61 | if @LoggingProc <> nil then begin 62 | LoggingProc(Operation, Message); 63 | end; 64 | 65 | Leave; 66 | end; 67 | end; 68 | end; 69 | 70 | procedure AssertHandler (const Mes, FileName: string; LineNumber: integer; Address: pointer); 71 | var 72 | CrashMes: string; 73 | 74 | begin 75 | CrashMes := StrLib.BuildStr 76 | ( 77 | 'Assert violation in file "~FileName~" on line ~Line~.'#13#10'Error at address: $~Address~.'#13#10'Message: "~Message~"', 78 | [ 79 | 'FileName', FileName, 80 | 'Line', SysUtils.IntToStr(LineNumber), 81 | 'Address', SysUtils.Format('%x', [integer(Address)]), 82 | 'Message', Mes 83 | ], 84 | '~' 85 | ); 86 | 87 | WriteLog('AssertHandler', CrashMes); 88 | 89 | DlgMes.MsgError(CrashMes); 90 | 91 | raise EAssertFailure.Create(CrashMes) at Address; 92 | end; // .procedure AssertHandler 93 | 94 | 95 | begin 96 | LogCritSection.Init; 97 | AssertErrorProc := AssertHandler; 98 | end. -------------------------------------------------------------------------------- /Tests/VfsOpenFilesTest.pas: -------------------------------------------------------------------------------- 1 | unit VfsOpenFilesTest; 2 | 3 | (***) interface (***) 4 | 5 | uses 6 | Windows, SysUtils, TestFramework, 7 | Utils, WinUtils, DataLib, 8 | VfsBase, VfsUtils, VfsOpenFiles, 9 | VfsTestHelper; 10 | 11 | type 12 | TestOpenFiles = class (TTestCase) 13 | protected 14 | procedure SetUp; override; 15 | procedure TearDown; override; 16 | 17 | published 18 | procedure GetCombinedDirListing; 19 | end; 20 | 21 | 22 | (***) implementation (***) 23 | 24 | 25 | procedure TestOpenFiles.SetUp; 26 | begin 27 | VfsBase.ResetVfs(); 28 | end; 29 | 30 | procedure TestOpenFiles.TearDown; 31 | begin 32 | VfsBase.ResetVfs(); 33 | end; 34 | 35 | procedure TestOpenFiles.GetCombinedDirListing; 36 | const 37 | VALID_FULLY_VIRT_DIR_LISTING = 'mms.cfg'#13#10'.'#13#10'..'; 38 | VALID_COMBINED_LISTING = 'Hobbots'#13#10'vcredist.bmp'#13#10'.'#13#10'..'#13#10'503.html'#13#10'default'#13#10'Mods'; 39 | VALID_COMBINED_MASKED_LISTING = '503.html'; 40 | 41 | var 42 | {O} OpenedFile: VfsOpenFiles.TOpenedFile; 43 | DirPath: WideString; 44 | RootDir: WideString; 45 | 46 | begin 47 | OpenedFile := nil; 48 | // * * * * * // 49 | RootDir := VfsTestHelper.GetTestsRootDir; 50 | VfsBase.MapDir(RootDir, VfsUtils.MakePath([RootDir, '\Mods\FullyVirtual']), DONT_OVERWRITE_EXISTING); 51 | VfsBase.MapDir(RootDir, VfsUtils.MakePath([RootDir, '\Mods\B']), DONT_OVERWRITE_EXISTING); 52 | VfsBase.RunVfs(SORT_FIFO); 53 | 54 | DirPath := VfsUtils.NormalizePath(VfsUtils.MakePath([RootDir, '\Hobbots'])); 55 | OpenedFile := VfsOpenFiles.TOpenedFile.Create(777, DirPath); 56 | OpenedFile.FillDirListing('*'); 57 | Check(OpenedFile.DirListing <> nil, 'Directory listing must be assigned'); 58 | CheckEquals(VALID_FULLY_VIRT_DIR_LISTING, OpenedFile.DirListing.GetDebugDump(), 'Invalid listing for fully virtual directory "' + DirPath + '"'); 59 | FreeAndNil(OpenedFile); 60 | 61 | OpenedFile := VfsOpenFiles.TOpenedFile.Create(888, RootDir); 62 | OpenedFile.FillDirListing('*'); 63 | Check(OpenedFile.DirListing <> nil, 'Directory listing must be assigned'); 64 | CheckEquals(VALID_COMBINED_LISTING, OpenedFile.DirListing.GetDebugDump(), 'Invalid combined listing for directory "' + VfsUtils.MakePath([RootDir, '"'])); 65 | FreeAndNil(OpenedFile); 66 | 67 | OpenedFile := VfsOpenFiles.TOpenedFile.Create(999, RootDir); 68 | OpenedFile.FillDirListing('*.????'); 69 | Check(OpenedFile.DirListing <> nil, 'Directory listing must be assigned'); 70 | CheckEquals(VALID_COMBINED_MASKED_LISTING, OpenedFile.DirListing.GetDebugDump(), 'Invalid combined masked listing for directory "' + VfsUtils.MakePath([RootDir, '"'])); 71 | FreeAndNil(OpenedFile); 72 | // * * * * * // 73 | SysUtils.FreeAndNil(OpenedFile); 74 | end; 75 | 76 | begin 77 | RegisterTest(TestOpenFiles.Suite); 78 | end. -------------------------------------------------------------------------------- /Tests/VfsUtilsTest.pas: -------------------------------------------------------------------------------- 1 | unit VfsUtilsTest; 2 | 3 | (***) interface (***) 4 | 5 | uses 6 | SysUtils, TestFramework, 7 | Utils, WinUtils, DataLib, 8 | VfsUtils, VfsTestHelper; 9 | 10 | type 11 | TestUtils = class (TTestCase) 12 | published 13 | procedure TestAddBackslash; 14 | procedure TestMakePath; 15 | procedure TestNativeDirScanning; 16 | procedure TestGetDirectoryListing; 17 | end; 18 | 19 | 20 | (***) implementation (***) 21 | 22 | 23 | procedure TestUtils.TestAddBackslash; 24 | begin 25 | CheckEquals('\', VfsUtils.AddBackslash('')); 26 | CheckEquals('\\', VfsUtils.AddBackslash('\\')); 27 | CheckEquals('Abba\', VfsUtils.AddBackslash('Abba')); 28 | CheckEquals('Abba\', VfsUtils.AddBackslash('Abba\')); 29 | end; 30 | 31 | procedure TestUtils.TestMakePath; 32 | begin 33 | CheckEquals('', VfsUtils.MakePath(['', '\', '\\\'])); 34 | CheckEquals('', VfsUtils.MakePath([])); 35 | CheckEquals('apple\back\hero', VfsUtils.MakePath(['apple', 'back', 'hero'])); 36 | CheckEquals('apple\back\hero', VfsUtils.MakePath(['\\\\apple', '\\\back\\\\', '\', 'hero\\\\'])); 37 | end; 38 | 39 | procedure TestUtils.TestNativeDirScanning; 40 | var 41 | RootDir: WideString; 42 | FileInfo: VfsUtils.TNativeFileInfo; 43 | DirItems: DataLib.TStrList; 44 | DirContents: string; 45 | 46 | begin 47 | DirItems := DataLib.NewStrList(not Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE); 48 | // * * * * * // 49 | RootDir := VfsTestHelper.GetTestsRootDir; 50 | 51 | with SysScanDir(RootDir, '*') do begin 52 | while IterNext(FileInfo.FileName, @FileInfo.Base) do begin 53 | DirItems.Add(FileInfo.FileName); 54 | end; 55 | end; 56 | 57 | DirItems.Sort; 58 | DirContents := DirItems.ToText(#13#10); 59 | Check(DirContents = '.'#13#10'..'#13#10'503.html'#13#10'default'#13#10'Mods', 'Invalid directory listing. Got:'#13#10 + DirContents); 60 | // * * * * * // 61 | SysUtils.FreeAndNil(DirItems); 62 | end; // .procedure TestNativeDirScanning 63 | 64 | procedure TestUtils.TestGetDirectoryListing; 65 | var 66 | DirListing: VfsUtils.TDirListing; 67 | Exclude: DataLib.TDict {of not nil}; 68 | RootDir: WideString; 69 | 70 | begin 71 | DirListing := VfsUtils.TDirListing.Create; 72 | Exclude := DataLib.NewDict(not Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE); 73 | // * * * * * // 74 | RootDir := VfsTestHelper.GetTestsRootDir; 75 | Exclude[VfsUtils.WideStrToCaselessKey('..')] := Ptr(1); 76 | 77 | VfsUtils.GetDirectoryListing(RootDir, '*', Exclude, DirListing); 78 | Check(DirListing.GetDebugDump() = '.'#13#10'503.html'#13#10'default'#13#10'Mods', 'Invalid directory listing. Got:'#13#10 + DirListing.GetDebugDump()); 79 | // * * * * * // 80 | SysUtils.FreeAndNil(DirListing); 81 | SysUtils.FreeAndNil(Exclude); 82 | end; // .procedure TestUtils.TestGetDirectoryListing 83 | 84 | begin 85 | RegisterTest(TestUtils.Suite); 86 | end. -------------------------------------------------------------------------------- /VfsImport.pas: -------------------------------------------------------------------------------- 1 | unit VfsImport; 2 | (* 3 | 4 | *) 5 | 6 | 7 | (***) interface (***) 8 | 9 | uses 10 | SysUtils, Utils; 11 | 12 | type 13 | (* 14 | Specifies the order, in which files from different mapped directories will be listed in virtual directory. 15 | Virtual directory sorting is performed by priorities firstly and lexicographically secondly. 16 | SORT_FIFO - Items of the first mapped directory will be listed before the second mapped directory items. 17 | SORT_LIFO - Items of The last mapped directory will be listed before all other mapped directory items. 18 | *) 19 | TDirListingSortType = (SORT_FIFO = 0, SORT_LIFO = 1); 20 | 21 | TLoggingProc = procedure (Operation, Message: pchar); stdcall; 22 | 23 | (* Install new logger routine. Returns previous logging routine address. Logger should not care about thread-safety *) 24 | function SetLoggingProc ({n} Handler: TLoggingProc): {n} TLoggingProc; stdcall; external 'vfs.dll'; 25 | 26 | (* Writes message to VFS log. Thread-safety is enforced automatically *) 27 | procedure WriteLog (const Operation, Message: pchar); stdcall; external 'vfs.dll'; 28 | 29 | (* Loads mod list from file and maps each mod directory to specified root directory. 30 | File with mod list is treated as (BOM or BOM-less) UTF-8 plain text file, where each mod name is separated 31 | from another one via Line Feed (#10) character. Each mod named is trimmed, converted to UCS16 and validated before 32 | adding to list. Invalid or empty mods will be skipped. Mods are mapped in reverse order, as compared to their order in file. 33 | Returns true if root and mods directory existed and file with mod list was loaded successfully *) 34 | function MapModsFromList (const RootDir, ModsDir, ModListFile: PWideChar; Flags: integer = 0): LONGBOOL; stdcall; external 'vfs.dll'; 35 | function MapModsFromListA (const RootDir, ModsDir, ModListFile: PAnsiChar; Flags: integer = 0): LONGBOOL; stdcall; external 'vfs.dll'; 36 | 37 | (* Runs all VFS subsystems, unless VFS is already running *) 38 | function RunVfs (DirListingOrder: TDirListingSortType): LONGBOOL; stdcall; external 'vfs.dll'; 39 | 40 | (* Spawns separate thread, which starts recursive monitoring for changes in specified directory. 41 | VFS will be fully refreshed or smartly updated on any change. Debounce interval specifies 42 | time in msec to wait after last change before running full VFS rescanning routine *) 43 | function RunWatcher (const WatchDir: PWideChar; DebounceInterval: integer): LONGBOOL; stdcall; external 'vfs.dll'; 44 | function RunWatcherA (const WatchDir: pchar; DebounceInterval: integer): LONGBOOL; stdcall; external 'vfs.dll'; 45 | 46 | (* Frees buffer, that was transfered to client earlier using other VFS API *) 47 | procedure MemFree ({O} Buf: pointer); stdcall; external 'vfs.dll'; 48 | 49 | (* Returns text with all applied mappings, separated via #13#10. If ShortenPaths is true, common part 50 | of real and virtual paths is stripped. Call MemFree to release result buffer *) 51 | function GetMappingsReport: {O} PWideChar; stdcall; external 'vfs.dll'; 52 | function GetMappingsReportA: {O} pchar; stdcall; external 'vfs.dll'; 53 | 54 | (* Returns text with all applied mappings on per-file level, separated via #13#10. If ShortenPaths is true, common part 55 | of real and virtual paths is stripped *) 56 | function GetDetailedMappingsReport: {O} PWideChar; stdcall; external 'vfs.dll'; 57 | function GetDetailedMappingsReportA: {O} pchar; stdcall; external 'vfs.dll'; 58 | 59 | (* Allocates console and install logger, writing messages to console *) 60 | procedure InstallConsoleLogger; stdcall; external 'vfs.dll'; 61 | 62 | 63 | (***) implementation (***) 64 | 65 | 66 | end. -------------------------------------------------------------------------------- /VfsTest.dproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | {c6015c7b-4070-47b6-8c8a-c2b54aba82d6} 5 | VfsTest.dpr 6 | Debug 7 | AnyCPU 8 | DCC32 9 | VfsTest.exe 10 | 11 | 12 | 7.0 13 | False 14 | False 15 | 0 16 | RELEASE 17 | 18 | 19 | 7.0 20 | False 21 | ..\Lib\B2;.\Tests 22 | ..\Lib\B2;.\Tests 23 | ..\Lib\B2;.\Tests 24 | ..\Lib\B2;.\Tests 25 | 3 26 | 27 | 28 | Delphi.Personality 29 | VCLApplication 30 | 31 | FalseTrueFalseFalseFalse1000FalseFalseFalseFalseFalse104912511.0.0.01.0.0.0VfsTest.dpr 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | Microsoft Office 2000 Sample Automation Server Wrapper Components 43 | Microsoft Office XP Sample Automation Server Wrapper Components 44 | 45 | 46 | 47 | 48 | 49 | MainSource 50 | 51 | 52 | -------------------------------------------------------------------------------- /Vfs.dproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | {e3e35df4-690f-11e9-a923-1681be663d3e} 5 | Vfs.dpr 6 | Debug 7 | AnyCPU 8 | DCC32 9 | Vfs.dll 10 | 11 | 12 | 7.0 13 | False 14 | False 15 | 0 16 | RELEASE 17 | 18 | 19 | 7.0 20 | False 21 | True 22 | ..\Lib\B2 23 | ..\Lib\B2 24 | ..\Lib\B2 25 | ..\Lib\B2 26 | 3 27 | Virtual File System 28 | 29 | 30 | Delphi.Personality 31 | VCLApplication 32 | 33 | FalseTrueFalseTrueTrue1041FalseFalseFalseFalseFalse10491251Alexander Shostak (aka EtherniDee)Virtual File System1.0.4.11.0.0.0Vfs.dpr 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | Microsoft Office 2000 Sample Automation Server Wrapper Components 45 | Microsoft Office XP Sample Automation Server Wrapper Components 46 | 47 | 48 | 49 | 50 | 51 | MainSource 52 | 53 | 54 | -------------------------------------------------------------------------------- /VfsExport.pas: -------------------------------------------------------------------------------- 1 | unit VfsExport; 2 | (* 3 | 4 | *) 5 | 6 | 7 | (***) interface (***) 8 | 9 | uses 10 | Windows, 11 | Utils, 12 | VfsDebug, VfsBase, VfsControl, VfsWatching; 13 | 14 | exports 15 | VfsDebug.SetLoggingProc, 16 | VfsDebug.WriteLog_ name 'WriteLog', 17 | VfsControl.RunVfs, 18 | VfsBase.PauseVfs, 19 | VfsBase.ResetVfs, 20 | VfsBase.RefreshVfs, 21 | VfsBase.CallWithoutVfs; 22 | 23 | 24 | (***) implementation (***) 25 | 26 | 27 | function Externalize (const Str: AnsiString): {O} pointer; overload; 28 | begin 29 | GetMem(result, Length(Str) + 1); 30 | Utils.CopyMem(Length(Str) + 1, pchar(Str), result); 31 | end; 32 | 33 | function Externalize (const Str: WideString): {O} pointer; overload; 34 | begin 35 | GetMem(result, (Length(Str) + 1) * sizeof(WideChar)); 36 | Utils.CopyMem((Length(Str) + 1) * sizeof(WideChar), PWideChar(Str), result); 37 | end; 38 | 39 | function MapDir (const VirtPath, RealPath: PWideChar; OverwriteExisting: boolean; Flags: integer = 0): LONGBOOL; stdcall; 40 | begin 41 | result := VfsBase.MapDir(WideString(VirtPath), WideString(RealPath), OverwriteExisting, Flags); 42 | end; 43 | 44 | function MapDirA (const VirtPath, RealPath: PAnsiChar; OverwriteExisting: boolean; Flags: integer = 0): LONGBOOL; stdcall; 45 | begin 46 | result := VfsBase.MapDir(WideString(VirtPath), WideString(RealPath), OverwriteExisting, Flags); 47 | end; 48 | 49 | function MapModsFromList (const RootDir, ModsDir, ModListFile: PWideChar; Flags: integer = 0): LONGBOOL; stdcall; 50 | begin 51 | result := VfsControl.MapModsFromList(WideString(RootDir), WideString(ModsDir), WideString(ModListFile), Flags); 52 | end; 53 | 54 | function MapModsFromListA (const RootDir, ModsDir, ModListFile: PAnsiChar; Flags: integer = 0): LONGBOOL; stdcall; 55 | begin 56 | result := VfsControl.MapModsFromList(WideString(RootDir), WideString(ModsDir), WideString(ModListFile), Flags); 57 | end; 58 | 59 | function RunWatcher (const WatchDir: PWideChar; DebounceInterval: integer): LONGBOOL; stdcall; 60 | begin 61 | result := VfsWatching.RunWatcher(WatchDir, DebounceInterval); 62 | end; 63 | 64 | function RunWatcherA (const WatchDir: pchar; DebounceInterval: integer): LONGBOOL; stdcall; 65 | begin 66 | result := VfsWatching.RunWatcher(WatchDir, DebounceInterval); 67 | end; 68 | 69 | (* Frees buffer, that was transfered to client earlier using other VFS API *) 70 | procedure MemFree ({O} Buf: pointer); stdcall; 71 | begin 72 | FreeMem(Buf); 73 | end; 74 | 75 | (* Returns text with all applied mappings, separated via #13#10. If ShortenPaths is true, common part 76 | of real and virtual paths is stripped. Call MemFree to release result buffer *) 77 | function GetMappingsReport: {O} PWideChar; stdcall; 78 | begin 79 | result := Externalize(VfsBase.GetMappingsReport); 80 | end; 81 | 82 | function GetMappingsReportA: {O} pchar; stdcall; 83 | begin 84 | result := Externalize(AnsiString(VfsBase.GetMappingsReport)); 85 | end; 86 | 87 | (* Returns text with all applied mappings on per-file level, separated via #13#10. If ShortenPaths is true, common part 88 | of real and virtual paths is stripped *) 89 | function GetDetailedMappingsReport: {O} PWideChar; stdcall; 90 | begin 91 | result := Externalize(VfsBase.GetDetailedMappingsReport); 92 | end; 93 | 94 | function GetDetailedMappingsReportA: {O} pchar; stdcall; 95 | begin 96 | result := Externalize(AnsiString(VfsBase.GetDetailedMappingsReport)); 97 | end; 98 | 99 | procedure ConsoleLoggingProc (Operation, Message: pchar); stdcall; 100 | begin 101 | WriteLn('>> ', string(Operation), ': ', string(Message), #13#10); 102 | end; 103 | 104 | (* Allocates console and install logger, writing messages to console *) 105 | procedure InstallConsoleLogger; stdcall; 106 | var 107 | Rect: TSmallRect; 108 | BufSize: TCoord; 109 | hIn: THandle; 110 | hOut: THandle; 111 | 112 | begin 113 | AllocConsole; 114 | SetConsoleCP(GetACP); 115 | SetConsoleOutputCP(GetACP); 116 | hIn := GetStdHandle(STD_INPUT_HANDLE); 117 | hOut := GetStdHandle(STD_OUTPUT_HANDLE); 118 | pinteger(@System.Input)^ := hIn; 119 | pinteger(@System.Output)^ := hOut; 120 | BufSize.x := 120; 121 | BufSize.y := 1000; 122 | SetConsoleScreenBufferSize(hOut, BufSize); 123 | Rect.Left := 0; 124 | Rect.Top := 0; 125 | Rect.Right := 120 - 1; 126 | Rect.Bottom := 50 - 1; 127 | SetConsoleWindowInfo(hOut, true, Rect); 128 | SetConsoleTextAttribute(hOut, (0 shl 4) or $0F); 129 | 130 | VfsDebug.SetLoggingProc(@ConsoleLoggingProc); 131 | end; // .procedure InitConsole; 132 | 133 | exports 134 | MapDir, 135 | MapDirA, 136 | MapModsFromList, 137 | MapModsFromListA, 138 | RunWatcher, 139 | RunWatcherA, 140 | GetMappingsReport, 141 | GetMappingsReportA, 142 | GetDetailedMappingsReport, 143 | GetDetailedMappingsReportA, 144 | MemFree, 145 | InstallConsoleLogger; 146 | 147 | end. 148 | -------------------------------------------------------------------------------- /VfsApiDigger.pas: -------------------------------------------------------------------------------- 1 | unit VfsApiDigger; 2 | (* 3 | Description: Provides means for detecting real WinAPI functions addresses, bypassing proxy dlls and 4 | other low level code routines. 5 | *) 6 | 7 | 8 | (***) interface (***) 9 | 10 | uses 11 | SysUtils, Windows, 12 | Utils, DataLib, PatchForge; 13 | 14 | 15 | (* Determines real exported API addresses for all specified DLL handles. If DLL imports function 16 | with the same name, as the exported one, then imported one is treated as real function. 17 | Example: kernel32.ReadProcessMemory can be a bridge to imported kernelbase.ReadProcessMemory. 18 | If DLL handle was processed earlier, it's skipped *) 19 | procedure FindOutRealSystemApiAddrs (const DllHandles: array of integer); 20 | 21 | (* Returns real code address, bypassing possibly nested simple redirection stubs like JMP [...] or JMP XXX. *) 22 | function GetRealAddress (CodeOrRedirStub: pointer): {n} pointer; 23 | 24 | (* Enhanced version of kernel32.GetProcAddress, traversing bridge chains and using info, gained by FindOutRealSystemApiAddrs earlier *) 25 | function GetRealProcAddress (DllHandle: integer; const ProcName: string): {n} pointer; 26 | 27 | 28 | (***) implementation (***) 29 | 30 | 31 | var 32 | (* Map of DLL handle => API name => Real api address *) 33 | {O} DllRealApiAddrs: {O} TObjDict {OF TDict}; 34 | 35 | 36 | procedure FindOutRealSystemApiAddrs (const DllHandles: array of integer); 37 | const 38 | PE_SIGNATURE_LEN = 4; 39 | 40 | type 41 | PImageImportDirectory = ^TImageImportDirectory; 42 | TImageImportDirectory = packed record 43 | RvaImportLookupTable: integer; 44 | TimeDateStamp: integer; 45 | ForwarderChain: integer; 46 | RvaModuleName: integer; 47 | RvaImportAddressTable: integer; 48 | end; 49 | 50 | PHintName = ^THintName; 51 | THintName = packed record 52 | Hint: word; 53 | Name: array [0..MAXLONGINT - 5] of char; 54 | end; 55 | 56 | var 57 | ImportDirInfo: PImageDataDirectory; 58 | ImportDir: PImageImportDirectory; 59 | ImportLookupTable: Utils.PEndlessIntArr; 60 | ImportAddrTable: Utils.PEndlessIntArr; 61 | DllApiRedirs: {U} TDict {of pointer}; 62 | DllHandle: integer; 63 | i, j: integer; 64 | 65 | begin 66 | ImportDirInfo := nil; 67 | ImportDir := nil; 68 | ImportLookupTable := nil; 69 | ImportAddrTable := nil; 70 | DllApiRedirs := nil; 71 | // * * * * * // 72 | for i := 0 to high(DllHandles) do begin 73 | DllHandle := DllHandles[i]; 74 | ImportDirInfo := @PImageOptionalHeader(DllHandle + PImageDosHeader(DllHandle)._lfanew + PE_SIGNATURE_LEN + sizeof(TImageFileHeader)).DataDirectory[1]; 75 | DllApiRedirs := DllRealApiAddrs[Ptr(DllHandle)]; 76 | 77 | if DllApiRedirs = nil then begin 78 | DllApiRedirs := DataLib.NewDict(NOT Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE); 79 | DllRealApiAddrs[Ptr(DllHandle)] := DllApiRedirs; 80 | 81 | // Found valid import directory in Win32 PE 82 | if ((ImportDirInfo.Size > 0) and (ImportDirInfo.VirtualAddress <> 0)) then begin 83 | ImportDir := pointer(DllHandle + integer(ImportDirInfo.VirtualAddress)); 84 | 85 | while ImportDir.RvaImportLookupTable <> 0 do begin 86 | ImportLookupTable := pointer(DllHandle + ImportDir.RvaImportLookupTable); 87 | ImportAddrTable := pointer(DllHandle + ImportDir.RvaImportAddressTable); 88 | 89 | j := 0; 90 | 91 | while (j >= 0) and (ImportLookupTable[j] <> 0) do begin 92 | if ImportLookupTable[j] > 0 then begin 93 | DllApiRedirs[pchar(@PHintName(DllHandle + ImportLookupTable[j]).Name)] := Ptr(ImportAddrTable[j]); 94 | end; 95 | 96 | Inc(j); 97 | end; 98 | 99 | Inc(ImportDir); 100 | end; // .while 101 | end; // .if 102 | end; // .if 103 | end; // .for 104 | end; // .procedure FindOutRealSystemApiAddrs 105 | 106 | function GetRealAddress (CodeOrRedirStub: pointer): {n} pointer; 107 | const 108 | MAX_DEPTH = 100; 109 | 110 | var 111 | Depth: integer; 112 | 113 | begin 114 | {!} Assert(CodeOrRedirStub <> nil); 115 | result := CodeOrRedirStub; 116 | Depth := 0; 117 | 118 | while Depth < MAX_DEPTH do begin 119 | // JMP DWORD [PTR] 120 | if pword(result)^ = PatchForge.OPCODE_JMP_PTR_CONST32 then begin 121 | result := ppointer(integer(result) + sizeof(word))^; 122 | // JXX SHORT CONST8 123 | end else if PatchForge.IsShortJumpConst8Opcode(pbyte(result)^) then begin 124 | result := pointer(integer(result) + sizeof(byte) + pshortint(integer(result) + sizeof(byte))^); 125 | // JMP NEAR CONST32 126 | end else if pbyte(result)^ = PatchForge.OPCODE_JMP_CONST32 then begin 127 | result := pointer(integer(result) + sizeof(PatchForge.TJumpCall32Rec) + pinteger(integer(result) + sizeof(byte))^); 128 | // JXX (conditional) NEAR CONST32 129 | end else if PatchForge.IsNearJumpConst32Opcode(pword(result)^) then begin 130 | result := pointer(integer(result) + sizeof(word) + sizeof(integer) + pinteger(integer(result) + sizeof(word))^); 131 | // Regular code 132 | end else begin 133 | break; 134 | end; // .else 135 | 136 | Inc(Depth); 137 | end; // .while 138 | end; // .function GetRealAddress 139 | 140 | function GetRealProcAddress (DllHandle: integer; const ProcName: string): {n} pointer; 141 | var 142 | {Un} DllApiRedirs: {U} TDict {OF pointer}; 143 | 144 | begin 145 | DllApiRedirs := DllRealApiAddrs[Ptr(DllHandle)]; 146 | result := nil; 147 | // * * * * * // 148 | 149 | if DllApiRedirs <> nil then begin 150 | result := DllApiRedirs[ProcName]; 151 | end; 152 | 153 | if result = nil then begin 154 | result := Windows.GetProcAddress(DllHandle, pchar(ProcName)); 155 | end; 156 | 157 | if result <> nil then begin 158 | result := GetRealAddress(result); 159 | end; 160 | end; // .function GetRealProcAddress 161 | 162 | begin 163 | DllRealApiAddrs := DataLib.NewObjDict(Utils.OWNS_ITEMS); 164 | end. -------------------------------------------------------------------------------- /VfsPatching.pas: -------------------------------------------------------------------------------- 1 | unit VfsPatching; 2 | (* 3 | Description: Code patching facilities, based on PatchForge library. 4 | All hooks are thread-safe. 5 | *) 6 | 7 | (***) interface (***) 8 | 9 | uses 10 | Windows, SysUtils, Utils, PatchForge, Concur; 11 | 12 | type 13 | PAppliedPatch = ^TAppliedPatch; 14 | TAppliedPatch = record 15 | Addr: pointer; 16 | Bytes: Utils.TArrayOfByte; 17 | 18 | procedure Rollback; 19 | end; 20 | 21 | 22 | (* Replaces original STDCALL function with the new one with the same prototype and one extra argument. 23 | The argument is callable pointer, used to execute original function. The pointer is passed as THE FIRST 24 | argument before other arguments. *) 25 | function SpliceWinApi (OrigFunc, HandlerFunc: pointer; {n} AppliedPatch: PAppliedPatch = nil): pointer; 26 | 27 | 28 | (***) implementation (***) 29 | 30 | 31 | type 32 | (* Import *) 33 | TPatchMaker = PatchForge.TPatchMaker; 34 | TPatchHelper = PatchForge.TPatchHelper; 35 | 36 | const 37 | PERSISTENT_MEM_CAPACITY = 100 * 1024; 38 | 39 | var 40 | PersistentMemCritSection: Concur.TCritSection; 41 | PersistentMem: array [0..PERSISTENT_MEM_CAPACITY - 1] of byte; 42 | PersistentMemPos: integer; 43 | 44 | 45 | procedure AllocPersistentMem (var Addr; Size: integer); 46 | begin 47 | {!} Assert(@Addr <> nil); 48 | {!} Assert(Size >= 0); 49 | 50 | with PersistentMemCritSection do begin 51 | Enter; 52 | pointer(Addr) := nil; 53 | 54 | try 55 | if PersistentMemPos + Size > High(PersistentMem) then begin 56 | raise EOutOfMemory.Create('Failed to allocate another persistent memory block of size ' + SysUtils.IntToStr(Size)); 57 | end; 58 | 59 | pointer(Addr) := @PersistentMem[PersistentMemPos]; 60 | Inc(PersistentMemPos, Size); 61 | finally 62 | Leave; 63 | end; 64 | end; // .with 65 | end; // .procedure AllocPersistentMem 66 | 67 | (* Writes arbitrary data to any write-protected section *) 68 | function WriteAtCode (NumBytes: integer; {n} Src, {n} Dst: pointer): boolean; 69 | var 70 | OldPageProtect: integer; 71 | 72 | begin 73 | {!} Assert(Utils.IsValidBuf(Src, NumBytes)); 74 | {!} Assert(Utils.IsValidBuf(Dst, NumBytes)); 75 | result := NumBytes = 0; 76 | 77 | if not result then begin 78 | try 79 | result := Windows.VirtualProtect(Dst, NumBytes, Windows.PAGE_EXECUTE_READWRITE, @OldPageProtect); 80 | 81 | if result then begin 82 | Utils.CopyMem(NumBytes, Src, Dst); 83 | Windows.VirtualProtect(Dst, NumBytes, OldPageProtect, @OldPageProtect); 84 | end; 85 | except 86 | result := false; 87 | end; 88 | end; // .if 89 | end; // .function WriteAtCode 90 | 91 | (* Writes patch to any write-protected section *) 92 | function WritePatchAtCode (PatchMaker: TPatchMaker; {n} Dst: pointer): boolean; 93 | var 94 | Buf: Utils.TArrayOfByte; 95 | 96 | begin 97 | {!} Assert(PatchMaker <> nil); 98 | {!} Assert((Dst <> nil) or (PatchMaker.Size = 0)); 99 | // * * * * * // 100 | result := true; 101 | 102 | if PatchMaker.Size > 0 then begin 103 | SetLength(Buf, PatchMaker.Size); 104 | PatchMaker.ApplyPatch(pointer(Buf), Dst); 105 | result := WriteAtCode(Length(Buf), pointer(Buf), Dst); 106 | end; 107 | end; // .function WritePatchAtCode 108 | 109 | function SpliceWinApi (OrigFunc, HandlerFunc: pointer; {n} AppliedPatch: PAppliedPatch = nil): pointer; 110 | const 111 | CODE_ADDR_ALIGNMENT = 8; 112 | 113 | var 114 | {O} p: PatchForge.TPatchHelper; 115 | {OI} SpliceBridge: pbyte; // Memory is never freed 116 | OrigFuncBridgeLabel: string; 117 | OrigCodeBridgeStartPos: integer; 118 | OverwrittenCodeSize: integer; 119 | 120 | begin 121 | {!} Assert(OrigFunc <> nil); 122 | {!} Assert(HandlerFunc <> nil); 123 | p := TPatchHelper.Wrap(TPatchMaker.Create); 124 | SpliceBridge := nil; 125 | result := nil; 126 | // * * * * * // 127 | 128 | // === BEGIN generating SpliceBridge === 129 | // Add pointer to original function bridge as the first argument 130 | p.WriteTribyte(PatchForge.INSTR_PUSH_PTR_ESP); 131 | p.WriteInt(PatchForge.INSTR_MOV_ESP_PLUS_4_CONST32); 132 | p.ExecActionOnApply(PatchForge.TAddLabelRealAddrAction.Create(p.NewAutoLabel(OrigFuncBridgeLabel))); 133 | p.WriteInt(0); 134 | 135 | // Jump to new handler 136 | p.Jump(PatchForge.JMP, HandlerFunc); 137 | 138 | // Ensure original code bridge is aligned 139 | p.Nop(p.Pos mod CODE_ADDR_ALIGNMENT); 140 | 141 | // Set result to offset from splice bridge start to original function bridge 142 | result := pointer(p.Pos); 143 | 144 | // Write original function bridge 145 | p.PutLabel(OrigFuncBridgeLabel); 146 | OrigCodeBridgeStartPos := p.Pos; 147 | p.WriteCode(OrigFunc, PatchForge.TMinCodeSizeDetector.Create(sizeof(PatchForge.TJumpCall32Rec))); 148 | OverwrittenCodeSize := p.Pos - OrigCodeBridgeStartPos; 149 | p.Jump(PatchForge.JMP, Utils.PtrOfs(OrigFunc, OverwrittenCodeSize)); 150 | // === END generating SpliceBridge === 151 | 152 | // Persist splice bridge 153 | AllocPersistentMem(SpliceBridge, p.Size); 154 | WritePatchAtCode(p.PatchMaker, SpliceBridge); 155 | 156 | // Turn result from offset to absolute address 157 | result := Ptr(integer(SpliceBridge) + integer(result)); 158 | 159 | // Create and apply hook at target function start 160 | p.Clear(); 161 | p.Jump(PatchForge.JMP, SpliceBridge); 162 | p.Nop(OverwrittenCodeSize - p.Pos); 163 | 164 | if AppliedPatch <> nil then begin 165 | AppliedPatch.Addr := OrigFunc; 166 | SetLength(AppliedPatch.Bytes, p.Size); 167 | Utils.CopyMem(p.Size, OrigFunc, @AppliedPatch.Bytes[0]); 168 | end; 169 | 170 | WritePatchAtCode(p.PatchMaker, OrigFunc); 171 | // * * * * * // 172 | p.Release; 173 | end; 174 | 175 | procedure TAppliedPatch.Rollback; 176 | begin 177 | if Self.Bytes <> nil then begin 178 | WriteAtCode(Length(Self.Bytes), @Self.Bytes[0], Self.Addr); 179 | end; 180 | end; 181 | 182 | begin 183 | PersistentMemCritSection.Init; 184 | end. -------------------------------------------------------------------------------- /VfsOpenFiles.pas: -------------------------------------------------------------------------------- 1 | unit VfsOpenFiles; 2 | (* 3 | Author: Alexander Shostak aka Berserker aka EtherniDee. 4 | Description: Provides concurrent storage for additional information for each file handle, 5 | fully integrated to file handles life cycle. 6 | The unit works independently of other VFS subsystems, guaranteeing relative paths 7 | resolution capability (conversion of directory handle into directory path). 8 | Most NT file APIs can work with pairs of [hDir, RelativePath] (@see WinNative.TObjectAttributes). 9 | *) 10 | 11 | 12 | (***) interface (***) 13 | 14 | uses 15 | Windows, SysUtils, 16 | Utils, Concur, DataLib, StrLib, 17 | VfsUtils, VfsBase, VfsMatching; 18 | type 19 | (* Import *) 20 | TVfsItem = VfsBase.TVfsItem; 21 | 22 | type 23 | (* Extra information for file handle. Working with structure must be protected by corresponding critical section *) 24 | TOpenedFile = class 25 | public 26 | (* Handle for either virtual or real path *) 27 | hFile: Windows.THandle; 28 | 29 | (* Virtual path to file (path given to NtCreate API) *) 30 | AbsPath: WideString; 31 | 32 | (* Directory listing (both real and virtual children). Created on the fly on FillDirListing call *) 33 | {On} DirListing: VfsUtils.TDirListing; 34 | 35 | constructor Create (hFile: Windows.THandle; const AbsPath: WideString); 36 | destructor Destroy; override; 37 | 38 | (* Makes complete directory listing, including real and virtual items. Does nothing if listing already exists *) 39 | procedure FillDirListing (const Mask: WideString); 40 | end; // .class TOpenedFile 41 | 42 | var 43 | OpenFilesCritSection: Concur.TCritSection; 44 | 45 | 46 | (* Returns TOpenedFile by handle or nil. MUST BE called in OpenFilesCritSection protected area *) 47 | function GetOpenedFile (hFile: Windows.THandle): {n} TOpenedFile; 48 | 49 | (* 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 *) 50 | function GetOpenedFilePath (hFile: Windows.THandle): WideString; 51 | 52 | (* Atomically replaces TOpenedFile record for given file handle *) 53 | procedure SetOpenedFileInfo (hFile: Windows.THandle; {On} OpenedFile: TOpenedFile); 54 | 55 | (* Atomically deletes TOpenedFile information by file handle *) 56 | procedure DeleteOpenedFileInfo (hFile: Windows.THandle); 57 | 58 | 59 | (***) implementation (***) 60 | 61 | 62 | var 63 | (* Map of all tracked file handles => TOpenedFile. Protected by corresponding critical section *) 64 | {O} OpenedFiles: {O} TObjDict {of TOpenedFile}; 65 | 66 | 67 | constructor TOpenedFile.Create (hFile: Windows.THandle; const AbsPath: WideString); 68 | begin 69 | Self.hFile := hFile; 70 | Self.AbsPath := AbsPath; 71 | end; 72 | 73 | destructor TOpenedFile.Destroy; 74 | begin 75 | FreeAndNil(Self.DirListing); 76 | end; 77 | 78 | procedure TOpenedFile.FillDirListing (const Mask: WideString); 79 | var 80 | {On} ExcludedItems: {U} TDict {OF not nil}; 81 | VfsItemFound: boolean; 82 | NumVfsChildren: integer; 83 | DirInfo: TNativeFileInfo; 84 | ParentDirInfo: TNativeFileInfo; 85 | DirItem: TFileInfo; 86 | 87 | begin 88 | ExcludedItems := nil; 89 | // * * * * * // 90 | if Self.DirListing <> nil then begin 91 | exit; 92 | end; 93 | 94 | Self.DirListing := TDirListing.Create; 95 | VfsItemFound := VfsBase.GetVfsDirInfo(Self.AbsPath, Mask, DirInfo, Self.DirListing); 96 | ExcludedItems := DataLib.NewDict(not Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE); 97 | 98 | if VfsItemFound then begin 99 | while Self.DirListing.GetNextItem(DirItem) do begin 100 | ExcludedItems[WideStrToCaselessKey(DirItem.Data.FileName)] := Ptr(1); 101 | end; 102 | 103 | Self.DirListing.Rewind; 104 | end; 105 | 106 | // Add real items 107 | NumVfsChildren := Self.DirListing.Count; 108 | 109 | with VfsBase.GetThreadVfsDisabler do begin 110 | DisableVfsForThread; 111 | 112 | try 113 | VfsUtils.GetDirectoryListing(Self.AbsPath, Mask, ExcludedItems, Self.DirListing); 114 | finally 115 | RestoreVfsForThread; 116 | end; 117 | end; 118 | 119 | // No real items added, maybe there is a need to add '.' and/or '..' manually 120 | if VfsItemFound and (Self.DirListing.Count = NumVfsChildren) and not VfsUtils.IsRootDriveAbsPath(Self.AbsPath) then begin 121 | if VfsMatching.MatchPattern('.', Mask) then begin 122 | Self.DirListing.AddItem(@DirInfo, '.'); 123 | end; 124 | 125 | if VfsMatching.MatchPattern('..', Mask) and VfsUtils.GetFileInfo(VfsUtils.AddBackslash(Self.AbsPath) + '..', ParentDirInfo) then begin 126 | Self.DirListing.AddItem(@ParentDirInfo, '..'); 127 | end; 128 | end; 129 | // * * * * * // 130 | SysUtils.FreeAndNil(ExcludedItems); 131 | end; // .procedure TOpenedFile.FillDirListing 132 | 133 | function GetOpenedFile (hFile: Windows.THandle): {n} TOpenedFile; 134 | begin 135 | result := OpenedFiles[pointer(hFile)]; 136 | end; 137 | 138 | function GetOpenedFilePath (hFile: Windows.THandle): WideString; 139 | var 140 | {n} OpenedFile: TOpenedFile; 141 | 142 | begin 143 | OpenedFile := nil; 144 | result := ''; 145 | // * * * * * // 146 | with OpenFilesCritSection do begin 147 | Enter; 148 | 149 | OpenedFile := OpenedFiles[pointer(hFile)]; 150 | 151 | if OpenedFile <> nil then begin 152 | result := OpenedFile.AbsPath; 153 | end; 154 | 155 | Leave; 156 | end; 157 | end; // .function GetOpenedFilePath 158 | 159 | procedure SetOpenedFileInfo (hFile: Windows.THandle; {On} OpenedFile: TOpenedFile); 160 | begin 161 | with OpenFilesCritSection do begin 162 | Enter; 163 | OpenedFiles[pointer(hFile)] := OpenedFile; OpenedFile := nil; 164 | Leave; 165 | end; 166 | // * * * * * // 167 | SysUtils.FreeAndNil(OpenedFile); 168 | end; 169 | 170 | procedure DeleteOpenedFileInfo (hFile: Windows.THandle); 171 | begin 172 | with OpenFilesCritSection do begin 173 | Enter; 174 | OpenedFiles.DeleteItem(pointer(hFile)); 175 | Leave; 176 | end; 177 | end; 178 | 179 | begin 180 | OpenFilesCritSection.Init; 181 | OpenedFiles := DataLib.NewObjDict(Utils.OWNS_ITEMS); 182 | end. -------------------------------------------------------------------------------- /VfsControl.pas: -------------------------------------------------------------------------------- 1 | unit VfsControl; 2 | (* 3 | Facade unit for high-level VFS API. 4 | *) 5 | 6 | 7 | (***) interface (***) 8 | 9 | uses 10 | Windows, SysUtils, 11 | Utils, WinUtils, TypeWrappers, DataLib, Files, StrLib, 12 | VfsBase, VfsUtils, VfsHooks, VfsWatching; 13 | 14 | type 15 | (* Import *) 16 | TWideString = TypeWrappers.TWideString; 17 | 18 | 19 | (* Runs all VFS subsystems, unless VFS is already running *) 20 | function RunVfs (DirListingOrder: VfsBase.TDirListingSortType): LONGBOOL; stdcall; 21 | 22 | (* Loads mod list from file and maps each mod directory to specified root directory. 23 | File with mod list is treated as (BOM or BOM-less) UTF-8 plain text file, where each mod name is separated 24 | from another one via Line Feed (#10) character. Each mod named is trimmed, converted to UCS16 and validated before 25 | adding to list. Invalid or empty mods will be skipped. Mods are mapped in reverse order, as compared to their order in file. 26 | Returns true if root and mods directory existed and file with mod list was loaded successfully *) 27 | function MapModsFromList (const RootDir, ModsDir, ModListFile: WideString; Flags: integer = 0): boolean; 28 | 29 | 30 | (***) implementation (***) 31 | 32 | 33 | type 34 | TModList = DataLib.TList {of (O) TWideString}; 35 | 36 | 37 | function RunVfs (DirListingOrder: VfsBase.TDirListingSortType): LONGBOOL; stdcall; 38 | var 39 | CurrDir: WideString; 40 | SysDir: WideString; 41 | 42 | begin 43 | with VfsBase.VfsCritSection do begin 44 | Enter; 45 | 46 | result := VfsBase.RunVfs(DirListingOrder); 47 | 48 | if result then begin 49 | VfsHooks.InstallHooks; 50 | 51 | // Hask: Try to ensure, that current directory handle is tracked by VfsOpenFiles 52 | // Windows SetCurrentDirectoryW is does not reopen directory for the same path, thus 53 | // not triggering NtCreateFile 54 | // Not thread safe 55 | CurrDir := WinUtils.GetCurrentDirW; 56 | SysDir := WinUtils.GetSysDirW; 57 | 58 | if (CurrDir <> '') and (SysDir <> '') then begin 59 | WinUtils.SetCurrentDirW(SysDir); 60 | {!} Assert(WinUtils.SetCurrentDirW(CurrDir), 'Failed to restore current directory from system directory during VFS initialization'); 61 | end; 62 | end; 63 | 64 | Leave; 65 | end; // .with 66 | end; // function RunVfs 67 | 68 | function ValidateModName (const ModName: WideString): boolean; 69 | const 70 | DISALLOWED_CHARS = ['<', '>', '"', '?', '*', '\', '/', '|', ':', #0]; 71 | 72 | var 73 | StrLen: integer; 74 | i: integer; 75 | 76 | begin 77 | StrLen := Length(ModName); 78 | i := 1; 79 | 80 | while (i <= StrLen) and ((ord(ModName[i]) > 255) or not (AnsiChar(ModName[i]) in DISALLOWED_CHARS)) do begin 81 | Inc(i); 82 | end; 83 | 84 | result := (i > StrLen) and (ModName <> '') and (ModName <> '.') and (ModName <> '..'); 85 | end; 86 | 87 | function LoadModList (const ModListFilePath: WideString; {O} var {out} ModList: TModList): boolean; 88 | const 89 | UTF8_BOM = #$EF#$BB#$BF; 90 | 91 | var 92 | AbsFilePath: WideString; 93 | FileHandle: integer; 94 | FileContents: string; 95 | Lines: Utils.TArrayOfStr; 96 | ModNameUtf8: string; 97 | ModName: WideString; 98 | i: integer; 99 | 100 | begin 101 | AbsFilePath := VfsUtils.NormalizePath(ModListFilePath); 102 | FileHandle := integer(Windows.INVALID_HANDLE_VALUE); 103 | result := AbsFilePath <> ''; 104 | 105 | if result then begin 106 | FileHandle := Windows.CreateFileW(PWideChar(AbsFilePath), Windows.GENERIC_READ, Windows.FILE_SHARE_READ, nil, Windows.OPEN_EXISTING, 0, 0); 107 | result := FileHandle <> integer(Windows.INVALID_HANDLE_VALUE); 108 | end; 109 | 110 | if result then begin 111 | result := Files.ReadFileContents(FileHandle, FileContents); 112 | 113 | if result then begin 114 | SysUtils.FreeAndNil(ModList); 115 | ModList := DataLib.NewList(Utils.OWNS_ITEMS); 116 | 117 | if (Length(FileContents) >= 3) and (FileContents[1] = UTF8_BOM[1]) and (FileContents[2] = UTF8_BOM[2]) and (FileContents[3] = UTF8_BOM[3]) then begin 118 | FileContents := Copy(FileContents, Length(UTF8_BOM) + 1); 119 | end; 120 | 121 | Lines := StrLib.Explode(FileContents, #10); 122 | 123 | for i := 0 to High(Lines) do begin 124 | ModNameUtf8 := Lines[i]; 125 | ModName := StrLib.TrimW(StrLib.Utf8ToWide(ModNameUtf8, StrLib.FAIL_ON_ERROR)); 126 | 127 | if ValidateModName(ModName) then begin 128 | ModList.Add(TWideString.Create(ModName)); 129 | end; 130 | end; 131 | end; 132 | 133 | Windows.CloseHandle(FileHandle); 134 | end; // .if 135 | end; // .function LoadModList 136 | 137 | function MapModsFromList_ (const RootDir, ModsDir: WideString; ModList: TModList; Flags: integer = 0): boolean; 138 | var 139 | AbsRootDir: WideString; 140 | AbsModsDir: WideString; 141 | FileInfo: VfsUtils.TNativeFileInfo; 142 | ModName: WideString; 143 | ModPathPrefix: WideString; 144 | i: integer; 145 | 146 | begin 147 | {!} Assert(ModList <> nil); 148 | // * * * * * // 149 | AbsRootDir := VfsUtils.NormalizePath(RootDir); 150 | AbsModsDir := VfsUtils.NormalizePath(ModsDir); 151 | result := (AbsRootDir <> '') and (AbsModsDir <> '') and 152 | VfsUtils.GetFileInfo(AbsRootDir, FileInfo) and Utils.Flags(FileInfo.Base.FileAttributes).Have(Windows.FILE_ATTRIBUTE_DIRECTORY) and 153 | VfsUtils.GetFileInfo(AbsModsDir, FileInfo) and Utils.Flags(FileInfo.Base.FileAttributes).Have(Windows.FILE_ATTRIBUTE_DIRECTORY); 154 | 155 | if result then begin 156 | ModPathPrefix := VfsUtils.AddBackslash(AbsModsDir); 157 | 158 | for i := ModList.Count - 1 downto 0 do begin 159 | ModName := TWideString(ModList[i]).Value; 160 | VfsBase.MapDir(AbsRootDir, ModPathPrefix + ModName, not VfsBase.OVERWRITE_EXISTING, Flags); 161 | end; 162 | end; // .if 163 | end; // .function MapModsFromList 164 | 165 | function MapModsFromList (const RootDir, ModsDir, ModListFile: WideString; Flags: integer = 0): boolean; 166 | var 167 | {O} ModList: TModList; 168 | 169 | begin 170 | ModList := nil; 171 | // * * * * * // 172 | result := VfsBase.EnterVfsConfig; 173 | 174 | if result then begin 175 | try 176 | result := LoadModList(ModListFile, ModList) and MapModsFromList_(RootDir, ModsDir, ModList, Flags); 177 | finally 178 | VfsBase.LeaveVfsConfig; 179 | end; 180 | end; 181 | // * * * * * // 182 | SysUtils.FreeAndNil(ModList); 183 | end; // .function MapModsFromList 184 | 185 | end. -------------------------------------------------------------------------------- /VfsMatching.pas: -------------------------------------------------------------------------------- 1 | unit VfsMatching; 2 | (* 3 | Description: Implements NT files matching strategy, same as RtlIsNameInExpression. 4 | @link https://blogs.msdn.microsoft.com/jeremykuhne/2017/06/04/wildcards-in-windows/ 5 | @link https://devblogs.microsoft.com/oldnewthing/?p=24143 6 | *) 7 | 8 | 9 | (***) interface (***) 10 | 11 | uses 12 | SysUtils, 13 | Utils, PatchForge; 14 | 15 | 16 | function CompilePattern (const Pattern: WideString): Utils.TArrayOfByte; 17 | function MatchPattern (const Str: WideString; {n} Pattern: pointer): boolean; overload; 18 | function MatchPattern (const Str, Pattern: WideString): boolean; overload; 19 | 20 | 21 | (***) implementation (***) 22 | 23 | 24 | const 25 | (* File name without last separator and extension: ~([^.]*+\z|.*(?=\.))~ *) 26 | DOS_STAR = '<'; 27 | 28 | (* Dos single char or before dot/end: ~((?=\.)|.?)~ *) 29 | DOS_QM = '>'; 30 | 31 | (* Dos dot or string end: ~(\.|\z)~ *) 32 | DOS_DOT = '"'; 33 | 34 | MAX_STR_LEN = High(word); 35 | 36 | 37 | type 38 | TPatternKind = (KIND_CHAR, KIND_ANY_CHAR, KIND_ANY_CHARS, KIND_DOS_ANY_CHAR, KIND_DOS_ANY_CHARS, KIND_DOS_DOT, KIND_END); 39 | 40 | PPattern = ^TPattern; 41 | TPattern = record 42 | Kind: TPatternKind; 43 | Len: word; 44 | Ch: WideChar; 45 | end; 46 | 47 | 48 | function CompilePattern (const Pattern: WideString): Utils.TArrayOfByte; 49 | var 50 | {O} Compiled: PatchForge.TPatchHelper; 51 | PrevPatternKind: TPatternKind; 52 | NextPatternKind: TPatternKind; 53 | SkipPattern: boolean; 54 | c: WideChar; 55 | i: integer; 56 | 57 | begin 58 | Compiled := PatchForge.TPatchHelper.Wrap(PatchForge.TPatchMaker.Create); 59 | // * * * * * // 60 | PrevPatternKind := KIND_END; 61 | 62 | for i := 1 to Length(Pattern) do begin 63 | c := Pattern[i]; 64 | SkipPattern := false; 65 | 66 | case c of 67 | '?': NextPatternKind := KIND_ANY_CHAR; 68 | 69 | '*': begin 70 | NextPatternKind := KIND_ANY_CHARS; 71 | SkipPattern := PrevPatternKind = KIND_ANY_CHARS; 72 | end; 73 | 74 | DOS_STAR: begin 75 | NextPatternKind := KIND_DOS_ANY_CHARS; 76 | SkipPattern := PrevPatternKind = KIND_DOS_ANY_CHARS; 77 | end; 78 | 79 | DOS_QM: NextPatternKind := KIND_DOS_ANY_CHAR; 80 | 81 | DOS_DOT: NextPatternKind := KIND_DOS_DOT; 82 | else 83 | NextPatternKind := KIND_CHAR; 84 | end; // .switch 85 | 86 | if not SkipPattern then begin 87 | with PPattern(Compiled.AllocAndSkip(sizeof(TPattern)))^ do begin 88 | Kind := NextPatternKind; 89 | Ch := c; 90 | end; 91 | end; 92 | 93 | PrevPatternKind := NextPatternKind; 94 | end; // .for 95 | 96 | PPattern(Compiled.AllocAndSkip(sizeof(TPattern))).Kind := KIND_END; 97 | result := Compiled.GetPatch; 98 | // * * * * * // 99 | Compiled.Release; 100 | end; // .function CompilePattern 101 | 102 | function MatchPattern (const Str: WideString; {n} Pattern: pointer): boolean; overload; 103 | var 104 | {Un} Subpattern: PPattern; 105 | StrLen: integer; 106 | StrStart: PWideChar; 107 | StrEnd: PWideChar; 108 | s: PWideChar; 109 | 110 | function MatchSubpattern: boolean; 111 | var 112 | DotFinder: PWideChar; 113 | 114 | begin 115 | result := false; 116 | Subpattern.Len := 1; 117 | 118 | case Subpattern.Kind of 119 | KIND_CHAR: begin 120 | result := s^ = Subpattern.Ch; 121 | end; 122 | 123 | KIND_ANY_CHAR: begin 124 | result := s <> StrEnd; 125 | end; 126 | 127 | KIND_DOS_ANY_CHAR: begin 128 | result := true; 129 | 130 | if (s^ = '.') or (s = StrEnd) then begin 131 | Subpattern.Len := 0; 132 | end; 133 | end; 134 | 135 | KIND_DOS_DOT: begin 136 | result := (s^ = '.') or (s = StrEnd); 137 | 138 | if s = StrEnd then begin 139 | Subpattern.Len := 0; 140 | end; 141 | end; 142 | 143 | KIND_DOS_ANY_CHARS: begin 144 | result := true; 145 | 146 | if s^ <> '.' then begin 147 | DotFinder := StrEnd; 148 | 149 | while (DotFinder > s) and (DotFinder^ <> '.') do begin 150 | Dec(DotFinder); 151 | end; 152 | 153 | if DotFinder^ <> '.' then begin 154 | DotFinder := StrEnd; 155 | end; 156 | end else begin 157 | DotFinder := s; 158 | end; 159 | 160 | Subpattern.Len := DotFinder - s; 161 | end; // .case KIND_DOS_ANY_CHARS 162 | 163 | KIND_ANY_CHARS: begin 164 | result := true; 165 | Subpattern.Len := 0; 166 | end; 167 | 168 | KIND_END: begin 169 | result := s = StrEnd; 170 | Subpattern.Len := 0; 171 | end; 172 | end; // .switch 173 | 174 | if result then begin 175 | Inc(s, Subpattern.Len); 176 | end; 177 | end; // .function MatchSubpattern 178 | 179 | function Recover: boolean; 180 | var 181 | NextSubpattern: PPattern; 182 | NextChar: WideChar; 183 | Caret: PWideChar; 184 | 185 | begin 186 | result := false; 187 | 188 | while not result and (cardinal(Subpattern) >= cardinal(Pattern)) do begin 189 | case Subpattern.Kind of 190 | KIND_ANY_CHARS: begin 191 | if s < StrEnd then begin 192 | result := true; 193 | NextSubpattern := Utils.PtrOfs(Subpattern, sizeof(TPattern)); 194 | Inc(Subpattern.Len); 195 | Inc(s); 196 | 197 | (* Fast consume to the end: xxx* *) 198 | if NextSubpattern.Kind = KIND_END then begin 199 | Inc(Subpattern.Len, StrEnd - s); 200 | s := StrEnd; 201 | end 202 | (* Fast search for special character: *carry *) 203 | else if NextSubpattern.Kind = KIND_CHAR then begin 204 | NextChar := NextSubpattern.Ch; 205 | Caret := s; 206 | 207 | while (Caret < StrEnd) and (Caret^ <> NextChar) do begin 208 | Inc(Caret); 209 | end; 210 | 211 | if Caret < StrEnd then begin 212 | Inc(Subpattern.Len, Caret - s); 213 | s := Caret; 214 | end else begin 215 | result := false; 216 | end; 217 | end; // .elseif 218 | end else begin 219 | Dec(s, Subpattern.Len); 220 | end; // .else 221 | end; // .case KIND_ANY_CHARS 222 | else 223 | Dec(s, Subpattern.Len); 224 | end; // .switch 225 | 226 | if result then begin 227 | Inc(Subpattern); 228 | end else begin 229 | Dec(Subpattern); 230 | end; 231 | end; // .while 232 | end; // .function Recover 233 | 234 | begin 235 | Subpattern := Pattern; 236 | StrLen := Length(Str); 237 | StrStart := PWideChar(Str); 238 | StrEnd := StrStart + StrLen; 239 | s := StrStart; 240 | // * * * * * // 241 | if Pattern = nil then begin 242 | result := Str = ''; 243 | exit; 244 | end; 245 | 246 | if StrLen > MAX_STR_LEN then begin 247 | result := false; 248 | exit; 249 | end; 250 | 251 | while cardinal(Subpattern) >= cardinal(Pattern) do begin 252 | if MatchSubpattern then begin 253 | if Subpattern.Kind = KIND_END then begin 254 | break; 255 | end; 256 | 257 | Inc(Subpattern); 258 | end else begin 259 | Dec(Subpattern); 260 | Recover; 261 | end; 262 | end; 263 | 264 | result := (cardinal(Subpattern) >= cardinal(Pattern)) and (s^ = #0); 265 | end; // .function MatchPattern 266 | 267 | function MatchPattern (const Str, Pattern: WideString): boolean; overload; 268 | var 269 | CompiledPattern: Utils.TArrayOfByte; 270 | 271 | begin 272 | CompiledPattern := CompilePattern(Pattern); 273 | result := MatchPattern(Str, pointer(CompiledPattern)); 274 | end; 275 | 276 | end. -------------------------------------------------------------------------------- /Vfs.drc: -------------------------------------------------------------------------------- 1 | /* VER185 2 | Generated by the CodeGear Delphi Pascal Compiler 3 | because -GD or --drc was supplied to the compiler. 4 | 5 | This file contains compiler-generated resources that 6 | were bound to the executable. 7 | If this file is empty, then no compiler-generated 8 | resources were bound to the produced executable. 9 | */ 10 | 11 | #define RTLConsts_SInvalidPropertyValue 65424 12 | #define RTLConsts_SListCapacityError 65425 13 | #define RTLConsts_SListCountError 65426 14 | #define RTLConsts_SListIndexError 65427 15 | #define RTLConsts_SReadError 65428 16 | #define RTLConsts_SSeekNotImplemented 65429 17 | #define RTLConsts_SSortedListError 65430 18 | #define RTLConsts_SWriteError 65431 19 | #define SysConst_SShortDayNameTue 65440 20 | #define SysConst_SShortDayNameWed 65441 21 | #define SysConst_SShortDayNameThu 65442 22 | #define SysConst_SShortDayNameFri 65443 23 | #define SysConst_SShortDayNameSat 65444 24 | #define SysConst_SLongDayNameSun 65445 25 | #define SysConst_SLongDayNameMon 65446 26 | #define SysConst_SLongDayNameTue 65447 27 | #define SysConst_SLongDayNameWed 65448 28 | #define SysConst_SLongDayNameThu 65449 29 | #define SysConst_SLongDayNameFri 65450 30 | #define SysConst_SLongDayNameSat 65451 31 | #define RTLConsts_SAssignError 65452 32 | #define RTLConsts_SDuplicateString 65453 33 | #define RTLConsts_SFCreateErrorEx 65454 34 | #define RTLConsts_SFOpenErrorEx 65455 35 | #define SysConst_SShortMonthNameNov 65456 36 | #define SysConst_SShortMonthNameDec 65457 37 | #define SysConst_SLongMonthNameJan 65458 38 | #define SysConst_SLongMonthNameFeb 65459 39 | #define SysConst_SLongMonthNameMar 65460 40 | #define SysConst_SLongMonthNameApr 65461 41 | #define SysConst_SLongMonthNameMay 65462 42 | #define SysConst_SLongMonthNameJun 65463 43 | #define SysConst_SLongMonthNameJul 65464 44 | #define SysConst_SLongMonthNameAug 65465 45 | #define SysConst_SLongMonthNameSep 65466 46 | #define SysConst_SLongMonthNameOct 65467 47 | #define SysConst_SLongMonthNameNov 65468 48 | #define SysConst_SLongMonthNameDec 65469 49 | #define SysConst_SShortDayNameSun 65470 50 | #define SysConst_SShortDayNameMon 65471 51 | #define SysConst_SSafecallException 65472 52 | #define SysConst_SAssertError 65473 53 | #define SysConst_SAbstractError 65474 54 | #define SysConst_SModuleAccessViolation 65475 55 | #define SysConst_SOSError 65476 56 | #define SysConst_SUnkOSError 65477 57 | #define SysConst_SShortMonthNameJan 65478 58 | #define SysConst_SShortMonthNameFeb 65479 59 | #define SysConst_SShortMonthNameMar 65480 60 | #define SysConst_SShortMonthNameApr 65481 61 | #define SysConst_SShortMonthNameMay 65482 62 | #define SysConst_SShortMonthNameJun 65483 63 | #define SysConst_SShortMonthNameJul 65484 64 | #define SysConst_SShortMonthNameAug 65485 65 | #define SysConst_SShortMonthNameSep 65486 66 | #define SysConst_SShortMonthNameOct 65487 67 | #define SysConst_SVarArrayCreate 65488 68 | #define SysConst_SVarArrayBounds 65489 69 | #define SysConst_SVarArrayLocked 65490 70 | #define SysConst_SInvalidVarCast 65491 71 | #define SysConst_SInvalidVarOp 65492 72 | #define SysConst_SInvalidVarOpWithHResultWithPrefix 65493 73 | #define SysConst_SVarTypeCouldNotConvert 65494 74 | #define SysConst_SVarTypeConvertOverflow 65495 75 | #define SysConst_SVarOverflow 65496 76 | #define SysConst_SVarInvalid 65497 77 | #define SysConst_SVarBadType 65498 78 | #define SysConst_SVarNotImplemented 65499 79 | #define SysConst_SVarUnexpected 65500 80 | #define SysConst_SExternalException 65501 81 | #define SysConst_SAssertionFailed 65502 82 | #define SysConst_SIntfCastError 65503 83 | #define SysConst_SOverflow 65504 84 | #define SysConst_SUnderflow 65505 85 | #define SysConst_SInvalidPointer 65506 86 | #define SysConst_SInvalidCast 65507 87 | #define SysConst_SAccessViolationArg3 65508 88 | #define SysConst_SAccessViolationNoArg 65509 89 | #define SysConst_SStackOverflow 65510 90 | #define SysConst_SControlC 65511 91 | #define SysConst_SPrivilege 65512 92 | #define SysConst_SException 65513 93 | #define SysConst_SExceptTitle 65514 94 | #define SysConst_SInvalidFormat 65515 95 | #define SysConst_SArgumentMissing 65516 96 | #define SysConst_SDispatchError 65517 97 | #define SysConst_SReadAccess 65518 98 | #define SysConst_SWriteAccess 65519 99 | #define SysConst_STimeEncodeError 65520 100 | #define SysConst_SDateEncodeError 65521 101 | #define SysConst_SOutOfMemory 65522 102 | #define SysConst_SInOutError 65523 103 | #define SysConst_SFileNotFound 65524 104 | #define SysConst_SInvalidFilename 65525 105 | #define SysConst_STooManyOpenFiles 65526 106 | #define SysConst_SAccessDenied 65527 107 | #define SysConst_SEndOfFile 65528 108 | #define SysConst_SDiskFull 65529 109 | #define SysConst_SInvalidInput 65530 110 | #define SysConst_SDivByZero 65531 111 | #define SysConst_SRangeError 65532 112 | #define SysConst_SIntOverflow 65533 113 | #define SysConst_SInvalidOp 65534 114 | #define SysConst_SZeroDivide 65535 115 | STRINGTABLE 116 | BEGIN 117 | RTLConsts_SInvalidPropertyValue, "Invalid property value" 118 | RTLConsts_SListCapacityError, "List capacity out of bounds (%d)" 119 | RTLConsts_SListCountError, "List count out of bounds (%d)" 120 | RTLConsts_SListIndexError, "List index out of bounds (%d)" 121 | RTLConsts_SReadError, "Stream read error" 122 | RTLConsts_SSeekNotImplemented, "%s.Seek not implemented" 123 | RTLConsts_SSortedListError, "Operation not allowed on sorted list" 124 | RTLConsts_SWriteError, "Stream write error" 125 | SysConst_SShortDayNameTue, "Tue" 126 | SysConst_SShortDayNameWed, "Wed" 127 | SysConst_SShortDayNameThu, "Thu" 128 | SysConst_SShortDayNameFri, "Fri" 129 | SysConst_SShortDayNameSat, "Sat" 130 | SysConst_SLongDayNameSun, "Sunday" 131 | SysConst_SLongDayNameMon, "Monday" 132 | SysConst_SLongDayNameTue, "Tuesday" 133 | SysConst_SLongDayNameWed, "Wednesday" 134 | SysConst_SLongDayNameThu, "Thursday" 135 | SysConst_SLongDayNameFri, "Friday" 136 | SysConst_SLongDayNameSat, "Saturday" 137 | RTLConsts_SAssignError, "Cannot assign a %s to a %s" 138 | RTLConsts_SDuplicateString, "String list does not allow duplicates" 139 | RTLConsts_SFCreateErrorEx, "Cannot create file \"%s\". %s" 140 | RTLConsts_SFOpenErrorEx, "Cannot open file \"%s\". %s" 141 | SysConst_SShortMonthNameNov, "Nov" 142 | SysConst_SShortMonthNameDec, "Dec" 143 | SysConst_SLongMonthNameJan, "January" 144 | SysConst_SLongMonthNameFeb, "February" 145 | SysConst_SLongMonthNameMar, "March" 146 | SysConst_SLongMonthNameApr, "April" 147 | SysConst_SLongMonthNameMay, "May" 148 | SysConst_SLongMonthNameJun, "June" 149 | SysConst_SLongMonthNameJul, "July" 150 | SysConst_SLongMonthNameAug, "August" 151 | SysConst_SLongMonthNameSep, "September" 152 | SysConst_SLongMonthNameOct, "October" 153 | SysConst_SLongMonthNameNov, "November" 154 | SysConst_SLongMonthNameDec, "December" 155 | SysConst_SShortDayNameSun, "Sun" 156 | SysConst_SShortDayNameMon, "Mon" 157 | SysConst_SSafecallException, "Exception in safecall method" 158 | SysConst_SAssertError, "%s (%s, line %d)" 159 | SysConst_SAbstractError, "Abstract Error" 160 | SysConst_SModuleAccessViolation, "Access violation at address %p in module '%s'. %s of address %p" 161 | SysConst_SOSError, "System Error. Code: %d.\r\n%s" 162 | SysConst_SUnkOSError, "A call to an OS function failed" 163 | SysConst_SShortMonthNameJan, "Jan" 164 | SysConst_SShortMonthNameFeb, "Feb" 165 | SysConst_SShortMonthNameMar, "Mar" 166 | SysConst_SShortMonthNameApr, "Apr" 167 | SysConst_SShortMonthNameMay, "May" 168 | SysConst_SShortMonthNameJun, "Jun" 169 | SysConst_SShortMonthNameJul, "Jul" 170 | SysConst_SShortMonthNameAug, "Aug" 171 | SysConst_SShortMonthNameSep, "Sep" 172 | SysConst_SShortMonthNameOct, "Oct" 173 | SysConst_SVarArrayCreate, "Error creating variant or safe array" 174 | SysConst_SVarArrayBounds, "Variant or safe array index out of bounds" 175 | SysConst_SVarArrayLocked, "Variant or safe array is locked" 176 | SysConst_SInvalidVarCast, "Invalid variant type conversion" 177 | SysConst_SInvalidVarOp, "Invalid variant operation" 178 | SysConst_SInvalidVarOpWithHResultWithPrefix, "Invalid variant operation (%s%.8x)\n%s" 179 | SysConst_SVarTypeCouldNotConvert, "Could not convert variant of type (%s) into type (%s)" 180 | SysConst_SVarTypeConvertOverflow, "Overflow while converting variant of type (%s) into type (%s)" 181 | SysConst_SVarOverflow, "Variant overflow" 182 | SysConst_SVarInvalid, "Invalid argument" 183 | SysConst_SVarBadType, "Invalid variant type" 184 | SysConst_SVarNotImplemented, "Operation not supported" 185 | SysConst_SVarUnexpected, "Unexpected variant error" 186 | SysConst_SExternalException, "External exception %x" 187 | SysConst_SAssertionFailed, "Assertion failed" 188 | SysConst_SIntfCastError, "Interface not supported" 189 | SysConst_SOverflow, "Floating point overflow" 190 | SysConst_SUnderflow, "Floating point underflow" 191 | SysConst_SInvalidPointer, "Invalid pointer operation" 192 | SysConst_SInvalidCast, "Invalid class typecast" 193 | SysConst_SAccessViolationArg3, "Access violation at address %p. %s of address %p" 194 | SysConst_SAccessViolationNoArg, "Access violation" 195 | SysConst_SStackOverflow, "Stack overflow" 196 | SysConst_SControlC, "Control-C hit" 197 | SysConst_SPrivilege, "Privileged instruction" 198 | SysConst_SException, "Exception %s in module %s at %p.\r\n%s%s\r\n" 199 | SysConst_SExceptTitle, "Application Error" 200 | SysConst_SInvalidFormat, "Format '%s' invalid or incompatible with argument" 201 | SysConst_SArgumentMissing, "No argument for format '%s'" 202 | SysConst_SDispatchError, "Variant method calls not supported" 203 | SysConst_SReadAccess, "Read" 204 | SysConst_SWriteAccess, "Write" 205 | SysConst_STimeEncodeError, "Invalid argument to time encode" 206 | SysConst_SDateEncodeError, "Invalid argument to date encode" 207 | SysConst_SOutOfMemory, "Out of memory" 208 | SysConst_SInOutError, "I/O error %d" 209 | SysConst_SFileNotFound, "File not found" 210 | SysConst_SInvalidFilename, "Invalid filename" 211 | SysConst_STooManyOpenFiles, "Too many open files" 212 | SysConst_SAccessDenied, "File access denied" 213 | SysConst_SEndOfFile, "Read beyond end of file" 214 | SysConst_SDiskFull, "Disk full" 215 | SysConst_SInvalidInput, "Invalid numeric input" 216 | SysConst_SDivByZero, "Division by zero" 217 | SysConst_SRangeError, "Range check error" 218 | SysConst_SIntOverflow, "Integer overflow" 219 | SysConst_SInvalidOp, "Invalid floating point operation" 220 | SysConst_SZeroDivide, "Floating point division by zero" 221 | END 222 | 223 | /* D:\Soft\Programming\Delphi\source\SRC\Vfs\Vfs.RES */ 224 | /* D:\Soft\Programming\Delphi\source\SRC\Vfs\Vfs.drf */ 225 | -------------------------------------------------------------------------------- /Tests/VfsIntegratedTest.pas: -------------------------------------------------------------------------------- 1 | unit VfsIntegratedTest; 2 | 3 | (***) interface (***) 4 | 5 | uses 6 | SysUtils, TestFramework, Windows, 7 | Utils, WinUtils, ConsoleApi, Files, FilesEx, 8 | DataLib, 9 | VfsUtils, VfsBase, VfsDebug, 10 | VfsOpenFiles, VfsControl, VfsTestHelper; 11 | 12 | type 13 | TestIntegrated = class (TTestCase) 14 | protected 15 | procedure SetUp; override; 16 | procedure TearDown; override; 17 | 18 | published 19 | procedure TestGetFileAttributes; 20 | procedure TestGetFileAttributesEx; 21 | procedure TestFilesOpenClose; 22 | procedure TestDirectoryListing; 23 | end; 24 | 25 | 26 | (***) implementation (***) 27 | 28 | 29 | var 30 | LogFile: Windows.THandle; 31 | 32 | procedure LogSomething (Operation, Message: pchar); stdcall; 33 | var 34 | OutputHandle: integer; 35 | 36 | begin 37 | WriteLn('>> ', string(Operation), ': ', string(Message), #13#10); 38 | 39 | OutputHandle := pinteger(@System.Output)^; 40 | pinteger(@System.Output)^ := integer(LogFile); 41 | WriteLn('>> ', string(Operation), ': ', string(Message), #13#10); 42 | pinteger(@System.Output)^ := OutputHandle; 43 | end; 44 | 45 | procedure TestIntegrated.SetUp; 46 | var 47 | RootDir: WideString; 48 | 49 | begin 50 | RootDir := VfsTestHelper.GetTestsRootDir; 51 | VfsBase.ResetVfs(); 52 | VfsBase.MapDir(RootDir, VfsUtils.MakePath([RootDir, 'Mods\FullyVirtual_2']), DONT_OVERWRITE_EXISTING); 53 | VfsBase.MapDir(RootDir, VfsUtils.MakePath([RootDir, 'Mods\FullyVirtual']), DONT_OVERWRITE_EXISTING); 54 | VfsBase.MapDir(RootDir, VfsUtils.MakePath([RootDir, 'Mods\B']), DONT_OVERWRITE_EXISTING); 55 | VfsBase.MapDir(RootDir, VfsUtils.MakePath([RootDir, 'Mods\A']), DONT_OVERWRITE_EXISTING); 56 | VfsBase.MapDir(RootDir, VfsUtils.MakePath([RootDir, 'Mods\Apache']), DONT_OVERWRITE_EXISTING); 57 | VfsDebug.SetLoggingProc(LogSomething); 58 | VfsControl.RunVfs(VfsBase.SORT_FIFO); 59 | end; 60 | 61 | procedure TestIntegrated.TearDown; 62 | begin 63 | VfsBase.ResetVfs(); 64 | VfsDebug.SetLoggingProc(nil); 65 | end; 66 | 67 | procedure TestIntegrated.TestGetFileAttributes; 68 | var 69 | RootDir: WideString; 70 | 71 | function HasValidAttrs (const Path: string; const RequiredAttrs: integer = 0; const ForbiddenAttrs: integer = 0): boolean; 72 | var 73 | Attrs: integer; 74 | 75 | begin 76 | Attrs := Int(Windows.GetFileAttributes(pchar(Path))); 77 | result := Attrs <> -1; 78 | 79 | if result then begin 80 | if RequiredAttrs <> 0 then begin 81 | result := (Attrs and RequiredAttrs) = RequiredAttrs; 82 | end; 83 | 84 | if result and (ForbiddenAttrs <> 0) then begin 85 | result := (Attrs and ForbiddenAttrs) = 0; 86 | end; 87 | end; 88 | end; // .function HasValidAttrs 89 | 90 | begin 91 | VfsDebug.WriteLog('TestGetFileAttributes', 'Started'); 92 | RootDir := VfsTestHelper.GetTestsRootDir; 93 | Check(not HasValidAttrs(VfsUtils.MakePath([RootDir, 'non-existing.non'])), '{1}'); 94 | Check(HasValidAttrs(VfsUtils.MakePath([RootDir, 'Hobbots\mms.cfg']), 0, Windows.FILE_ATTRIBUTE_DIRECTORY), '{2}'); 95 | Check(HasValidAttrs(VfsUtils.MakePath([RootDir, '503.html']), 0, Windows.FILE_ATTRIBUTE_DIRECTORY), '{3}'); 96 | Check(HasValidAttrs(VfsUtils.MakePath([RootDir, 'Hobbots\']), Windows.FILE_ATTRIBUTE_DIRECTORY), '{4}'); 97 | Check(HasValidAttrs(VfsUtils.MakePath([RootDir, 'Mods']), Windows.FILE_ATTRIBUTE_DIRECTORY), '{5}'); 98 | VfsDebug.WriteLog('TestGetFileAttributes', 'Ended'); 99 | end; // .procedure TestIntegrated.TestGetFileAttributes; 100 | 101 | procedure TestIntegrated.TestGetFileAttributesEx; 102 | var 103 | RootDir: WideString; 104 | 105 | function GetFileSize (const Path: string): integer; 106 | var 107 | FileData: Windows.TWin32FileAttributeData; 108 | 109 | begin 110 | result := -1; 111 | 112 | if Windows.GetFileAttributesExA(pchar(Path), Windows.GetFileExInfoStandard, @FileData) then begin 113 | result := Int(FileData.nFileSizeLow); 114 | end; 115 | end; 116 | 117 | begin 118 | VfsDebug.WriteLog('TestGetFileAttributesEx', 'Started'); 119 | RootDir := VfsTestHelper.GetTestsRootDir; 120 | CheckEquals(-1, GetFileSize(VfsUtils.MakePath([RootDir, 'non-existing.non'])), '{1}'); 121 | CheckEquals(42, GetFileSize(VfsUtils.MakePath([RootDir, 'Hobbots\mms.cfg'])), '{2}'); 122 | CheckEquals(22, GetFileSize(VfsUtils.MakePath([RootDir, '503.html'])), '{3}'); 123 | CheckEquals(318, GetFileSize(VfsUtils.MakePath([RootDir, 'default'])), '{4}'); 124 | VfsDebug.WriteLog('TestGetFileAttributesEx', 'Ended'); 125 | end; // .procedure TestIntegrated.TestGetFileAttributesEx; 126 | 127 | procedure TestIntegrated.TestFilesOpenClose; 128 | var 129 | CurrDir: WideString; 130 | RootDir: WideString; 131 | FileData: string; 132 | hFile: integer; 133 | 134 | function OpenFile (const Path: string): integer; 135 | begin 136 | result := SysUtils.FileOpen(Path, fmOpenRead or fmShareDenyNone); 137 | end; 138 | 139 | begin 140 | CurrDir := WinUtils.GetCurrentDirW; 141 | RootDir := VfsTestHelper.GetTestsRootDir; 142 | 143 | try 144 | VfsDebug.WriteLog('TestFilesOpenClose', 'Started'); 145 | Check(WinUtils.SetCurrentDirW(RootDir), 'Setting current directory to real path must succeed. Path: ' + RootDir); 146 | CheckEquals(RootDir, WinUtils.GetCurrentDirW(), 'GetCurrentDirW must return virtual path, not redirected one'); 147 | 148 | Check(OpenFile(VfsUtils.MakePath([RootDir, 'non-existing.non'])) <= 0, 'Opening non-existing file must fail'); 149 | 150 | hFile := OpenFile(VfsUtils.MakePath([RootDir, 'Hobbots\mms.cfg'])); 151 | Check(hFile > 0, 'Opening fully virtual file must succeed'); 152 | CheckEquals(VfsUtils.MakePath([RootDir, 'Hobbots\mms.cfg']), VfsOpenFiles.GetOpenedFilePath(hFile), 'There must be created a corresponding TOpenedFile record for opened file handle with valid virtual path'); 153 | SysUtils.FileClose(hFile); 154 | CheckEquals('', VfsOpenFiles.GetOpenedFilePath(hFile), 'TOpenedFile record must be destroyed on file handle closing {1}'); 155 | 156 | hFile := OpenFile('Hobbots\mms.cfg'); 157 | Check(hFile > 0, 'Opening fully virtual file using relative path must succeed'); 158 | CheckEquals(VfsUtils.MakePath([RootDir, 'Hobbots\mms.cfg']), VfsOpenFiles.GetOpenedFilePath(hFile), 'There must be created a corresponding TOpenedFile record for opened file handle with valid virtual path when relative path was used'); 159 | SysUtils.FileClose(hFile); 160 | CheckEquals('', VfsOpenFiles.GetOpenedFilePath(hFile), 'TOpenedFile record must be destroyed on file handle closing {2}'); 161 | 162 | Check(WinUtils.SetCurrentDirW(VfsUtils.MakePath([RootDir, 'Hobbots'])), 'Setting current durectory to fully virtual must succeed'); 163 | hFile := OpenFile('mms.cfg'); 164 | Check(hFile > 0, 'Opening fully virtual file in fully virtual directory using relative path must succeed'); 165 | CheckEquals(VfsUtils.MakePath([RootDir, 'Hobbots\mms.cfg']), VfsOpenFiles.GetOpenedFilePath(hFile), 'There must be created a corresponding TOpenedFile record for opened file handle with valid virtual path when relative path was used for fully virtual directory'); 166 | SysUtils.FileClose(hFile); 167 | CheckEquals('', VfsOpenFiles.GetOpenedFilePath(hFile), 'TOpenedFile record must be destroyed on file handle closing {3}'); 168 | 169 | Check(Files.ReadFileContents('mms.cfg', FileData), 'File mms.cfg must be readable'); 170 | CheckEquals('It was a pleasure to override you, friend!', FileData); 171 | finally 172 | WinUtils.SetCurrentDirW(CurrDir); 173 | end; // .try 174 | 175 | VfsDebug.WriteLog('TestFilesOpenClose', 'Ended'); 176 | end; // .procedure TestIntegrated.TestFilesOpenClose; 177 | 178 | procedure TestIntegrated.TestDirectoryListing; 179 | const 180 | VALID_ROOT_DIR_LISTING = 'Hobbots'#13#10'vcredist.bmp'#13#10'eula.1028.txt'#13#10'503.html'#13#10'.'#13#10'..'#13#10'default'#13#10'Mods'; 181 | VALID_ROOT_DIR_MASKED_LISTING_1 = 'vcredist.bmp'#13#10'eula.1028.txt'#13#10'503.html'; 182 | VALID_ROOT_DIR_MASKED_LISTING_2 = 'eula.1028.txt'; 183 | 184 | var 185 | {O} FileList: {U} DataLib.TStrList; 186 | {O} DirListing: VfsUtils.TDirListing; 187 | CurrDir: WideString; 188 | RootDir: WideString; 189 | DirContents: string; 190 | 191 | function GetDirListing (const Path: string): {O} DataLib.TStrList; 192 | var 193 | FoundData: TWin32FindDataA; 194 | SearchHandle: Windows.THandle; 195 | 196 | begin 197 | result := DataLib.NewStrList(not Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE); 198 | // * * * * * // 199 | SearchHandle := Windows.FindFirstFileA(pchar(Path), FoundData); 200 | 201 | if SearchHandle <> Windows.INVALID_HANDLE_VALUE then begin 202 | result.Add(pchar(@FoundData.cFileName)); 203 | 204 | while Windows.FindNextFileA(SearchHandle, FoundData) do begin 205 | result.Add(pchar(@FoundData.cFileName)); 206 | end; 207 | 208 | Windows.FindClose(SearchHandle); 209 | end; 210 | end; // .function GetDirListing 211 | 212 | function GetDirListingLow (const Path, Mask: WideString): {O} DataLib.TStrList; 213 | var 214 | FileName: WideString; 215 | 216 | begin 217 | result := DataLib.NewStrList(not Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE); 218 | // * * * * * // 219 | with VfsUtils.SysScanDir(Path, Mask) do begin 220 | while IterNext(FileName) do begin 221 | result.Add(FileName); 222 | end; 223 | end; 224 | end; // .function GetDirListingLow 225 | 226 | begin 227 | FileList := nil; 228 | DirListing := VfsUtils.TDirListing.Create; 229 | // * * * * * // 230 | CurrDir := WinUtils.GetCurrentDirW; 231 | RootDir := VfsTestHelper.GetTestsRootDir; 232 | 233 | try 234 | VfsDebug.WriteLog('TestDirectoryListing', 'Started'); 235 | FileList := GetDirListing(VfsUtils.MakePath([RootDir, '*'])); 236 | DirContents := FileList.ToText(#13#10); 237 | CheckEquals(VALID_ROOT_DIR_LISTING, DirContents); 238 | SysUtils.FreeAndNil(FileList); 239 | 240 | FileList := GetDirListingLow(RootDir, '*.??*'); 241 | DirContents := FileList.ToText(#13#10); 242 | CheckEquals(VALID_ROOT_DIR_MASKED_LISTING_1, DirContents); 243 | SysUtils.FreeAndNil(FileList); 244 | 245 | FileList := GetDirListing(VfsUtils.MakePath([RootDir, '*.txt'])); 246 | DirContents := FileList.ToText(#13#10); 247 | CheckEquals(VALID_ROOT_DIR_MASKED_LISTING_2, DirContents); 248 | SysUtils.FreeAndNil(FileList); 249 | finally 250 | WinUtils.SetCurrentDirW(CurrDir); 251 | SysUtils.FreeAndNil(FileList); 252 | SysUtils.FreeAndNil(DirListing); 253 | end; // .try 254 | 255 | VfsDebug.WriteLog('TestDirectoryListing', 'Ended'); 256 | end; // .procedure TestIntegrated.TestDirectoryListing; 257 | 258 | begin 259 | RegisterTest(TestIntegrated.Suite); 260 | LogFile := SysUtils.FileCreate(SysUtils.ExtractFileDir(WinUtils.GetExePath()) + '\_LOG_.txt'); 261 | end. -------------------------------------------------------------------------------- /VfsWatching.pas: -------------------------------------------------------------------------------- 1 | unit VfsWatching; 2 | (* 3 | Description: Provides means to watch for mapped directories changes and refresh VFS. 4 | Works unreliably when trying to watch the whole logical drive. 5 | *) 6 | 7 | 8 | (***) interface (***) 9 | 10 | uses 11 | Windows, SysUtils, Math, 12 | Utils, Concur, WinUtils, StrLib, WinNative, 13 | VfsBase, VfsUtils; 14 | 15 | 16 | (* Spawns separate thread, which starts recursive monitoring for changes in specified directory. 17 | VFS will be fully refreshed or smartly updated on any change. Debounce interval specifies 18 | time in msec to wait after last change before running full VFS rescanning routine *) 19 | function RunWatcher (const WatchDir: WideString; DebounceInterval: integer): boolean; 20 | 21 | 22 | (***) implementation (***) 23 | 24 | 25 | type 26 | (* Import *) 27 | THandle = Windows.THandle; 28 | 29 | const 30 | (* Import *) 31 | INVALID_HANDLE_VALUE = Windows.INVALID_HANDLE_VALUE; 32 | 33 | STOP_EVENT_HANDLE_IND = 0; 34 | NOTIFICATION_HANDLE_INDEX = 1; 35 | NUM_WATCHED_HANDLES = 2; 36 | 37 | type 38 | TDirChangeAction = (NOTIFY_FILE_ADDED, NOTIFY_FILE_REMOVED, NOTIFY_FILE_MODIFIED, NOTIFY_FILE_RENAMED_FROM_NAME, NOTIFY_FILE_RENAMED_TO_NAME, 39 | NOTIFY_STOP_EVENT, NOTIFY_TIMEOUT, NOTIFY_TOO_MANY_CHANGES, NOTIFY_UNKNOWN_ACTION); 40 | 41 | const 42 | NOTIFY_ESSENTIAL = FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_DIR_NAME or FILE_NOTIFY_CHANGE_ATTRIBUTES or FILE_NOTIFY_CHANGE_SIZE or FILE_NOTIFY_CHANGE_CREATION; 43 | NO_STOP_EVENT = 0; 44 | INFINITE = Windows.INFINITE; 45 | 46 | type 47 | (* Directory change record *) 48 | TDirChange = record 49 | Action: TDirChangeAction; 50 | 51 | (* Absolute expanded and normalized path to file, that triggered notification *) 52 | FilePath: WideString; 53 | end; 54 | 55 | IDirChangesIterator = interface 56 | function IterNext ({out} var DirChange: TDirChange; StopEvent: THandle = 0; Timeout: integer = integer(Windows.INFINITE); NotifyFilter: cardinal = NOTIFY_ESSENTIAL): boolean; 57 | end; 58 | 59 | TDirChangesIterator = class (Utils.TManagedObject, IDirChangesIterator) 60 | protected const 61 | BUF_SIZE = 65500; 62 | 63 | protected 64 | {O} fDirHandle: THandle; 65 | {O} fNotifyEvent: THandle; 66 | fDirPath: WideString; 67 | fBuf: array [0..BUF_SIZE - 1] of byte; 68 | fBufSize: integer; 69 | fBufPos: integer; 70 | fIsEnd: boolean; 71 | 72 | public 73 | constructor Create (const DirPath: WideString); overload; 74 | destructor Destroy; override; 75 | 76 | function IterNext ({out} var DirChange: TDirChange; StopEvent: THandle = 0; Timeout: integer = integer(Windows.INFINITE); NotifyFilter: cardinal = NOTIFY_ESSENTIAL): boolean; 77 | end; // .class TDirChangesIterator 78 | 79 | var 80 | WatcherCritSection: Concur.TCritSection; 81 | AbsWatcherDir: WideString; 82 | WatcherDebounceInterval: integer; 83 | WatcherStopEvent: THandle = 0; 84 | WatcherIsRunning: boolean = false; 85 | WatcherThreadHandle: THandle; 86 | WatcherThreadId: cardinal; 87 | 88 | 89 | function IsValidHandle (Handle: THandle): boolean; inline; 90 | begin 91 | result := (Handle <> 0) and (Handle <> INVALID_HANDLE_VALUE); 92 | end; 93 | 94 | constructor TDirChangesIterator.Create (const DirPath: WideString); 95 | const 96 | MANUAL_RESET_EVENT = true; 97 | 98 | begin 99 | Self.fDirPath := VfsUtils.NormalizePath(DirPath); 100 | Self.fDirHandle := Windows.CreateFileW(PWideChar(Self.fDirPath), Windows.GENERIC_READ, Windows.FILE_SHARE_READ or Windows.FILE_SHARE_WRITE, nil, 101 | Windows.OPEN_EXISTING, Windows.FILE_FLAG_BACKUP_SEMANTICS or Windows.FILE_FLAG_OVERLAPPED, 0); 102 | 103 | if IsValidHandle(Self.fDirHandle) then begin 104 | Self.fNotifyEvent := Windows.CreateEventW(nil, MANUAL_RESET_EVENT, false, nil); 105 | 106 | if not IsValidHandle(Self.fNotifyEvent) then begin 107 | Windows.CloseHandle(Self.fDirHandle); 108 | Self.fDirHandle := 0; 109 | end; 110 | end; 111 | 112 | Self.fIsEnd := not IsValidHandle(Self.fDirHandle); 113 | end; // .constructor TDirChangesIterator.Create 114 | 115 | destructor TDirChangesIterator.Destroy; 116 | begin 117 | if IsValidHandle(Self.fDirHandle) then begin 118 | Windows.CloseHandle(Self.fDirHandle); 119 | end; 120 | 121 | if IsValidHandle(Self.fNotifyEvent) then begin 122 | Windows.CloseHandle(Self.fNotifyEvent); 123 | end; 124 | end; 125 | 126 | function DecodeNativeDirChangeAction (Action: integer): TDirChangeAction; 127 | begin 128 | case Action of 129 | Windows.FILE_ACTION_ADDED: result := NOTIFY_FILE_ADDED; 130 | Windows.FILE_ACTION_REMOVED: result := NOTIFY_FILE_REMOVED; 131 | Windows.FILE_ACTION_MODIFIED: result := NOTIFY_FILE_MODIFIED; 132 | Windows.FILE_ACTION_RENAMED_OLD_NAME: result := NOTIFY_FILE_RENAMED_FROM_NAME; 133 | Windows.FILE_ACTION_RENAMED_NEW_NAME: result := NOTIFY_FILE_RENAMED_TO_NAME; 134 | else 135 | result := NOTIFY_UNKNOWN_ACTION; 136 | end; 137 | end; 138 | 139 | function TDirChangesIterator.IterNext ({out} var DirChange: TDirChange; StopEvent: THandle = 0; Timeout: integer = integer(Windows.INFINITE); NotifyFilter: cardinal = NOTIFY_ESSENTIAL): boolean; 140 | const 141 | WATCH_SUBTREE = true; 142 | WAIT_OVERLAPPED = true; 143 | 144 | 145 | var 146 | {n} NotifInfoInBuf: WinNative.PFILE_NOTIFY_INFORMATION; 147 | AsyncRes: Windows.TOverlapped; 148 | TriggeredEvent: THandle; 149 | Dummy: integer; 150 | 151 | begin 152 | NotifInfoInBuf := nil; 153 | // * * * * * // 154 | result := not Self.fIsEnd; 155 | 156 | if not result then begin 157 | exit; 158 | end; 159 | 160 | if Timeout = 0 then begin 161 | DirChange.Action := NOTIFY_TIMEOUT; 162 | exit; 163 | end; 164 | 165 | if Self.fBufPos < fBufSize then begin 166 | NotifInfoInBuf := @Self.fBuf[Self.fBufPos]; 167 | DirChange.Action := DecodeNativeDirChangeAction(NotifInfoInBuf.Action); 168 | 169 | if DirChange.Action = NOTIFY_FILE_REMOVED then begin 170 | DirChange.FilePath := VfsUtils.AddBackslash(Self.fDirPath) + NotifInfoInBuf.GetFileName; 171 | DirChange.FilePath := VfsUtils.AddBackslash(WinUtils.GetLongPathW(StrLib.ExtractDirPathW(DirChange.FilePath))) + StrLib.ExtractFileNameW(DirChange.FilePath); 172 | end else begin 173 | DirChange.FilePath := WinUtils.GetLongPathW(VfsUtils.AddBackslash(Self.fDirPath) + NotifInfoInBuf.GetFileName); 174 | end; 175 | 176 | Self.fBufPos := Utils.IfThen(NotifInfoInBuf.NextEntryOffset <> 0, Self.fBufPos + integer(NotifInfoInBuf.NextEntryOffset), Self.BUF_SIZE); 177 | end else begin 178 | FillChar(AsyncRes, sizeof(AsyncRes), 0); 179 | AsyncRes.hEvent := Self.fNotifyEvent; 180 | Windows.ResetEvent(Self.fNotifyEvent); 181 | 182 | Self.fBufSize := 0; 183 | Self.fBufPos := 0; 184 | result := Windows.ReadDirectoryChangesW(Self.fDirHandle, @Self.fBuf, sizeof(Self.fBuf), WATCH_SUBTREE, NotifyFilter, @Dummy, @AsyncRes, nil); 185 | 186 | if result then begin 187 | DirChange.FilePath := ''; 188 | 189 | case WinUtils.WaitForObjects([StopEvent, Self.fNotifyEvent], TriggeredEvent, Timeout) of 190 | WinUtils.WR_WAITED: begin 191 | if TriggeredEvent = StopEvent then begin 192 | DirChange.Action := NOTIFY_STOP_EVENT; 193 | end else begin 194 | result := Windows.GetOverlappedResult(Self.fNotifyEvent, AsyncRes, cardinal(Self.fBufSize), not WAIT_OVERLAPPED); 195 | 196 | if result then begin 197 | if Self.fBufSize = 0 then begin 198 | DirChange.Action := NOTIFY_TOO_MANY_CHANGES; 199 | end else if Self.fBufSize < sizeof(NotifInfoInBuf^) + sizeof(WideChar) then begin 200 | result := false; 201 | end else begin 202 | result := Self.IterNext(DirChange, StopEvent, Timeout, NotifyFilter); 203 | end; 204 | end; 205 | end; 206 | end; // .case WR_WAITED 207 | 208 | WinUtils.WR_TIMEOUT: begin 209 | DirChange.Action := NOTIFY_TIMEOUT; 210 | end; 211 | else 212 | result := false; 213 | end; // .switch wait result 214 | end; // .if 215 | 216 | Self.fIsEnd := not result; 217 | end; // .else 218 | end; // .function TDirChangesIterator.IterNext 219 | 220 | function ReadDirChanges (const DirPath: WideString): IDirChangesIterator; 221 | begin 222 | result := TDirChangesIterator.Create(DirPath); 223 | end; 224 | 225 | function WatcherThreadProc (Arg: integer): integer; stdcall; 226 | var 227 | IsEnd: LONGBOOL; 228 | NeedFullRescan: LONGBOOL; 229 | CurrentTime: Int64; 230 | LastChangeTime: Int64; 231 | PlannedRescanTime: Int64; 232 | Timeout: integer; 233 | DummyEvent: THandle; 234 | DirChangesScanner: IDirChangesIterator; 235 | DirChange: TDirChange; 236 | 237 | begin 238 | DirChangesScanner := nil; 239 | // * * * * * // 240 | IsEnd := false; 241 | NeedFullRescan := false; 242 | LastChangeTime := 0; 243 | result := 0; 244 | 245 | with VfsBase.GetThreadVfsDisabler do begin 246 | DisableVfsForThread; 247 | 248 | try 249 | while not IsEnd do begin 250 | CurrentTime := GetMicroTime; 251 | PlannedRescanTime := LastChangeTime + Int64(WatcherDebounceInterval); 252 | 253 | if NeedFullRescan and (PlannedRescanTime <= CurrentTime) then begin 254 | VfsBase.RefreshVfs; 255 | NeedFullRescan := false; 256 | end; 257 | 258 | if DirChangesScanner = nil then begin 259 | DirChangesScanner := TDirChangesIterator.Create(AbsWatcherDir); 260 | end; 261 | 262 | // Failed to start watching directory 263 | if not DirChangesScanner.IterNext(DirChange, WatcherStopEvent, Utils.IfThen(boolean(NeedFullRescan), integer(PlannedRescanTime - CurrentTime), integer(Windows.INFINITE))) then begin 264 | // Force scanner recreation later 265 | DirChangesScanner := nil; 266 | 267 | // Wait and retry, unless stop signal is received 268 | Timeout := Utils.IfThen(NeedFullRescan, Min(WatcherDebounceInterval, integer(PlannedRescanTime - CurrentTime)), WatcherDebounceInterval); 269 | 270 | if WinUtils.WaitForObjects([WatcherStopEvent], DummyEvent, Timeout) = WinUtils.WR_WAITED then begin 271 | IsEnd := true; 272 | end; 273 | // Ok, got some signal 274 | end else begin 275 | if DirChange.Action = NOTIFY_STOP_EVENT then begin 276 | IsEnd := true; 277 | end else if DirChange.Action = NOTIFY_TIMEOUT then begin 278 | // Will perform full rescan on next loop iteration 279 | end else if DirChange.Action in [NOTIFY_FILE_ADDED, NOTIFY_FILE_REMOVED, NOTIFY_FILE_RENAMED_FROM_NAME, NOTIFY_FILE_RENAMED_TO_NAME, NOTIFY_UNKNOWN_ACTION, NOTIFY_TOO_MANY_CHANGES] then begin 280 | LastChangeTime := WinUtils.GetMicroTime; 281 | NeedFullRescan := true; 282 | end else if DirChange.Action = NOTIFY_FILE_MODIFIED then begin 283 | if not NeedFullRescan then begin 284 | VfsBase.RefreshMappedFile(DirChange.FilePath); 285 | end; 286 | 287 | LastChangeTime := WinUtils.GetMicroTime; 288 | end; 289 | end; // .else 290 | end; // .while 291 | finally 292 | RestoreVfsForThread; 293 | end; // .try 294 | end; // .with 295 | end; // .function WatcherThreadProc 296 | 297 | function RunWatcher (const WatchDir: WideString; DebounceInterval: integer): boolean; 298 | const 299 | MANUAL_RESET = true; 300 | 301 | begin 302 | with WatcherCritSection do begin 303 | Enter; 304 | 305 | result := not WatcherIsRunning; 306 | 307 | if result then begin 308 | AbsWatcherDir := VfsUtils.NormalizePath(WatchDir); 309 | WatcherDebounceInterval := Max(0, DebounceInterval); 310 | 311 | if not WinUtils.IsValidHandle(WatcherStopEvent) then begin 312 | WatcherStopEvent := Windows.CreateEventW(nil, MANUAL_RESET, false, nil); 313 | result := WinUtils.IsValidHandle(WatcherStopEvent); 314 | end; 315 | 316 | if result then begin 317 | WatcherThreadHandle := Windows.CreateThread(nil, 0, @WatcherThreadProc, nil, 0, WatcherThreadId); 318 | end; 319 | end; 320 | 321 | Leave; 322 | end; // .with 323 | end; // .function RunWatcher 324 | 325 | function StopWatcher: LONGBOOL; 326 | const 327 | MANUAL_RESET = true; 328 | 329 | begin 330 | with WatcherCritSection do begin 331 | Enter; 332 | 333 | result := WatcherIsRunning; 334 | 335 | if result then begin 336 | Windows.SetEvent(WatcherStopEvent); 337 | result := Windows.WaitForSingleObject(WatcherThreadHandle, Windows.INFINITE) = Windows.WAIT_OBJECT_0; 338 | 339 | if result then begin 340 | Windows.CloseHandle(WatcherThreadHandle); 341 | Windows.CloseHandle(WatcherStopEvent); 342 | WatcherThreadHandle := 0; 343 | WatcherStopEvent := 0; 344 | WatcherIsRunning := false; 345 | end; 346 | end; 347 | 348 | Leave; 349 | end; // .with 350 | end; // .function StopWatcher 351 | 352 | begin 353 | WatcherCritSection.Init; 354 | end. -------------------------------------------------------------------------------- /VfsTest.drc: -------------------------------------------------------------------------------- 1 | /* VER185 2 | Generated by the CodeGear Delphi Pascal Compiler 3 | because -GD or --drc was supplied to the compiler. 4 | 5 | This file contains compiler-generated resources that 6 | were bound to the executable. 7 | If this file is empty, then no compiler-generated 8 | resources were bound to the produced executable. 9 | */ 10 | 11 | #define ComStrs_sRichEditSaveFail 65280 12 | #define ComStrs_sInvalidComCtl32 65281 13 | #define Consts_SDockZoneHasNoCtl 65296 14 | #define Consts_SDockZoneVersionConflict 65297 15 | #define Consts_SMultiSelectRequired 65298 16 | #define Consts_SSeparator 65299 17 | #define Consts_SNoGetItemEventHandler 65300 18 | #define Consts_SANSIEncoding 65301 19 | #define Consts_SASCIIEncoding 65302 20 | #define Consts_SUnicodeEncoding 65303 21 | #define Consts_SBigEndianEncoding 65304 22 | #define Consts_SUTF8Encoding 65305 23 | #define Consts_SUTF7Encoding 65306 24 | #define ComStrs_sInvalidIndex 65307 25 | #define ComStrs_sInsertError 65308 26 | #define ComStrs_sInvalidOwner 65309 27 | #define ComStrs_sRichEditInsertError 65310 28 | #define ComStrs_sRichEditLoadFail 65311 29 | #define Consts_SmkcDown 65312 30 | #define Consts_SmkcIns 65313 31 | #define Consts_SmkcDel 65314 32 | #define Consts_SmkcShift 65315 33 | #define Consts_SmkcCtrl 65316 34 | #define Consts_SmkcAlt 65317 35 | #define Consts_SOutOfRange 65318 36 | #define Consts_SInvalidClipFmt 65319 37 | #define Consts_SIconToClipboard 65320 38 | #define Consts_SCannotOpenClipboard 65321 39 | #define Consts_SInvalidMemoSize 65322 40 | #define Consts_SNoDefaultPrinter 65323 41 | #define Consts_SDuplicateMenus 65324 42 | #define Consts_SDockedCtlNeedsName 65325 43 | #define Consts_SDockTreeRemoveError 65326 44 | #define Consts_SDockZoneNotFound 65327 45 | #define Consts_SMsgDlgIgnore 65328 46 | #define Consts_SMsgDlgAll 65329 47 | #define Consts_SMsgDlgNoToAll 65330 48 | #define Consts_SMsgDlgYesToAll 65331 49 | #define Consts_SmkcBkSp 65332 50 | #define Consts_SmkcTab 65333 51 | #define Consts_SmkcEsc 65334 52 | #define Consts_SmkcEnter 65335 53 | #define Consts_SmkcSpace 65336 54 | #define Consts_SmkcPgUp 65337 55 | #define Consts_SmkcPgDn 65338 56 | #define Consts_SmkcEnd 65339 57 | #define Consts_SmkcHome 65340 58 | #define Consts_SmkcLeft 65341 59 | #define Consts_SmkcUp 65342 60 | #define Consts_SmkcRight 65343 61 | #define Consts_SIgnoreButton 65344 62 | #define Consts_SRetryButton 65345 63 | #define Consts_SAbortButton 65346 64 | #define Consts_SAllButton 65347 65 | #define Consts_SCannotDragForm 65348 66 | #define Consts_SMsgDlgWarning 65349 67 | #define Consts_SMsgDlgError 65350 68 | #define Consts_SMsgDlgInformation 65351 69 | #define Consts_SMsgDlgConfirm 65352 70 | #define Consts_SMsgDlgYes 65353 71 | #define Consts_SMsgDlgNo 65354 72 | #define Consts_SMsgDlgOK 65355 73 | #define Consts_SMsgDlgCancel 65356 74 | #define Consts_SMsgDlgHelp 65357 75 | #define Consts_SMsgDlgAbort 65358 76 | #define Consts_SMsgDlgRetry 65359 77 | #define Consts_SMenuReinserted 65360 78 | #define Consts_SMenuNotFound 65361 79 | #define Consts_SNoTimers 65362 80 | #define Consts_SNotPrinting 65363 81 | #define Consts_SPrinting 65364 82 | #define Consts_SInvalidPrinter 65365 83 | #define Consts_SDeviceOnPort 65366 84 | #define Consts_SGroupIndexTooLow 65367 85 | #define Consts_SNoMDIForm 65368 86 | #define Consts_SControlParentSetToSelf 65369 87 | #define Consts_SOKButton 65370 88 | #define Consts_SCancelButton 65371 89 | #define Consts_SYesButton 65372 90 | #define Consts_SNoButton 65373 91 | #define Consts_SHelpButton 65374 92 | #define Consts_SCloseButton 65375 93 | #define Consts_SNoCanvasHandle 65376 94 | #define Consts_SInvalidImageSize 65377 95 | #define Consts_SInvalidImageList 65378 96 | #define Consts_SImageIndexError 65379 97 | #define Consts_SImageReadFail 65380 98 | #define Consts_SImageWriteFail 65381 99 | #define Consts_SWindowDCError 65382 100 | #define Consts_SWindowClass 65383 101 | #define Consts_SCannotFocus 65384 102 | #define Consts_SParentRequired 65385 103 | #define Consts_SParentGivenNotAParent 65386 104 | #define Consts_SMDIChildNotVisible 65387 105 | #define Consts_SVisibleChanged 65388 106 | #define Consts_SCannotShowModal 65389 107 | #define Consts_SPropertyOutOfRange 65390 108 | #define Consts_SMenuIndexError 65391 109 | #define RTLConsts_SSeekNotImplemented 65392 110 | #define RTLConsts_SSortedListError 65393 111 | #define RTLConsts_SUnknownGroup 65394 112 | #define RTLConsts_SUnknownProperty 65395 113 | #define RTLConsts_SWriteError 65396 114 | #define HelpIntfs_hNoTableOfContents 65397 115 | #define HelpIntfs_hNothingFound 65398 116 | #define HelpIntfs_hNoContext 65399 117 | #define HelpIntfs_hNoContextFound 65400 118 | #define HelpIntfs_hNoTopics 65401 119 | #define Consts_SInvalidBitmap 65402 120 | #define Consts_SInvalidIcon 65403 121 | #define Consts_SInvalidMetafile 65404 122 | #define Consts_SChangeIconSize 65405 123 | #define Consts_SUnknownClipboardFormat 65406 124 | #define Consts_SOutOfResources 65407 125 | #define RTLConsts_SInvalidName 65408 126 | #define RTLConsts_SInvalidProperty 65409 127 | #define RTLConsts_SInvalidPropertyPath 65410 128 | #define RTLConsts_SInvalidPropertyValue 65411 129 | #define RTLConsts_SInvalidRegType 65412 130 | #define RTLConsts_SListCapacityError 65413 131 | #define RTLConsts_SListCountError 65414 132 | #define RTLConsts_SListIndexError 65415 133 | #define RTLConsts_SMemoryStreamError 65416 134 | #define RTLConsts_SPropertyException 65417 135 | #define RTLConsts_SReadError 65418 136 | #define RTLConsts_SReadOnlyProperty 65419 137 | #define RTLConsts_SRegCreateFailed 65420 138 | #define RTLConsts_SRegGetDataFailed 65421 139 | #define RTLConsts_SRegSetDataFailed 65422 140 | #define RTLConsts_SResNotFound 65423 141 | #define SysConst_SLongDayNameFri 65424 142 | #define SysConst_SLongDayNameSat 65425 143 | #define RTLConsts_SAncestorNotFound 65426 144 | #define RTLConsts_SAssignError 65427 145 | #define RTLConsts_SBitsIndexError 65428 146 | #define RTLConsts_SCantWriteResourceStreamError 65429 147 | #define RTLConsts_SCheckSynchronizeError 65430 148 | #define RTLConsts_SClassNotFound 65431 149 | #define RTLConsts_SDuplicateClass 65432 150 | #define RTLConsts_SDuplicateItem 65433 151 | #define RTLConsts_SDuplicateName 65434 152 | #define RTLConsts_SDuplicateString 65435 153 | #define RTLConsts_SFCreateErrorEx 65436 154 | #define RTLConsts_SFOpenErrorEx 65437 155 | #define RTLConsts_SIniFileWriteError 65438 156 | #define RTLConsts_SInvalidImage 65439 157 | #define SysConst_SLongMonthNameSep 65440 158 | #define SysConst_SLongMonthNameOct 65441 159 | #define SysConst_SLongMonthNameNov 65442 160 | #define SysConst_SLongMonthNameDec 65443 161 | #define SysConst_SShortDayNameSun 65444 162 | #define SysConst_SShortDayNameMon 65445 163 | #define SysConst_SShortDayNameTue 65446 164 | #define SysConst_SShortDayNameWed 65447 165 | #define SysConst_SShortDayNameThu 65448 166 | #define SysConst_SShortDayNameFri 65449 167 | #define SysConst_SShortDayNameSat 65450 168 | #define SysConst_SLongDayNameSun 65451 169 | #define SysConst_SLongDayNameMon 65452 170 | #define SysConst_SLongDayNameTue 65453 171 | #define SysConst_SLongDayNameWed 65454 172 | #define SysConst_SLongDayNameThu 65455 173 | #define SysConst_SShortMonthNameMay 65456 174 | #define SysConst_SShortMonthNameJun 65457 175 | #define SysConst_SShortMonthNameJul 65458 176 | #define SysConst_SShortMonthNameAug 65459 177 | #define SysConst_SShortMonthNameSep 65460 178 | #define SysConst_SShortMonthNameOct 65461 179 | #define SysConst_SShortMonthNameNov 65462 180 | #define SysConst_SShortMonthNameDec 65463 181 | #define SysConst_SLongMonthNameJan 65464 182 | #define SysConst_SLongMonthNameFeb 65465 183 | #define SysConst_SLongMonthNameMar 65466 184 | #define SysConst_SLongMonthNameApr 65467 185 | #define SysConst_SLongMonthNameMay 65468 186 | #define SysConst_SLongMonthNameJun 65469 187 | #define SysConst_SLongMonthNameJul 65470 188 | #define SysConst_SLongMonthNameAug 65471 189 | #define SysConst_SVarBadType 65472 190 | #define SysConst_SVarNotImplemented 65473 191 | #define SysConst_SVarUnexpected 65474 192 | #define SysConst_SExternalException 65475 193 | #define SysConst_SAssertionFailed 65476 194 | #define SysConst_SIntfCastError 65477 195 | #define SysConst_SSafecallException 65478 196 | #define SysConst_SAssertError 65479 197 | #define SysConst_SAbstractError 65480 198 | #define SysConst_SModuleAccessViolation 65481 199 | #define SysConst_SOSError 65482 200 | #define SysConst_SUnkOSError 65483 201 | #define SysConst_SShortMonthNameJan 65484 202 | #define SysConst_SShortMonthNameFeb 65485 203 | #define SysConst_SShortMonthNameMar 65486 204 | #define SysConst_SShortMonthNameApr 65487 205 | #define SysConst_SInvalidFormat 65488 206 | #define SysConst_SArgumentMissing 65489 207 | #define SysConst_SDispatchError 65490 208 | #define SysConst_SReadAccess 65491 209 | #define SysConst_SWriteAccess 65492 210 | #define SysConst_SVarArrayCreate 65493 211 | #define SysConst_SVarArrayBounds 65494 212 | #define SysConst_SVarArrayLocked 65495 213 | #define SysConst_SInvalidVarCast 65496 214 | #define SysConst_SInvalidVarOp 65497 215 | #define SysConst_SInvalidVarNullOp 65498 216 | #define SysConst_SInvalidVarOpWithHResultWithPrefix 65499 217 | #define SysConst_SVarTypeCouldNotConvert 65500 218 | #define SysConst_SVarTypeConvertOverflow 65501 219 | #define SysConst_SVarOverflow 65502 220 | #define SysConst_SVarInvalid 65503 221 | #define SysConst_SDivByZero 65504 222 | #define SysConst_SRangeError 65505 223 | #define SysConst_SIntOverflow 65506 224 | #define SysConst_SInvalidOp 65507 225 | #define SysConst_SZeroDivide 65508 226 | #define SysConst_SOverflow 65509 227 | #define SysConst_SUnderflow 65510 228 | #define SysConst_SInvalidPointer 65511 229 | #define SysConst_SInvalidCast 65512 230 | #define SysConst_SAccessViolationArg3 65513 231 | #define SysConst_SAccessViolationNoArg 65514 232 | #define SysConst_SStackOverflow 65515 233 | #define SysConst_SControlC 65516 234 | #define SysConst_SPrivilege 65517 235 | #define SysConst_SException 65518 236 | #define SysConst_SExceptTitle 65519 237 | #define SysConst_SInvalidInteger 65520 238 | #define SysConst_SInvalidFloat 65521 239 | #define SysConst_SInvalidDate 65522 240 | #define SysConst_SInvalidTime 65523 241 | #define SysConst_SInvalidDateTime 65524 242 | #define SysConst_STimeEncodeError 65525 243 | #define SysConst_SDateEncodeError 65526 244 | #define SysConst_SOutOfMemory 65527 245 | #define SysConst_SInOutError 65528 246 | #define SysConst_SFileNotFound 65529 247 | #define SysConst_SInvalidFilename 65530 248 | #define SysConst_STooManyOpenFiles 65531 249 | #define SysConst_SAccessDenied 65532 250 | #define SysConst_SEndOfFile 65533 251 | #define SysConst_SDiskFull 65534 252 | #define SysConst_SInvalidInput 65535 253 | STRINGTABLE 254 | BEGIN 255 | ComStrs_sRichEditSaveFail, "Failed to Save Stream" 256 | ComStrs_sInvalidComCtl32, "This control requires version 4.70 or greater of COMCTL32.DLL" 257 | Consts_SDockZoneHasNoCtl, " - Dock zone has no control" 258 | Consts_SDockZoneVersionConflict, "Error loading dock zone from the stream. Expecting version %d, but found %d." 259 | Consts_SMultiSelectRequired, "Multiselect mode must be on for this feature" 260 | Consts_SSeparator, "Separator" 261 | Consts_SNoGetItemEventHandler, "No OnGetItem event handler assigned" 262 | Consts_SANSIEncoding, "ANSI" 263 | Consts_SASCIIEncoding, "ASCII" 264 | Consts_SUnicodeEncoding, "Unicode" 265 | Consts_SBigEndianEncoding, "Big Endian Unicode" 266 | Consts_SUTF8Encoding, "UTF-8" 267 | Consts_SUTF7Encoding, "UTF-7" 268 | ComStrs_sInvalidIndex, "Invalid index" 269 | ComStrs_sInsertError, "Unable to insert an item" 270 | ComStrs_sInvalidOwner, "Invalid owner" 271 | ComStrs_sRichEditInsertError, "RichEdit line insertion error" 272 | ComStrs_sRichEditLoadFail, "Failed to Load Stream" 273 | Consts_SmkcDown, "Down" 274 | Consts_SmkcIns, "Ins" 275 | Consts_SmkcDel, "Del" 276 | Consts_SmkcShift, "Shift+" 277 | Consts_SmkcCtrl, "Ctrl+" 278 | Consts_SmkcAlt, "Alt+" 279 | Consts_SOutOfRange, "Value must be between %d and %d" 280 | Consts_SInvalidClipFmt, "Invalid clipboard format" 281 | Consts_SIconToClipboard, "Clipboard does not support Icons" 282 | Consts_SCannotOpenClipboard, "Cannot open clipboard" 283 | Consts_SInvalidMemoSize, "Text exceeds memo capacity" 284 | Consts_SNoDefaultPrinter, "There is no default printer currently selected" 285 | Consts_SDuplicateMenus, "Menu '%s' is already being used by another form" 286 | Consts_SDockedCtlNeedsName, "Docked control must have a name" 287 | Consts_SDockTreeRemoveError, "Error removing control from dock tree" 288 | Consts_SDockZoneNotFound, " - Dock zone not found" 289 | Consts_SMsgDlgIgnore, "&Ignore" 290 | Consts_SMsgDlgAll, "&All" 291 | Consts_SMsgDlgNoToAll, "N&o to All" 292 | Consts_SMsgDlgYesToAll, "Yes to &All" 293 | Consts_SmkcBkSp, "BkSp" 294 | Consts_SmkcTab, "Tab" 295 | Consts_SmkcEsc, "Esc" 296 | Consts_SmkcEnter, "Enter" 297 | Consts_SmkcSpace, "Space" 298 | Consts_SmkcPgUp, "PgUp" 299 | Consts_SmkcPgDn, "PgDn" 300 | Consts_SmkcEnd, "End" 301 | Consts_SmkcHome, "Home" 302 | Consts_SmkcLeft, "Left" 303 | Consts_SmkcUp, "Up" 304 | Consts_SmkcRight, "Right" 305 | Consts_SIgnoreButton, "&Ignore" 306 | Consts_SRetryButton, "&Retry" 307 | Consts_SAbortButton, "Abort" 308 | Consts_SAllButton, "&All" 309 | Consts_SCannotDragForm, "Cannot drag a form" 310 | Consts_SMsgDlgWarning, "Warning" 311 | Consts_SMsgDlgError, "Error" 312 | Consts_SMsgDlgInformation, "Information" 313 | Consts_SMsgDlgConfirm, "Confirm" 314 | Consts_SMsgDlgYes, "&Yes" 315 | Consts_SMsgDlgNo, "&No" 316 | Consts_SMsgDlgOK, "OK" 317 | Consts_SMsgDlgCancel, "Cancel" 318 | Consts_SMsgDlgHelp, "&Help" 319 | Consts_SMsgDlgAbort, "&Abort" 320 | Consts_SMsgDlgRetry, "&Retry" 321 | Consts_SMenuReinserted, "Menu inserted twice" 322 | Consts_SMenuNotFound, "Sub-menu is not in menu" 323 | Consts_SNoTimers, "Not enough timers available" 324 | Consts_SNotPrinting, "Printer is not currently printing" 325 | Consts_SPrinting, "Printing in progress" 326 | Consts_SInvalidPrinter, "Printer selected is not valid" 327 | Consts_SDeviceOnPort, "%s on %s" 328 | Consts_SGroupIndexTooLow, "GroupIndex cannot be less than a previous menu item's GroupIndex" 329 | Consts_SNoMDIForm, "Cannot create form. No MDI forms are currently active" 330 | Consts_SControlParentSetToSelf, "A control cannot have itself as its parent" 331 | Consts_SOKButton, "OK" 332 | Consts_SCancelButton, "Cancel" 333 | Consts_SYesButton, "&Yes" 334 | Consts_SNoButton, "&No" 335 | Consts_SHelpButton, "&Help" 336 | Consts_SCloseButton, "&Close" 337 | Consts_SNoCanvasHandle, "Canvas does not allow drawing" 338 | Consts_SInvalidImageSize, "Invalid image size" 339 | Consts_SInvalidImageList, "Invalid ImageList" 340 | Consts_SImageIndexError, "Invalid ImageList Index" 341 | Consts_SImageReadFail, "Failed to read ImageList data from stream" 342 | Consts_SImageWriteFail, "Failed to write ImageList data to stream" 343 | Consts_SWindowDCError, "Error creating window device context" 344 | Consts_SWindowClass, "Error creating window class" 345 | Consts_SCannotFocus, "Cannot focus a disabled or invisible window" 346 | Consts_SParentRequired, "Control '%s' has no parent window" 347 | Consts_SParentGivenNotAParent, "Parent given is not a parent of '%s'" 348 | Consts_SMDIChildNotVisible, "Cannot hide an MDI Child Form" 349 | Consts_SVisibleChanged, "Cannot change Visible in OnShow or OnHide" 350 | Consts_SCannotShowModal, "Cannot make a visible window modal" 351 | Consts_SPropertyOutOfRange, "%s property out of range" 352 | Consts_SMenuIndexError, "Menu index out of range" 353 | RTLConsts_SSeekNotImplemented, "%s.Seek not implemented" 354 | RTLConsts_SSortedListError, "Operation not allowed on sorted list" 355 | RTLConsts_SUnknownGroup, "%s not in a class registration group" 356 | RTLConsts_SUnknownProperty, "Property %s does not exist" 357 | RTLConsts_SWriteError, "Stream write error" 358 | HelpIntfs_hNoTableOfContents, "Unable to find a Table of Contents" 359 | HelpIntfs_hNothingFound, "No help found for %s" 360 | HelpIntfs_hNoContext, "No context-sensitive help installed" 361 | HelpIntfs_hNoContextFound, "No help found for context" 362 | HelpIntfs_hNoTopics, "No topic-based help system installed" 363 | Consts_SInvalidBitmap, "Bitmap image is not valid" 364 | Consts_SInvalidIcon, "Icon image is not valid" 365 | Consts_SInvalidMetafile, "Metafile is not valid" 366 | Consts_SChangeIconSize, "Cannot change the size of an icon" 367 | Consts_SUnknownClipboardFormat, "Unsupported clipboard format" 368 | Consts_SOutOfResources, "Out of system resources" 369 | RTLConsts_SInvalidName, "''%s'' is not a valid component name" 370 | RTLConsts_SInvalidProperty, "Invalid property value" 371 | RTLConsts_SInvalidPropertyPath, "Invalid property path" 372 | RTLConsts_SInvalidPropertyValue, "Invalid property value" 373 | RTLConsts_SInvalidRegType, "Invalid data type for '%s'" 374 | RTLConsts_SListCapacityError, "List capacity out of bounds (%d)" 375 | RTLConsts_SListCountError, "List count out of bounds (%d)" 376 | RTLConsts_SListIndexError, "List index out of bounds (%d)" 377 | RTLConsts_SMemoryStreamError, "Out of memory while expanding memory stream" 378 | RTLConsts_SPropertyException, "Error reading %s%s%s: %s" 379 | RTLConsts_SReadError, "Stream read error" 380 | RTLConsts_SReadOnlyProperty, "Property is read-only" 381 | RTLConsts_SRegCreateFailed, "Failed to create key %s" 382 | RTLConsts_SRegGetDataFailed, "Failed to get data for '%s'" 383 | RTLConsts_SRegSetDataFailed, "Failed to set data for '%s'" 384 | RTLConsts_SResNotFound, "Resource %s not found" 385 | SysConst_SLongDayNameFri, "Friday" 386 | SysConst_SLongDayNameSat, "Saturday" 387 | RTLConsts_SAncestorNotFound, "Ancestor for '%s' not found" 388 | RTLConsts_SAssignError, "Cannot assign a %s to a %s" 389 | RTLConsts_SBitsIndexError, "Bits index out of range" 390 | RTLConsts_SCantWriteResourceStreamError, "Can't write to a read-only resource stream" 391 | RTLConsts_SCheckSynchronizeError, "CheckSynchronize called from thread $%x, which is NOT the main thread" 392 | RTLConsts_SClassNotFound, "Class %s not found" 393 | RTLConsts_SDuplicateClass, "A class named %s already exists" 394 | RTLConsts_SDuplicateItem, "List does not allow duplicates ($0%x)" 395 | RTLConsts_SDuplicateName, "A component named %s already exists" 396 | RTLConsts_SDuplicateString, "String list does not allow duplicates" 397 | RTLConsts_SFCreateErrorEx, "Cannot create file \"%s\". %s" 398 | RTLConsts_SFOpenErrorEx, "Cannot open file \"%s\". %s" 399 | RTLConsts_SIniFileWriteError, "Unable to write to %s" 400 | RTLConsts_SInvalidImage, "Invalid stream format" 401 | SysConst_SLongMonthNameSep, "September" 402 | SysConst_SLongMonthNameOct, "October" 403 | SysConst_SLongMonthNameNov, "November" 404 | SysConst_SLongMonthNameDec, "December" 405 | SysConst_SShortDayNameSun, "Sun" 406 | SysConst_SShortDayNameMon, "Mon" 407 | SysConst_SShortDayNameTue, "Tue" 408 | SysConst_SShortDayNameWed, "Wed" 409 | SysConst_SShortDayNameThu, "Thu" 410 | SysConst_SShortDayNameFri, "Fri" 411 | SysConst_SShortDayNameSat, "Sat" 412 | SysConst_SLongDayNameSun, "Sunday" 413 | SysConst_SLongDayNameMon, "Monday" 414 | SysConst_SLongDayNameTue, "Tuesday" 415 | SysConst_SLongDayNameWed, "Wednesday" 416 | SysConst_SLongDayNameThu, "Thursday" 417 | SysConst_SShortMonthNameMay, "May" 418 | SysConst_SShortMonthNameJun, "Jun" 419 | SysConst_SShortMonthNameJul, "Jul" 420 | SysConst_SShortMonthNameAug, "Aug" 421 | SysConst_SShortMonthNameSep, "Sep" 422 | SysConst_SShortMonthNameOct, "Oct" 423 | SysConst_SShortMonthNameNov, "Nov" 424 | SysConst_SShortMonthNameDec, "Dec" 425 | SysConst_SLongMonthNameJan, "January" 426 | SysConst_SLongMonthNameFeb, "February" 427 | SysConst_SLongMonthNameMar, "March" 428 | SysConst_SLongMonthNameApr, "April" 429 | SysConst_SLongMonthNameMay, "May" 430 | SysConst_SLongMonthNameJun, "June" 431 | SysConst_SLongMonthNameJul, "July" 432 | SysConst_SLongMonthNameAug, "August" 433 | SysConst_SVarBadType, "Invalid variant type" 434 | SysConst_SVarNotImplemented, "Operation not supported" 435 | SysConst_SVarUnexpected, "Unexpected variant error" 436 | SysConst_SExternalException, "External exception %x" 437 | SysConst_SAssertionFailed, "Assertion failed" 438 | SysConst_SIntfCastError, "Interface not supported" 439 | SysConst_SSafecallException, "Exception in safecall method" 440 | SysConst_SAssertError, "%s (%s, line %d)" 441 | SysConst_SAbstractError, "Abstract Error" 442 | SysConst_SModuleAccessViolation, "Access violation at address %p in module '%s'. %s of address %p" 443 | SysConst_SOSError, "System Error. Code: %d.\r\n%s" 444 | SysConst_SUnkOSError, "A call to an OS function failed" 445 | SysConst_SShortMonthNameJan, "Jan" 446 | SysConst_SShortMonthNameFeb, "Feb" 447 | SysConst_SShortMonthNameMar, "Mar" 448 | SysConst_SShortMonthNameApr, "Apr" 449 | SysConst_SInvalidFormat, "Format '%s' invalid or incompatible with argument" 450 | SysConst_SArgumentMissing, "No argument for format '%s'" 451 | SysConst_SDispatchError, "Variant method calls not supported" 452 | SysConst_SReadAccess, "Read" 453 | SysConst_SWriteAccess, "Write" 454 | SysConst_SVarArrayCreate, "Error creating variant or safe array" 455 | SysConst_SVarArrayBounds, "Variant or safe array index out of bounds" 456 | SysConst_SVarArrayLocked, "Variant or safe array is locked" 457 | SysConst_SInvalidVarCast, "Invalid variant type conversion" 458 | SysConst_SInvalidVarOp, "Invalid variant operation" 459 | SysConst_SInvalidVarNullOp, "Invalid NULL variant operation" 460 | SysConst_SInvalidVarOpWithHResultWithPrefix, "Invalid variant operation (%s%.8x)\n%s" 461 | SysConst_SVarTypeCouldNotConvert, "Could not convert variant of type (%s) into type (%s)" 462 | SysConst_SVarTypeConvertOverflow, "Overflow while converting variant of type (%s) into type (%s)" 463 | SysConst_SVarOverflow, "Variant overflow" 464 | SysConst_SVarInvalid, "Invalid argument" 465 | SysConst_SDivByZero, "Division by zero" 466 | SysConst_SRangeError, "Range check error" 467 | SysConst_SIntOverflow, "Integer overflow" 468 | SysConst_SInvalidOp, "Invalid floating point operation" 469 | SysConst_SZeroDivide, "Floating point division by zero" 470 | SysConst_SOverflow, "Floating point overflow" 471 | SysConst_SUnderflow, "Floating point underflow" 472 | SysConst_SInvalidPointer, "Invalid pointer operation" 473 | SysConst_SInvalidCast, "Invalid class typecast" 474 | SysConst_SAccessViolationArg3, "Access violation at address %p. %s of address %p" 475 | SysConst_SAccessViolationNoArg, "Access violation" 476 | SysConst_SStackOverflow, "Stack overflow" 477 | SysConst_SControlC, "Control-C hit" 478 | SysConst_SPrivilege, "Privileged instruction" 479 | SysConst_SException, "Exception %s in module %s at %p.\r\n%s%s\r\n" 480 | SysConst_SExceptTitle, "Application Error" 481 | SysConst_SInvalidInteger, "'%s' is not a valid integer value" 482 | SysConst_SInvalidFloat, "'%s' is not a valid floating point value" 483 | SysConst_SInvalidDate, "'%s' is not a valid date" 484 | SysConst_SInvalidTime, "'%s' is not a valid time" 485 | SysConst_SInvalidDateTime, "'%s' is not a valid date and time" 486 | SysConst_STimeEncodeError, "Invalid argument to time encode" 487 | SysConst_SDateEncodeError, "Invalid argument to date encode" 488 | SysConst_SOutOfMemory, "Out of memory" 489 | SysConst_SInOutError, "I/O error %d" 490 | SysConst_SFileNotFound, "File not found" 491 | SysConst_SInvalidFilename, "Invalid filename" 492 | SysConst_STooManyOpenFiles, "Too many open files" 493 | SysConst_SAccessDenied, "File access denied" 494 | SysConst_SEndOfFile, "Read beyond end of file" 495 | SysConst_SDiskFull, "Disk full" 496 | SysConst_SInvalidInput, "Invalid numeric input" 497 | END 498 | 499 | /* d:\soft\programming\delphi\lib\Controls.res */ 500 | /* d:\soft\programming\delphi\lib\Buttons.res */ 501 | /* d:\soft\programming\delphi\lib\ExtDlgs.res */ 502 | /* d:\soft\programming\delphi\lib\GUITestRunner.DFM */ 503 | /* D:\Soft\Programming\Delphi\source\SRC\Vfs\VfsTest.drf */ 504 | -------------------------------------------------------------------------------- /VfsUtils.pas: -------------------------------------------------------------------------------- 1 | unit VfsUtils; 2 | (* 3 | 4 | *) 5 | 6 | 7 | (***) interface (***) 8 | 9 | uses 10 | SysUtils, Math, Windows, 11 | Utils, WinNative, Alg, TypeWrappers, 12 | Lists, DataLib, StrLib, 13 | VfsMatching; 14 | 15 | type 16 | (* Import *) 17 | TDict = DataLib.TDict; 18 | TObjDict = DataLib.TObjDict; 19 | TString = TypeWrappers.TString; 20 | TList = Lists.TList; 21 | 22 | const 23 | MAX_FILENAME_SIZE = WinNative.MAX_FILENAME_LEN * sizeof(WideChar); 24 | DRIVE_CHAR_INDEX_IN_NT_ABS_PATH = 5; // \??\D: 25 | 26 | type 27 | TSysOpenFileMode = (OPEN_AS_ANY = 0, OPEN_AS_FILE = WinNative.FILE_NON_DIRECTORY_FILE, OPEN_AS_DIR = WinNative.FILE_DIRECTORY_FILE); 28 | 29 | (* WINNT widest file structre wrapper *) 30 | PNativeFileInfo = ^TNativeFileInfo; 31 | TNativeFileInfo = record 32 | Base: WinNative.FILE_ID_BOTH_DIR_INFORMATION; 33 | FileName: WideString; 34 | 35 | procedure SetFileName (const NewFileName: WideString); 36 | function CopyFileNameToBuf ({ni} Buf: pbyte; BufSize: integer): boolean; 37 | function GetFileSize: Int64; 38 | end; 39 | 40 | (* TNativeFileInfo wrapper for dynamical data structures with memory manamement *) 41 | TFileInfo = class 42 | public 43 | Data: TNativeFileInfo; 44 | 45 | constructor Create ({n} Data: PNativeFileInfo = nil); 46 | end; 47 | 48 | (* Universal directory listing holder *) 49 | TDirListing = class 50 | private 51 | {O} fFileList: {O} DataLib.TList {OF TFileInfo}; 52 | fFileInd: integer; 53 | 54 | function GetCount: integer; 55 | 56 | public 57 | constructor Create; 58 | destructor Destroy; override; 59 | 60 | function IsEnd: boolean; 61 | procedure AddItem ({U} FileInfo: PNativeFileInfo; const FileName: WideString = ''; const InsertBefore: integer = High(integer)); 62 | function GetNextItem ({OUT} var {U} Res: TFileInfo): boolean; 63 | procedure Rewind; 64 | procedure Clear; 65 | 66 | (* Always seeks as close as possible *) 67 | function Seek (SeekInd: integer): boolean; 68 | function SeekRel (RelInd: integer): boolean; 69 | 70 | function GetDebugDump: string; 71 | 72 | property FileInd: integer read fFileInd; 73 | property Count: integer read GetCount; 74 | end; // .class TDirListing 75 | 76 | ISysDirScanner = interface 77 | function IterNext ({OUT} var FileName: WideString; {n} FileInfo: WinNative.PFILE_ID_BOTH_DIR_INFORMATION = nil): boolean; 78 | end; 79 | 80 | TSysDirScanner = class (Utils.TManagedObject, ISysDirScanner) 81 | protected const 82 | BUF_SIZE = 65000; 83 | 84 | protected 85 | fOwnsDirHandle: boolean; 86 | fDirHandle: Windows.THandle; 87 | fMask: WideString; 88 | fMaskU: WinNative.UNICODE_STRING; 89 | fIsStart: boolean; 90 | fIsEnd: boolean; 91 | fBufPos: integer; 92 | fBuf: array [0..BUF_SIZE - 1] of byte; 93 | 94 | public 95 | constructor Create (const hDir: Windows.THandle; const Mask: WideString); overload; 96 | constructor Create (const DirPath, Mask: WideString); overload; 97 | destructor Destroy; override; 98 | 99 | function IterNext ({OUT} var FileName: WideString; {n} FileInfo: WinNative.PFILE_ID_BOTH_DIR_INFORMATION = nil): boolean; 100 | end; // .class TSysDirScanner 101 | 102 | 103 | (* Packs lower cased WideString bytes into AnsiString buffer *) 104 | function WideStrToCaselessKey (const Str: WideString): string; 105 | 106 | (* The opposite of WideStrToKey *) 107 | function CaselessKeyToWideStr (const CaselessKey: string): WideString; 108 | 109 | (* Returns expanded unicode path, preserving trailing delimiter, or original path on error *) 110 | function ExpandPath (const Path: WideString): WideString; 111 | 112 | (* Returns path without trailing delimiter (for non-drives). Optionally returns flag, whether path had trailing delim or not. 113 | The flag is false for drives *) 114 | function NormalizeAbsPath (const Path: WideString; {n} HadTrailingDelim: pboolean = nil): WideString; 115 | 116 | (* Returns expanded path without trailing delimiter (for non-drives). Optionally returns flag, whether path had trailing delim or not. 117 | The flag is false for drives *) 118 | function NormalizePath (const Path: WideString; {n} HadTrailingDelim: pboolean = nil): WideString; 119 | 120 | (* Returns absolute normalized path with nt path prefix '\??\' (unless path already begins with '\' character). 121 | Optionally returns flag, whether path had trailing delim or not. *) 122 | function ToNtAbsPath (const Path: WideString; {n} HadTrailingDelim: pboolean = nil): WideString; 123 | 124 | (* Return true if path is valid absolute path to root drive like 'X:' with any/zero number of trailing slashes *) 125 | function IsRootDriveAbsPath (const Path: WideString): boolean; 126 | 127 | (* Return true if path is valid absolute NT path to root drive like '\??\X:' with any/zero number of trailing slashes *) 128 | function IsNtRootDriveAbsPath (const Path: WideString): boolean; 129 | 130 | (* Adds backslash to path end, unless there is already existing one *) 131 | function AddBackslash (const Path: WideString): WideString; 132 | 133 | (* Joins multiple path parts into single path. Backslashes are trimmed from each part and finally empty parts are ignored. 134 | Each part must be valid path part like '\DirName\\\' or 'C:' *) 135 | function MakePath (const Parts: array of WideString): WideString; 136 | 137 | (* Removes optional leading \??\ prefix from path *) 138 | function StripNtAbsPathPrefix (const Path: WideString): WideString; 139 | 140 | (* Saves API result in external variable and returns result as is *) 141 | function SaveAndRet (Res: integer; out ResCopy): integer; 142 | 143 | (* Returns attributes for file at given path *) 144 | function GetFileAttrs (const Path: WideString; {out} var Attrs: integer): boolean; 145 | 146 | (* Returns true if directory with given path exists *) 147 | function IsDir (const Path: WideString): boolean; 148 | 149 | (* Opens file/directory using absolute NT path and returns success flag *) 150 | function SysOpenFile (const NtAbsPath: WideString; {OUT} var Res: Windows.THandle; const OpenMode: TSysOpenFileMode = OPEN_AS_ANY; const AccessMode: ACCESS_MASK = FILE_GENERIC_READ): boolean; 151 | 152 | (* Returns TNativeFileInfo record for single file/directory. Short names and files indexes/ids in the result are always empty. *) 153 | function GetFileInfo (const FilePath: WideString; {OUT} var Res: TNativeFileInfo): boolean; 154 | 155 | function SysScanDir (const hDir: Windows.THandle; const Mask: WideString): ISysDirScanner; overload; 156 | function SysScanDir (const DirPath, Mask: WideString): ISysDirScanner; overload; 157 | 158 | (* Scans specified directory and adds sorted entries to directory listing. Optionally exclude names from Exclude dictionary. 159 | Excluded items must be preprocessed via WideStringToCaselessKey routine. 160 | Applies filtering by mask to fix possible invalid native functions behavior, found at least on Win XP when 161 | tests were run on network drive *) 162 | procedure GetDirectoryListing (const SearchPath, FileMask: WideString; {Un} Exclude: TDict {OF CaselessKey => not NIL}; DirListing: TDirListing); 163 | 164 | 165 | (***) implementation (***) 166 | 167 | 168 | type 169 | TDirListingItem = class 170 | SearchName: WideString; 171 | Info: TNativeFileInfo; 172 | end; 173 | 174 | 175 | function WideStrToCaselessKey (const Str: WideString): string; 176 | var 177 | ProcessedPath: WideString; 178 | 179 | begin 180 | result := ''; 181 | 182 | if Str <> '' then begin 183 | ProcessedPath := StrLib.WideLowerCase(Str); 184 | SetLength(result, Length(ProcessedPath) * sizeof(ProcessedPath[1]) div sizeof(result[1])); 185 | Utils.CopyMem(Length(result) * sizeof(result[1]), PWideChar(ProcessedPath), PChar(result)); 186 | end; 187 | end; 188 | 189 | function CaselessKeyToWideStr (const CaselessKey: string): WideString; 190 | begin 191 | result := ''; 192 | 193 | if CaselessKey <> '' then begin 194 | SetLength(result, Length(CaselessKey) * sizeof(CaselessKey[1]) div sizeof(result[1])); 195 | Utils.CopyMem(Length(result) * sizeof(result[1]), pchar(CaselessKey), PWideChar(result)); 196 | end; 197 | end; 198 | 199 | function ExpandPath (const Path: WideString): WideString; 200 | var 201 | BufLen: integer; 202 | NumCharsCopied: integer; 203 | FileNameAddr: PWideChar; 204 | 205 | begin 206 | result := ''; 207 | 208 | if Path <> '' then begin 209 | BufLen := 0; 210 | NumCharsCopied := Windows.GetFullPathNameW(PWideChar(Path), 0, nil, FileNameAddr); 211 | 212 | while NumCharsCopied > BufLen do begin 213 | BufLen := NumCharsCopied; 214 | SetLength(result, BufLen - 1); 215 | NumCharsCopied := Windows.GetFullPathNameW(PWideChar(Path), BufLen, PWideChar(result), FileNameAddr); 216 | end; 217 | 218 | if NumCharsCopied <= 0 then begin 219 | result := Path; 220 | end else begin 221 | SetLength(result, NumCharsCopied); 222 | end; 223 | end; // .if 224 | end; // .function ExpandPath 225 | 226 | function NormalizeAbsPath (const Path: WideString; {n} HadTrailingDelim: pboolean = nil): WideString; 227 | begin 228 | result := StrLib.ExcludeTrailingBackslashW(Path, HadTrailingDelim); 229 | 230 | if (Length(result) = 2) and (result[2] = ':') then begin 231 | result := result + '\'; 232 | 233 | if HadTrailingDelim <> nil then begin 234 | HadTrailingDelim^ := false; 235 | end; 236 | end; 237 | end; 238 | 239 | function NormalizePath (const Path: WideString; {n} HadTrailingDelim: pboolean = nil): WideString; 240 | begin 241 | result := NormalizeAbsPath(ExpandPath(Path), HadTrailingDelim); 242 | end; 243 | 244 | function ToNtAbsPath (const Path: WideString; {n} HadTrailingDelim: pboolean = nil): WideString; 245 | begin 246 | result := NormalizePath(Path, HadTrailingDelim); 247 | 248 | if (result <> '') and (result[1] <> '\') then begin 249 | result := '\??\' + result; 250 | end; 251 | end; 252 | 253 | function IsRootDriveAbsPath (const Path: WideString): boolean; 254 | const 255 | MIN_VALID_LEN = Length('X:'); 256 | 257 | var 258 | i: integer; 259 | 260 | begin 261 | result := (Length(Path) >= MIN_VALID_LEN) and (ord(Path[1]) < 256) and (char(Path[1]) in ['A'..'Z']) and (Path[2] = ':'); 262 | 263 | if result then begin 264 | for i := MIN_VALID_LEN + 1 to Length(Path) do begin 265 | if Path[i] <> '\' then begin 266 | result := false; 267 | exit; 268 | end; 269 | end; 270 | end; 271 | end; // .function IsRootDriveAbsPath 272 | 273 | function IsNtRootDriveAbsPath (const Path: WideString): boolean; 274 | const 275 | MIN_VALID_LEN = Length('\??\X:'); 276 | 277 | var 278 | i: integer; 279 | 280 | begin 281 | result := (Length(Path) >= MIN_VALID_LEN) and (Path[1] = '\') and (Path[2] = '?') and (Path[3] = '?') and (Path[4] = '\') and (ord(Path[5]) < 256) and (char(Path[5]) in ['A'..'Z']) and (Path[6] = ':'); 282 | 283 | if result then begin 284 | for i := MIN_VALID_LEN + 1 to Length(Path) do begin 285 | if Path[i] <> '\' then begin 286 | result := false; 287 | exit; 288 | end; 289 | end; 290 | end; 291 | end; // .function IsNtRootDriveAbsPath 292 | 293 | function StripNtAbsPathPrefix (const Path: WideString): WideString; 294 | begin 295 | result := Path; 296 | 297 | if (Length(Path) >= 4) and (Path[1] = '\') and (Path[2] = '?') and (Path[3] = '?') and (Path[4] = '\') then begin 298 | result := Copy(Path, 4 + 1); 299 | end; 300 | end; 301 | 302 | function AddBackslash (const Path: WideString): WideString; 303 | begin 304 | if (Path = '') or (Path[Length(Path)] <> '\') then begin 305 | result := Path + '\'; 306 | end else begin 307 | result := Path; 308 | end; 309 | end; 310 | 311 | function MakePath (const Parts: array of WideString): WideString; 312 | var 313 | {n} CurrChar: PWideChar; 314 | Part: WideString; 315 | PartLen: integer; 316 | ResLen: integer; 317 | i: integer; 318 | 319 | begin 320 | CurrChar := nil; 321 | // * * * * * // 322 | ResLen := 0; 323 | 324 | // Calculate estimated final string length, assume extra '\' for each non-empty part 325 | for i := 0 to High(Parts) do begin 326 | if Parts[i] <> '' then begin 327 | Inc(ResLen, Length(Parts[i]) + 1); 328 | end; 329 | end; 330 | 331 | SetLength(result, ResLen); 332 | CurrChar := PWideChar(result); 333 | 334 | for i := 0 to High(Parts) do begin 335 | PartLen := Length(Parts[i]); 336 | 337 | if PartLen > 0 then begin 338 | Part := StrLib.TrimBackslashesW(Parts[i]); 339 | 340 | if Part <> '' then begin 341 | // Add '\' glue for non-first part 342 | if i = 0 then begin 343 | Dec(ResLen); 344 | end else begin 345 | CurrChar^ := '\'; 346 | Inc(CurrChar); 347 | end; 348 | 349 | Dec(ResLen, PartLen - Length(Part)); 350 | PartLen := Length(Part); 351 | 352 | Utils.CopyMem(PartLen * sizeof(WideChar), PWideChar(Part), CurrChar); 353 | Inc(CurrChar, PartLen); 354 | end else begin 355 | Dec(ResLen, PartLen + 1); 356 | end; 357 | end; 358 | end; // .for 359 | 360 | // Trim garbage at final string end 361 | SetLength(result, ResLen); 362 | end; // .function MakePath 363 | 364 | function SaveAndRet (Res: integer; out ResCopy): integer; 365 | begin 366 | integer(ResCopy) := Res; 367 | result := Res; 368 | end; 369 | 370 | procedure TNativeFileInfo.SetFileName (const NewFileName: WideString); 371 | begin 372 | Self.FileName := NewFileName; 373 | Self.Base.FileNameLength := Length(NewFileName) * sizeof(WideChar); 374 | end; 375 | 376 | function TNativeFileInfo.CopyFileNameToBuf ({ni} Buf: pbyte; BufSize: integer): boolean; 377 | begin 378 | {!} Assert(Utils.IsValidBuf(Buf, BufSize)); 379 | result := integer(Self.Base.FileNameLength) <= BufSize; 380 | 381 | if BufSize > 0 then begin 382 | Utils.CopyMem(Self.Base.FileNameLength, PWideChar(Self.FileName), Buf); 383 | end; 384 | end; 385 | 386 | function TNativeFileInfo.GetFileSize: Int64; 387 | begin 388 | result := Self.Base.EndOfFile.QuadPart; 389 | end; 390 | 391 | constructor TFileInfo.Create ({n} Data: PNativeFileInfo = nil); 392 | begin 393 | if Data <> nil then begin 394 | Self.Data := Data^; 395 | end; 396 | end; 397 | 398 | constructor TDirListing.Create; 399 | begin 400 | Self.fFileList := DataLib.NewList(Utils.OWNS_ITEMS); 401 | Self.fFileInd := 0; 402 | end; 403 | 404 | destructor TDirListing.Destroy; 405 | begin 406 | SysUtils.FreeAndNil(Self.fFileList); 407 | end; 408 | 409 | procedure TDirListing.AddItem (FileInfo: PNativeFileInfo; const FileName: WideString = ''; const InsertBefore: integer = High(integer)); 410 | var 411 | {O} Item: TFileInfo; 412 | 413 | begin 414 | {!} Assert(FileInfo <> nil); 415 | // * * * * * // 416 | Item := TFileInfo.Create(FileInfo); 417 | 418 | if FileName <> '' then begin 419 | Item.Data.SetFileName(FileName); 420 | end; 421 | 422 | if InsertBefore >= Self.fFileList.Count then begin 423 | Self.fFileList.Add(Item); Item := nil; 424 | end else begin 425 | Self.fFileList.Insert(Item, InsertBefore); Item := nil; 426 | end; 427 | // * * * * * // 428 | SysUtils.FreeAndNil(Item); 429 | end; // .procedure TDirListing.AddItem 430 | 431 | function TDirListing.GetCount: integer; 432 | begin 433 | result := Self.fFileList.Count; 434 | end; 435 | 436 | function TDirListing.IsEnd: boolean; 437 | begin 438 | result := Self.fFileInd >= Self.fFileList.Count; 439 | end; 440 | 441 | function TDirListing.GetNextItem ({OUT} var Res: TFileInfo): boolean; 442 | begin 443 | result := Self.fFileInd < Self.fFileList.Count; 444 | 445 | if result then begin 446 | Res := TFileInfo(Self.fFileList[Self.fFileInd]); 447 | Inc(Self.fFileInd); 448 | end; 449 | end; 450 | 451 | procedure TDirListing.Rewind; 452 | begin 453 | Self.fFileInd := 0; 454 | end; 455 | 456 | procedure TDirListing.Clear; 457 | begin 458 | Self.fFileList.Clear; 459 | Self.fFileInd := 0; 460 | end; 461 | 462 | function TDirListing.Seek (SeekInd: integer): boolean; 463 | begin 464 | Self.fFileInd := Alg.ToRange(SeekInd, 0, Self.fFileList.Count - 1); 465 | result := Self.fFileInd = SeekInd; 466 | end; 467 | 468 | function TDirListing.SeekRel (RelInd: integer): boolean; 469 | begin 470 | result := Self.Seek(Self.fFileInd + RelInd); 471 | end; 472 | 473 | function TDirListing.GetDebugDump: string; 474 | var 475 | FileNames: Utils.TArrayOfStr; 476 | i: integer; 477 | 478 | begin 479 | SetLength(FileNames, Self.fFileList.Count); 480 | 481 | for i := 0 to Self.fFileList.Count - 1 do begin 482 | FileNames[i] := TFileInfo(Self.fFileList[i]).Data.FileName; 483 | end; 484 | 485 | result := StrLib.Join(FileNames, #13#10); 486 | end; 487 | 488 | function GetFileAttrs (const Path: WideString; {out} var Attrs: integer): boolean; 489 | const 490 | INVALID_FILE_ATTRIBUTES = -1; 491 | 492 | var 493 | Res: integer; 494 | 495 | begin 496 | Res := integer(Windows.GetFileAttributesW(PWideChar(Path))); 497 | result := Res <> INVALID_FILE_ATTRIBUTES; 498 | 499 | if result then begin 500 | Attrs := Res; 501 | end; 502 | end; 503 | 504 | function IsDir (const Path: WideString): boolean; 505 | var 506 | FileAttrs: integer; 507 | 508 | begin 509 | result := GetFileAttrs(Path, FileAttrs) and Utils.Flags(FileAttrs).Have(Windows.FILE_ATTRIBUTE_DIRECTORY); 510 | end; 511 | 512 | function SysOpenFile (const NtAbsPath: WideString; {OUT} var Res: Windows.THandle; const OpenMode: TSysOpenFileMode = OPEN_AS_ANY; const AccessMode: ACCESS_MASK = FILE_GENERIC_READ): boolean; 513 | var 514 | FilePathU: WinNative.UNICODE_STRING; 515 | hFile: Windows.THandle; 516 | ObjAttrs: WinNative.OBJECT_ATTRIBUTES; 517 | IoStatusBlock: WinNative.IO_STATUS_BLOCK; 518 | 519 | begin 520 | FilePathU.AssignExistingStr(NtAbsPath); 521 | ObjAttrs.Init(@FilePathU); 522 | 523 | 524 | result := WinNative.NtOpenFile(@hFile, AccessMode, @ObjAttrs, @IoStatusBlock, FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE, 525 | ord(OpenMode) or FILE_SYNCHRONOUS_IO_NONALERT or FILE_OPEN_FOR_BACKUP_INTENT) = WinNative.STATUS_SUCCESS; 526 | 527 | if result then begin 528 | Res := hFile; 529 | end; 530 | end; // .function SysOpenFile 531 | 532 | function GetFileInfo (const FilePath: WideString; {OUT} var Res: TNativeFileInfo): boolean; 533 | const 534 | BUF_SIZE = sizeof(WinNative.FILE_ALL_INFORMATION) + MAX_FILENAME_SIZE; 535 | 536 | var 537 | {U} FileAllInfo: WinNative.PFILE_ALL_INFORMATION; 538 | NtAbsPath: WideString; 539 | hFile: Windows.THandle; 540 | Buf: array [0..BUF_SIZE - 1] of byte; 541 | IoStatusBlock: WinNative.IO_STATUS_BLOCK; 542 | 543 | begin 544 | FileAllInfo := @Buf; 545 | // * * * * * // 546 | NtAbsPath := ToNtAbsPath(FilePath); 547 | result := SysOpenFile(NtAbsPath, hFile, OPEN_AS_ANY, STANDARD_RIGHTS_READ or FILE_READ_ATTRIBUTES or FILE_READ_EA or SYNCHRONIZE); 548 | 549 | if not result then begin 550 | exit; 551 | end; 552 | 553 | if IsNtRootDriveAbsPath(NtAbsPath) then begin 554 | // Return fake info for root drive 555 | result := GetFileAttrs(StripNtAbsPathPrefix(NtAbsPath), integer(FileAllInfo.BasicInformation.FileAttributes)); 556 | 557 | if result then begin 558 | FillChar(Res.Base, sizeof(Res.Base), 0); 559 | Res.Base.FileAttributes := FileAllInfo.BasicInformation.FileAttributes; 560 | Res.SetFileName(NtAbsPath[DRIVE_CHAR_INDEX_IN_NT_ABS_PATH] + WideString(':\'#0)); 561 | end; 562 | end else begin 563 | result := WinNative.NtQueryInformationFile(hFile, @IoStatusBlock, FileAllInfo, BUF_SIZE, ord(WinNative.FileAllInformation)) = WinNative.STATUS_SUCCESS; 564 | 565 | if result then begin 566 | Res.Base.FileIndex := 0; 567 | Res.Base.CreationTime := FileAllInfo.BasicInformation.CreationTime; 568 | Res.Base.LastAccessTime := FileAllInfo.BasicInformation.LastAccessTime; 569 | Res.Base.LastWriteTime := FileAllInfo.BasicInformation.LastWriteTime; 570 | Res.Base.ChangeTime := FileAllInfo.BasicInformation.ChangeTime; 571 | Res.Base.FileAttributes := FileAllInfo.BasicInformation.FileAttributes; 572 | Res.Base.EndOfFile := FileAllInfo.StandardInformation.EndOfFile; 573 | Res.Base.AllocationSize := FileAllInfo.StandardInformation.AllocationSize; 574 | Res.Base.EaSize := FileAllInfo.EaInformation.EaSize; 575 | Res.Base.ShortNameLength := 0; 576 | Res.Base.ShortName[0] := #0; 577 | Res.Base.FileNameLength := FileAllInfo.NameInformation.FileNameLength; 578 | Res.Base.FileId.LowPart := 0; 579 | Res.Base.FileId.HighPart := 0; 580 | 581 | Res.SetFileName(StrLib.ExtractFileNameW(StrLib.WideStringFromBuf( 582 | @FileAllInfo.NameInformation.FileName, 583 | Max(0, Min(integer(IoStatusBlock.Information) - sizeof(FileAllInfo^), FileAllInfo.NameInformation.FileNameLength)) div sizeof(WideChar) 584 | ))); 585 | end; // .if 586 | end; // .else 587 | 588 | WinNative.NtClose(hFile); 589 | end; // .function GetFileInfo 590 | 591 | constructor TSysDirScanner.Create (const hDir: Windows.THandle; const Mask: WideString); 592 | begin 593 | Self.fOwnsDirHandle := false; 594 | Self.fDirHandle := hDir; 595 | Self.fMask := StrLib.WideLowerCase(Mask); 596 | Self.fMaskU.AssignExistingStr(Self.fMask); 597 | Self.fIsStart := true; 598 | Self.fIsEnd := false; 599 | Self.fBufPos := 0; 600 | end; 601 | 602 | constructor TSysDirScanner.Create (const DirPath, Mask: WideString); 603 | var 604 | hDir: Windows.THandle; 605 | 606 | begin 607 | hDir := Windows.INVALID_HANDLE_VALUE; 608 | SysOpenFile(ToNtAbsPath(DirPath), hDir, OPEN_AS_DIR, FILE_LIST_DIRECTORY or SYNCHRONIZE); 609 | 610 | Self.Create(hDir, Mask); 611 | 612 | if hDir <> Windows.INVALID_HANDLE_VALUE then begin 613 | Self.fOwnsDirHandle := true; 614 | end else begin 615 | Self.fIsEnd := true; 616 | end; 617 | end; // .constructor TSysDirScanner.Create 618 | 619 | destructor TSysDirScanner.Destroy; 620 | begin 621 | if Self.fOwnsDirHandle then begin 622 | WinNative.NtClose(Self.fDirHandle); 623 | end; 624 | end; 625 | 626 | function TSysDirScanner.IterNext ({OUT} var FileName: WideString; {n} FileInfo: WinNative.PFILE_ID_BOTH_DIR_INFORMATION = nil): boolean; 627 | const 628 | MULTIPLE_ENTRIES = false; 629 | 630 | var 631 | {n} FileInfoInBuf: WinNative.PFILE_ID_BOTH_DIR_INFORMATION; 632 | IoStatusBlock: WinNative.IO_STATUS_BLOCK; 633 | FileNameLen: integer; 634 | Status: integer; 635 | 636 | begin 637 | FileInfoInBuf := nil; 638 | // * * * * * // 639 | result := not Self.fIsEnd and (Self.fDirHandle <> Windows.INVALID_HANDLE_VALUE); 640 | 641 | if not result then begin 642 | exit; 643 | end; 644 | 645 | if not Self.fIsStart and (Self.fBufPos < Self.BUF_SIZE) then begin 646 | FileInfoInBuf := @Self.fBuf[Self.fBufPos]; 647 | FileNameLen := Min(FileInfoInBuf.FileNameLength, Self.BUF_SIZE - Self.fBufPos) div sizeof(WideChar); 648 | FileName := StrLib.WideStringFromBuf(@FileInfoInBuf.FileName, FileNameLen); 649 | 650 | if FileInfo <> nil then begin 651 | FileInfo^ := FileInfoInBuf^; 652 | FileInfo.FileNameLength := FileNameLen * sizeof(WideChar); 653 | end; 654 | 655 | Self.fBufPos := Utils.IfThen(FileInfoInBuf.NextEntryOffset <> 0, Self.fBufPos + integer(FileInfoInBuf.NextEntryOffset), Self.BUF_SIZE); 656 | end else begin 657 | Self.fBufPos := 0; 658 | Status := WinNative.NtQueryDirectoryFile(Self.fDirHandle, 0, nil, nil, @IoStatusBlock, @Self.fBuf, Self.BUF_SIZE, ord(WinNative.FileIdBothDirectoryInformation), MULTIPLE_ENTRIES, @Self.fMaskU, Self.fIsStart); 659 | result := (Status = WinNative.STATUS_SUCCESS) and (integer(IoStatusBlock.Information) <> 0); 660 | Self.fIsStart := false; 661 | 662 | if result then begin 663 | result := Self.IterNext(FileName, FileInfo); 664 | end else begin 665 | Self.fIsEnd := true; 666 | end; 667 | end; // .else 668 | end; // .function TSysDirScanner.IterNext 669 | 670 | function SysScanDir (const hDir: Windows.THandle; const Mask: WideString): ISysDirScanner; overload; 671 | begin 672 | result := TSysDirScanner.Create(hDir, Mask); 673 | end; 674 | 675 | function SysScanDir (const DirPath, Mask: WideString): ISysDirScanner; overload; 676 | begin 677 | result := TSysDirScanner.Create(DirPath, Mask); 678 | end; 679 | 680 | function CompareFileItemsByNameAsc (Item1, Item2: integer): integer; 681 | begin 682 | result := StrLib.CompareBinStringsW(TDirListingItem(Item1).SearchName, TDirListingItem(Item2).SearchName); 683 | 684 | if result = 0 then begin 685 | result := StrLib.CompareBinStringsW(TDirListingItem(Item1).Info.FileName, TDirListingItem(Item2).Info.FileName); 686 | end; 687 | end; 688 | 689 | procedure SortDirListing ({U} List: TList {OF TDirListingItem}); 690 | begin 691 | List.CustomSort(CompareFileItemsByNameAsc); 692 | end; 693 | 694 | procedure GetDirectoryListing (const SearchPath, FileMask: WideString; {Un} Exclude: TDict {OF CaselessKey => not NIL}; DirListing: TDirListing); 695 | var 696 | {O} Items: {O} TList {OF TDirListingItem}; 697 | {O} Item: {O} TDirListingItem; 698 | i: integer; 699 | 700 | begin 701 | {!} Assert(DirListing <> nil); 702 | Items := DataLib.NewList(Utils.OWNS_ITEMS); 703 | Item := TDirListingItem.Create; 704 | // * * * * * // 705 | with VfsUtils.SysScanDir(SearchPath, FileMask) do begin 706 | while IterNext(Item.Info.FileName, @Item.Info.Base) do begin 707 | if (Exclude = nil) or (Exclude[WideStrToCaselessKey(Item.Info.FileName)] = nil) then begin 708 | Item.SearchName := StrLib.WideLowerCase(Item.Info.FileName); 709 | Items.Add(Item); Item := nil; 710 | Item := TDirListingItem.Create; 711 | end; 712 | end; 713 | end; 714 | 715 | SortDirListing(Items); 716 | 717 | for i := 0 to Items.Count - 1 do begin 718 | DirListing.AddItem(@TDirListingItem(Items[i]).Info); 719 | end; 720 | // * * * * * // 721 | SysUtils.FreeAndNil(Items); 722 | SysUtils.FreeAndNil(Item); 723 | end; // .procedure GetDirectoryListing 724 | 725 | end. -------------------------------------------------------------------------------- /VfsBase.pas: -------------------------------------------------------------------------------- 1 | unit VfsBase; 2 | (* 3 | Description: Implements in-memory virtual file system data storage. 4 | Author: Alexander Shostak (aka Berserker aka EtherniDee aka BerSoft) 5 | TODO: Use optimized hash-table storage for VfsItems instead of ansi-to-wide string keys in regular binary tree. 6 | *) 7 | 8 | 9 | (***) interface (***) 10 | 11 | uses 12 | SysUtils, Math, Windows, 13 | Utils, WinNative, Alg, Concur, TypeWrappers, Lists, DataLib, 14 | StrLib, 15 | VfsUtils, VfsMatching; 16 | 17 | type 18 | (* Import *) 19 | TDict = DataLib.TDict; 20 | TObjDict = DataLib.TObjDict; 21 | TString = TypeWrappers.TString; 22 | TList = Lists.TList; 23 | 24 | const 25 | OVERWRITE_EXISTING = true; 26 | DONT_OVERWRITE_EXISTING = false; 27 | 28 | AUTO_PRIORITY = MAXLONGINT div 2; 29 | INITIAL_OVERWRITING_PRIORITY = AUTO_PRIORITY + 1; 30 | INITIAL_ADDING_PRIORITY = AUTO_PRIORITY - 1; 31 | 32 | type 33 | (* 34 | Specifies the order, in which files from different mapped directories will be listed in virtual directory. 35 | Virtual directory sorting is performed by priorities firstly and lexicographically secondly. 36 | SORT_FIFO - Items of the first mapped directory will be listed before the second mapped directory items. 37 | SORT_LIFO - Items of The last mapped directory will be listed before all other mapped directory items. 38 | *) 39 | TDirListingSortType = (SORT_FIFO = 0, SORT_LIFO = 1); 40 | 41 | (* Single redirected VFS entry: file or directory *) 42 | TVfsItem = class 43 | private 44 | function GetName: WideString; inline; 45 | procedure SetName (const NewName: WideString); inline; 46 | 47 | public 48 | (* Name in lower case, used for wildcard mask matching *) 49 | SearchName: WideString; 50 | 51 | (* Absolute path to virtual file/folder location without trailing slash for non-drives *) 52 | VirtPath: WideString; 53 | 54 | (* Absolute path to real file/folder location without trailing slash for non-drives *) 55 | RealPath: WideString; 56 | 57 | (* The priority used in virtual directories sorting for listing *) 58 | Priority: integer; 59 | 60 | (* List of directory child items or nil *) 61 | {On} Children: {U} TList {OF TVfsItem}; 62 | 63 | (* Up to 32 special non-Windows attribute flags *) 64 | Attrs: integer; 65 | 66 | (* Full file info *) 67 | Info: TNativeFileInfo; 68 | 69 | function IsDir (): boolean; 70 | 71 | destructor Destroy; override; 72 | 73 | (* Name in original case. Automatically sets/converts SearchName, Info.FileName, Info.Base.FileNameLength *) 74 | property Name: WideString read GetName write SetName; 75 | end; // .class TVfsItem 76 | 77 | (* Allows to disable VFS temporarily for current thread only *) 78 | TThreadVfsDisabler = record 79 | PrevDisableVfsForThisThread: boolean; 80 | 81 | procedure DisableVfsForThread; 82 | procedure EnableVfsForThread; 83 | procedure RestoreVfsForThread; 84 | end; 85 | 86 | TSingleArgExternalFunc = function (Arg: pointer = nil): integer; stdcall; 87 | 88 | var 89 | (* Global VFS access synchronizer *) 90 | VfsCritSection: Concur.TCritSection; 91 | 92 | 93 | function GetThreadVfsDisabler: TThreadVfsDisabler; 94 | 95 | (* Runs VFS. Higher level API must install hooks in VfsCritSection protected area. 96 | Listing order is ignored if VFS is resumed from pause *) 97 | function RunVfs (DirListingOrder: TDirListingSortType): boolean; 98 | 99 | (* Temporarily pauses VFS, but does not reset existing mappings *) 100 | function PauseVfs: LONGBOOL; stdcall; 101 | 102 | (* Stops VFS and clears all mappings *) 103 | function ResetVfs: LONGBOOL; stdcall; 104 | 105 | (* If VFS is running or paused, pauses VFS, clears cache and fully reaplies all mappings in the same order and 106 | with the same arguments, as MapDir routines were called earlier. Restores VFS state afterwards *) 107 | function RefreshVfs: LONGBOOL; stdcall; 108 | 109 | (* Refreshes VFS item attributes info for given mapped file. File must exist to succeed *) 110 | function RefreshMappedFile (const FilePath: WideString): boolean; 111 | 112 | (* Returns true if VFS is active globally and for current thread *) 113 | function IsVfsActive: boolean; 114 | 115 | function EnterVfs: boolean; 116 | procedure LeaveVfs; 117 | function EnterVfsConfig: boolean; 118 | procedure LeaveVfsConfig; 119 | 120 | (* Returns real path for VFS item by its absolute virtual path or empty string. Optionally returns file info structure *) 121 | function GetVfsItemRealPath (const AbsVirtPath: WideString; {n} FileInfo: PNativeFileInfo = nil): WideString; 122 | 123 | (* Returns virtual directory info. Adds virtual entries to specified directory listing container *) 124 | function GetVfsDirInfo (const NormalizedVirtPath, Mask: WideString; {OUT} var DirInfo: TNativeFileInfo; DirListing: TDirListing): boolean; 125 | 126 | (* Maps real directory contents to virtual path. Target must exist for success *) 127 | function MapDir (const VirtPath, RealPath: WideString; OverwriteExisting: boolean; Flags: integer = 0): boolean; 128 | 129 | (* Calls specified function with a single argument and returns its result. VFS is disabled for current thread during function exection *) 130 | function CallWithoutVfs (Func: TSingleArgExternalFunc; Arg: pointer = nil): integer; stdcall; 131 | 132 | (* Returns text with all applied mappings, separated via #13#10. If ShortenPaths is true, common part 133 | of real and virtual paths is stripped *) 134 | function GetMappingsReport: WideString; 135 | 136 | (* Returns text with all applied mappings on per-file level, separated via #13#10. If ShortenPaths is true, common part 137 | of real and virtual paths is stripped *) 138 | function GetDetailedMappingsReport: WideString; 139 | 140 | 141 | (***) implementation (***) 142 | 143 | 144 | type 145 | (* Applied and remembered mapping. Used to refresh or report VFS *) 146 | TMapping = class 147 | Applied: LONGBOOL; 148 | AbsVirtPath: WideString; 149 | AbsRealPath: WideString; 150 | OverwriteExisting: LONGBOOL; 151 | Flags: integer; 152 | 153 | class function Make (Applied: boolean; const AbsVirtPath, AbsRealPath: WideString; OverwriteExisting: boolean; Flags: integer): TMapping; 154 | end; 155 | 156 | var 157 | (* 158 | Global map of case-insensitive normalized path to file/directory => corresponding TVfsItem. 159 | Access is controlled via critical section and global/thread switchers. 160 | Represents the whole cached virtual file system contents. 161 | *) 162 | {O} VfsItems: {O} TDict {of TVfsItem}; 163 | 164 | (* Map of real (mapped) file path => VFS item. Used to update VFS info whenever mapped files are changed *) 165 | {O} MappedFiles: {U} TDict {of TVfsItem}; 166 | 167 | (* List of all applied mappings *) 168 | {O} Mappings: {O} TList {of TMapping}; 169 | 170 | (* Global VFS state indicator. If false, all VFS search operations must fail *) 171 | VfsIsRunning: boolean = false; 172 | 173 | (* Directory listing ordering, chosen on first VFS run. Updated on any first run after reset *) 174 | VfsDirListingOrder: TDirListingSortType; 175 | 176 | (* If true, VFS file/directory hierarchy is built and no mapping is allowed untill full reset *) 177 | VfsTreeIsBuilt: boolean = false; 178 | 179 | (* Automatical VFS items priority management *) 180 | OverwritingPriority: integer = INITIAL_OVERWRITING_PRIORITY; 181 | AddingPriority: integer = INITIAL_ADDING_PRIORITY; 182 | 183 | // All threadvar variables are automatically zeroed during finalization, thus zero must be the safest default value 184 | threadvar 185 | DisableVfsForThisThread: boolean; 186 | 187 | 188 | function TVfsItem.IsDir: boolean; 189 | begin 190 | result := (Self.Info.Base.FileAttributes and Windows.FILE_ATTRIBUTE_DIRECTORY) <> 0; 191 | end; 192 | 193 | function TVfsItem.GetName: WideString; 194 | begin 195 | result := Self.Info.FileName; 196 | end; 197 | 198 | procedure TVfsItem.SetName (const NewName: WideString); 199 | begin 200 | Self.Info.SetFileName(NewName); 201 | Self.SearchName := StrLib.WideLowerCase(NewName); 202 | end; 203 | 204 | destructor TVfsItem.Destroy; 205 | begin 206 | SysUtils.FreeAndNil(Self.Children); 207 | end; 208 | 209 | procedure TThreadVfsDisabler.DisableVfsForThread; 210 | begin 211 | Self.PrevDisableVfsForThisThread := DisableVfsForThisThread; 212 | DisableVfsForThisThread := true; 213 | end; 214 | 215 | procedure TThreadVfsDisabler.EnableVfsForThread; 216 | begin 217 | Self.PrevDisableVfsForThisThread := DisableVfsForThisThread; 218 | DisableVfsForThisThread := false; 219 | end; 220 | 221 | procedure TThreadVfsDisabler.RestoreVfsForThread; 222 | begin 223 | DisableVfsForThisThread := Self.PrevDisableVfsForThisThread; 224 | end; 225 | 226 | function GetThreadVfsDisabler: TThreadVfsDisabler; 227 | begin 228 | end; 229 | 230 | function EnterVfs: boolean; 231 | begin 232 | result := not DisableVfsForThisThread; 233 | 234 | if result then begin 235 | VfsCritSection.Enter; 236 | result := VfsIsRunning; 237 | 238 | if not result then begin 239 | VfsCritSection.Leave; 240 | end; 241 | end; 242 | end; 243 | 244 | procedure LeaveVfs; 245 | begin 246 | VfsCritSection.Leave; 247 | end; 248 | 249 | function EnterVfsConfig: boolean; 250 | begin 251 | VfsCritSection.Enter; 252 | result := not VfsIsRunning and not VfsTreeIsBuilt; 253 | 254 | if not result then begin 255 | VfsCritSection.Leave; 256 | end; 257 | end; 258 | 259 | procedure LeaveVfsConfig; 260 | begin 261 | VfsCritSection.Leave; 262 | end; 263 | 264 | function CompareVfsItemsByPriorityDescAndNameAsc (Item1, Item2: integer): integer; 265 | begin 266 | result := TVfsItem(Item2).Priority - TVfsItem(Item1).Priority; 267 | 268 | if result = 0 then begin 269 | result := StrLib.CompareBinStringsW(TVfsItem(Item1).SearchName, TVfsItem(Item2).SearchName); 270 | end; 271 | end; 272 | 273 | function CompareVfsItemsByPriorityAscAndNameAsc (Item1, Item2: integer): integer; 274 | begin 275 | result := TVfsItem(Item1).Priority - TVfsItem(Item2).Priority; 276 | 277 | if result = 0 then begin 278 | result := StrLib.CompareBinStringsW(TVfsItem(Item1).SearchName, TVfsItem(Item2).SearchName); 279 | end; 280 | end; 281 | 282 | procedure SortVfsListing ({U} List: DataLib.TList {OF TVfsItem}; SortType: TDirListingSortType); 283 | begin 284 | if SortType = SORT_FIFO then begin 285 | List.CustomSort(CompareVfsItemsByPriorityDescAndNameAsc); 286 | end else begin 287 | List.CustomSort(CompareVfsItemsByPriorityAscAndNameAsc); 288 | end; 289 | end; 290 | 291 | procedure SortVfsDirListings (SortType: TDirListingSortType); 292 | var 293 | {Un} Children: DataLib.TList {OF TVfsItem}; 294 | 295 | begin 296 | Children := nil; 297 | // * * * * * // 298 | with DataLib.IterateDict(VfsItems) do begin 299 | while IterNext() do begin 300 | Children := TVfsItem(IterValue).Children; 301 | 302 | if (Children <> nil) and (Children.Count > 1) then begin 303 | SortVfsListing(Children, SortType); 304 | end; 305 | end; 306 | end; 307 | end; // .procedure SortVfsDirListings 308 | 309 | function FindVfsItemByNormalizedPath (const Path: WideString; {U} var {OUT} Res: TVfsItem): boolean; 310 | var 311 | {Un} VfsItem: TVfsItem; 312 | 313 | begin 314 | VfsItem := VfsItems[WideStrToCaselessKey(Path)]; 315 | result := VfsItem <> nil; 316 | 317 | if result then begin 318 | Res := VfsItem; 319 | end; 320 | end; 321 | 322 | function FindVfsItemByPath (const Path: WideString; {U} var {OUT} Res: TVfsItem): boolean; 323 | begin 324 | result := FindVfsItemByNormalizedPath(NormalizePath(Path), Res); 325 | end; 326 | 327 | (* All children list of VFS items MUST be empty *) 328 | procedure BuildVfsItemsTree; 329 | var 330 | {Un} DirVfsItem: TVfsItem; 331 | AbsDirPath: WideString; 332 | 333 | begin 334 | DirVfsItem := nil; 335 | // * * * * * // 336 | with DataLib.IterateDict(VfsItems) do begin 337 | while IterNext() do begin 338 | AbsDirPath := StrLib.ExtractDirPathW(CaselessKeyToWideStr(IterKey)); 339 | 340 | if FindVfsItemByNormalizedPath(AbsDirPath, DirVfsItem) then begin 341 | DirVfsItem.Children.Add(IterValue); 342 | end; 343 | end; 344 | end; 345 | end; // .procedure BuildVfsItemsTree 346 | 347 | class function TMapping.Make (Applied: boolean; const AbsVirtPath, AbsRealPath: WideString; OverwriteExisting: boolean; Flags: integer): {O} TMapping; 348 | begin 349 | result := TMapping.Create; 350 | result.Applied := Applied; 351 | result.AbsVirtPath := AbsVirtPath; 352 | result.AbsRealPath := AbsRealPath; 353 | result.OverwriteExisting := OverwriteExisting; 354 | result.Flags := Flags; 355 | end; 356 | 357 | function RunVfs (DirListingOrder: TDirListingSortType): boolean; 358 | begin 359 | result := true; 360 | 361 | with VfsCritSection do begin 362 | Enter; 363 | 364 | if not VfsIsRunning then begin 365 | if not VfsTreeIsBuilt then begin 366 | VfsDirListingOrder := DirListingOrder; 367 | BuildVfsItemsTree(); 368 | SortVfsDirListings(DirListingOrder); 369 | VfsTreeIsBuilt := true; 370 | end; 371 | 372 | VfsIsRunning := true; 373 | end; 374 | 375 | Leave; 376 | end; // .with 377 | end; // .function RunVfs 378 | 379 | function PauseVfs: LONGBOOL; stdcall; 380 | begin 381 | result := true; 382 | 383 | with VfsCritSection do begin 384 | Enter; 385 | VfsIsRunning := false; 386 | Leave; 387 | end; 388 | end; 389 | 390 | function ResetVfs: LONGBOOL; stdcall; 391 | begin 392 | result := true; 393 | 394 | with VfsCritSection do begin 395 | Enter; 396 | VfsItems.Clear; 397 | MappedFiles.Clear; 398 | Mappings.Clear; 399 | VfsIsRunning := false; 400 | VfsTreeIsBuilt := false; 401 | Leave; 402 | end; 403 | end; 404 | 405 | function IsVfsActive: boolean; 406 | begin 407 | result := EnterVfs; 408 | 409 | if result then begin 410 | LeaveVfs; 411 | end; 412 | end; 413 | 414 | (* Returns real path for vfs item by its absolute virtual path or empty string. Optionally returns file info structure *) 415 | function GetVfsItemRealPath (const AbsVirtPath: WideString; {n} FileInfo: PNativeFileInfo = nil): WideString; 416 | var 417 | {n} VfsItem: TVfsItem; 418 | 419 | begin 420 | VfsItem := nil; 421 | result := ''; 422 | // * * * * * // 423 | if EnterVfs then begin 424 | if FindVfsItemByNormalizedPath(AbsVirtPath, VfsItem) then begin 425 | result := VfsItem.RealPath; 426 | 427 | if FileInfo <> nil then begin 428 | FileInfo^ := VfsItem.Info; 429 | end; 430 | end; 431 | 432 | LeaveVfs; 433 | end; // .if 434 | end; // .function GetVfsItemRealPath 435 | 436 | function GetVfsDirInfo (const NormalizedVirtPath, Mask: WideString; {OUT} var DirInfo: TNativeFileInfo; DirListing: TDirListing): boolean; 437 | var 438 | {n} VfsItem: TVfsItem; 439 | NormalizedMask: WideString; 440 | MaskPattern: Utils.TArrayOfByte; 441 | i: integer; 442 | 443 | begin 444 | {!} Assert(DirListing <> nil); 445 | VfsItem := nil; 446 | // * * * * * // 447 | result := EnterVfs; 448 | 449 | if result then begin 450 | result := FindVfsItemByNormalizedPath(NormalizedVirtPath, VfsItem) and VfsItem.IsDir; 451 | 452 | if result then begin 453 | DirInfo := VfsItem.Info; 454 | 455 | if VfsItem.Children <> nil then begin 456 | NormalizedMask := StrLib.WideLowerCase(Mask); 457 | MaskPattern := VfsMatching.CompilePattern(NormalizedMask); 458 | 459 | for i := 0 to VfsItem.Children.Count - 1 do begin 460 | if VfsMatching.MatchPattern(TVfsItem(VfsItem.Children[i]).SearchName, pointer(MaskPattern)) then begin 461 | DirListing.AddItem(@TVfsItem(VfsItem.Children[i]).Info); 462 | end; 463 | end; 464 | end; // .if 465 | end; // .if 466 | 467 | LeaveVfs; 468 | end; // .if 469 | end; // .function GetVfsDirInfo 470 | 471 | procedure CopyFileInfoWithoutNames (var Src, Dest: WinNative.FILE_ID_BOTH_DIR_INFORMATION); 472 | begin 473 | Dest.FileIndex := 0; 474 | Dest.CreationTime := Src.CreationTime; 475 | Dest.LastAccessTime := Src.LastAccessTime; 476 | Dest.LastWriteTime := Src.LastWriteTime; 477 | Dest.ChangeTime := Src.ChangeTime; 478 | Dest.EndOfFile := Src.EndOfFile; 479 | Dest.AllocationSize := Src.AllocationSize; 480 | Dest.FileAttributes := Src.FileAttributes; 481 | Dest.EaSize := Src.EaSize; 482 | end; 483 | 484 | (* Redirects single file/directory path (not including directory contents). Returns redirected VFS item 485 | for given real path if VFS item was successfully created/overwritten or it already existed and OverwriteExisting = false. *) 486 | function RedirectFile (const AbsVirtPath, AbsRealPath: WideString; {n} FileInfoPtr: WinNative.PFILE_ID_BOTH_DIR_INFORMATION; OverwriteExisting: boolean; Priority: integer): {Un} TVfsItem; 487 | const 488 | WIDE_NULL_CHAR_LEN = Length(#0); 489 | 490 | var 491 | {Un} VfsItem: TVfsItem; 492 | PackedVirtPath: string; 493 | IsNewItem: boolean; 494 | FileInfo: TNativeFileInfo; 495 | Success: boolean; 496 | 497 | begin 498 | VfsItem := nil; 499 | result := nil; 500 | // * * * * * // 501 | PackedVirtPath := WideStrToCaselessKey(AbsVirtPath); 502 | VfsItem := VfsItems[PackedVirtPath]; 503 | IsNewItem := VfsItem = nil; 504 | Success := true; 505 | 506 | if IsNewItem or OverwriteExisting then begin 507 | if FileInfoPtr = nil then begin 508 | Success := GetFileInfo(AbsRealPath, FileInfo); 509 | end; 510 | 511 | if Success then begin 512 | if IsNewItem then begin 513 | VfsItem := TVfsItem.Create(); 514 | VfsItems[PackedVirtPath] := VfsItem; 515 | VfsItem.Name := StrLib.ExtractFileNameW(AbsVirtPath); 516 | VfsItem.SearchName := StrLib.WideLowerCase(VfsItem.Name); 517 | VfsItem.Info.Base.ShortNameLength := 0; 518 | VfsItem.Info.Base.ShortName[0] := #0; 519 | end; 520 | 521 | if FileInfoPtr <> nil then begin 522 | CopyFileInfoWithoutNames(FileInfoPtr^, VfsItem.Info.Base); 523 | end else begin 524 | CopyFileInfoWithoutNames(FileInfo.Base, VfsItem.Info.Base); 525 | end; 526 | 527 | VfsItem.VirtPath := AbsVirtPath; 528 | VfsItem.RealPath := AbsRealPath; 529 | VfsItem.Priority := Priority; 530 | VfsItem.Attrs := 0; 531 | MappedFiles[WideStrToCaselessKey(AbsRealPath)] := VfsItem; 532 | end; // .if 533 | end; // .if 534 | 535 | if Success then begin 536 | result := VfsItem; 537 | end; 538 | end; // .function RedirectFile 539 | 540 | function _MapDir (const AbsVirtPath, AbsRealPath: WideString; {n} FileInfoPtr: WinNative.PFILE_ID_BOTH_DIR_INFORMATION; OverwriteExisting: boolean; Flags, Priority: integer): {Un} TVfsItem; 541 | var 542 | {O} Subdirs: {O} TList {OF TFileInfo}; 543 | {U} SubdirInfo: TFileInfo; 544 | {Un} DirVfsItem: TVfsItem; 545 | Success: boolean; 546 | FileInfo: TNativeFileInfo; 547 | VirtPathPrefix: WideString; 548 | RealPathPrefix: WideString; 549 | i: integer; 550 | 551 | begin 552 | DirVfsItem := nil; 553 | Subdirs := DataLib.NewList(Utils.OWNS_ITEMS); 554 | SubdirInfo := nil; 555 | result := nil; 556 | // * * * * * // 557 | if Priority = AUTO_PRIORITY then begin 558 | if OverwriteExisting then begin 559 | Priority := OverwritingPriority; 560 | Inc(OverwritingPriority); 561 | end else begin 562 | Priority := AddingPriority; 563 | Dec(AddingPriority); 564 | end; 565 | end; 566 | 567 | DirVfsItem := RedirectFile(AbsVirtPath, AbsRealPath, FileInfoPtr, OverwriteExisting, Priority); 568 | Success := (DirVfsItem <> nil) and ((DirVfsItem.RealPath = AbsRealPath) or VfsUtils.IsDir(AbsRealPath)); 569 | 570 | if Success then begin 571 | VirtPathPrefix := AddBackslash(AbsVirtPath); 572 | RealPathPrefix := AddBackslash(AbsRealPath); 573 | 574 | if DirVfsItem.Children = nil then begin 575 | DirVfsItem.Children := DataLib.NewList(not Utils.OWNS_ITEMS); 576 | end; 577 | 578 | with SysScanDir(AbsRealPath, '*') do begin 579 | while IterNext(FileInfo.FileName, @FileInfo.Base) do begin 580 | if Utils.Flags(FileInfo.Base.FileAttributes).Have(Windows.FILE_ATTRIBUTE_DIRECTORY) then begin 581 | if (FileInfo.FileName <> '.') and (FileInfo.FileName <> '..') then begin 582 | Subdirs.Add(TFileInfo.Create(@FileInfo)); 583 | end; 584 | end else begin 585 | RedirectFile(VirtPathPrefix + FileInfo.FileName, RealPathPrefix + FileInfo.FileName, @FileInfo, OverwriteExisting, Priority); 586 | end; 587 | end; 588 | end; 589 | 590 | for i := 0 to Subdirs.Count - 1 do begin 591 | SubdirInfo := TFileInfo(Subdirs[i]); 592 | _MapDir(VirtPathPrefix + SubdirInfo.Data.FileName, RealPathPrefix + SubdirInfo.Data.FileName, @SubdirInfo.Data, OverwriteExisting, Flags, Priority); 593 | end; 594 | end; // .if 595 | 596 | if Success then begin 597 | result := DirVfsItem; 598 | end; 599 | // * * * * * // 600 | SysUtils.FreeAndNil(Subdirs); 601 | end; // .function _MapDir 602 | 603 | function MapDir (const VirtPath, RealPath: WideString; OverwriteExisting: boolean; Flags: integer = 0): boolean; 604 | var 605 | AbsVirtPath: WideString; 606 | AbsRealPath: WideString; 607 | 608 | begin 609 | result := EnterVfsConfig; 610 | 611 | if result then begin 612 | AbsVirtPath := VfsUtils.NormalizePath(VirtPath); 613 | AbsRealPath := VfsUtils.NormalizePath(RealPath); 614 | result := (AbsVirtPath <> '') and (AbsRealPath <> ''); 615 | 616 | if result then begin 617 | result := _MapDir(AbsVirtPath, AbsRealPath, nil, OverwriteExisting, Flags, AUTO_PRIORITY) <> nil; 618 | Mappings.Add(TMapping.Make(result, AbsVirtPath, AbsRealPath, OverwriteExisting, Flags)); 619 | end; 620 | 621 | LeaveVfsConfig; 622 | end; 623 | end; // .function MapDir 624 | 625 | function CallWithoutVfs (Func: TSingleArgExternalFunc; Arg: pointer = nil): integer; stdcall; 626 | begin 627 | with GetThreadVfsDisabler do begin 628 | try 629 | DisableVfsForThread; 630 | result := Func(Arg); 631 | finally 632 | RestoreVfsForThread; 633 | end; 634 | end; 635 | end; // .function CallWithoutVfs 636 | 637 | function RefreshVfs: LONGBOOL; stdcall; 638 | var 639 | VfsWasRunning: boolean; 640 | i: integer; 641 | 642 | begin 643 | with VfsCritSection do begin 644 | Enter; 645 | result := VfsTreeIsBuilt; 646 | 647 | if result then begin 648 | VfsItems.Clear; 649 | MappedFiles.Clear; 650 | VfsWasRunning := VfsIsRunning; 651 | VfsIsRunning := false; 652 | VfsTreeIsBuilt := false; 653 | 654 | for i := 0 to Mappings.Count - 1 do begin 655 | with TMapping(Mappings[i]) do begin 656 | TMapping(Mappings[i]).Applied := MapDir(AbsVirtPath, AbsRealPath, OverwriteExisting, Flags); 657 | end; 658 | end; 659 | 660 | if VfsWasRunning then begin 661 | BuildVfsItemsTree(); 662 | SortVfsDirListings(VfsDirListingOrder); 663 | VfsTreeIsBuilt := true; 664 | VfsIsRunning := true; 665 | end; 666 | end; 667 | 668 | Leave; 669 | end; // .with 670 | end; // .function RefreshVfs 671 | 672 | function RefreshMappedFile (const FilePath: WideString): boolean; 673 | var 674 | {U} VfsItem: TVfsItem; 675 | AbsRealPath: WideString; 676 | FileInfo: TNativeFileInfo; 677 | VfsWasRunning: boolean; 678 | 679 | begin 680 | VfsItem := nil; 681 | // * * * * * // 682 | with VfsCritSection do begin 683 | Enter; 684 | result := VfsTreeIsBuilt; 685 | 686 | if result then begin 687 | VfsWasRunning := VfsIsRunning; 688 | VfsIsRunning := false; 689 | AbsRealPath := NormalizePath(FilePath); 690 | VfsItem := TVfsItem(MappedFiles[WideStrToCaselessKey(AbsRealPath)]); 691 | result := (VfsItem <> nil) and GetFileInfo(AbsRealPath, FileInfo); 692 | 693 | if result then begin 694 | CopyFileInfoWithoutNames(FileInfo.Base, VfsItem.Info.Base); 695 | end; 696 | 697 | VfsIsRunning := VfsWasRunning; 698 | end; 699 | 700 | Leave; 701 | end; // .with 702 | end; // .function RefreshMappedFile 703 | 704 | function GetMappingsReport_ (Mappings: TList {of TMapping}): WideString; 705 | const 706 | COL_PATHS = 0; 707 | COL_META = 1; 708 | 709 | var 710 | {O} Buf: StrLib.TStrBuilder; 711 | {O} Line: StrLib.TStrBuilder; 712 | Cols: array [0..1] of array of WideString; 713 | MaxPathColWidth: integer; 714 | i: integer; 715 | 716 | procedure WriteMapping (Mapping: TMapping; LineN: integer); 717 | var 718 | StartPathPos: integer; 719 | MaxCommonPathLen: integer; 720 | ShortestPath: WideString; 721 | LongestPath: WideString; 722 | i: integer; 723 | 724 | begin 725 | {!} Assert(Mapping <> nil); 726 | StartPathPos := 1; 727 | 728 | if Length(Mapping.AbsRealPath) > Length(Mapping.AbsVirtPath) then begin 729 | LongestPath := Mapping.AbsRealPath; 730 | ShortestPath := Mapping.AbsVirtPath; 731 | end else begin 732 | LongestPath := Mapping.AbsVirtPath; 733 | ShortestPath := Mapping.AbsRealPath; 734 | end; 735 | 736 | i := 1; 737 | MaxCommonPathLen := Length(ShortestPath); 738 | 739 | while (i <= MaxCommonPathLen) and (ShortestPath[i] = LongestPath[i]) do begin 740 | Inc(i); 741 | end; 742 | 743 | // Handle case: [xxx\yyy] zzz and [xxx\yyy]. Common part is [xxx] 744 | if (Length(LongestPath) > MaxCommonPathLen) and (LongestPath[i] <> '\') then begin 745 | while (i >= 2) and (LongestPath[i] <> '\') do begin 746 | Dec(i); 747 | end; 748 | end 749 | // Handle case: D:\App <= D:\Mods. Common part is D: 750 | else if ShortestPath[i] = '\' then begin 751 | Dec(i); 752 | end; 753 | 754 | StartPathPos := i; 755 | Line.Clear; 756 | 757 | if StartPathPos > 1 then begin 758 | Line.AppendWide('$'); 759 | end; 760 | 761 | Line.AppendWide(Copy(Mapping.AbsVirtPath, StartPathPos)); 762 | Line.AppendWide(' <= '); 763 | 764 | if StartPathPos > 1 then begin 765 | Line.AppendWide('$'); 766 | end; 767 | 768 | Line.AppendWide(Copy(Mapping.AbsRealPath, StartPathPos)); 769 | 770 | if not Mapping.Applied then begin 771 | Line.AppendWide(' *MISS*'); 772 | end; 773 | 774 | Cols[COL_PATHS][LineN] := Line.BuildWideStr; 775 | MaxPathColWidth := Max(MaxPathColWidth, Length(Cols[COL_PATHS][LineN])); 776 | 777 | Line.Clear; 778 | Line.AppendWide('[Overwrite = ' + IntToStr(ord(Mapping.OverwriteExisting)) + ', Flags = ' + IntToStr(Mapping.Flags)); 779 | 780 | if StartPathPos > 1 then begin 781 | Line.AppendWide(', $ = "' + Copy(ShortestPath, 1, StartPathPos - 1) + '"]'); 782 | end else begin 783 | Line.AppendWide(']'); 784 | end; 785 | 786 | Cols[COL_META][LineN] := Line.BuildWideStr; 787 | end; // .procedure WriteMapping 788 | 789 | function FormatResultTable: WideString; 790 | var 791 | i: integer; 792 | 793 | begin 794 | for i := 0 to Mappings.Count - 1 do begin 795 | Buf.AppendWide(Cols[COL_PATHS][i] + StringOfChar(WideChar(' '), MaxPathColWidth - Length(Cols[COL_PATHS][i]) + 1)); 796 | Buf.AppendWide(Cols[COL_META][i]); 797 | 798 | if i < Mappings.Count - 1 then begin 799 | Buf.AppendWide(#13#10); 800 | end; 801 | end; 802 | 803 | result := Buf.BuildWideStr; 804 | end; 805 | 806 | begin 807 | Buf := StrLib.TStrBuilder.Create; 808 | Line := StrLib.TStrBuilder.Create; 809 | // * * * * * // 810 | SetLength(Cols[COL_PATHS], Mappings.Count); 811 | SetLength(Cols[COL_META], Mappings.Count); 812 | MaxPathColWidth := 0; 813 | 814 | for i := 0 to Mappings.Count - 1 do begin 815 | WriteMapping(TMapping(Mappings[i]), i); 816 | end; 817 | 818 | result := FormatResultTable; 819 | // * * * * * // 820 | SysUtils.FreeAndNil(Buf); 821 | SysUtils.FreeAndNil(Line); 822 | end; // .function GetMappingsReport_ 823 | 824 | function GetMappingsReport: WideString; 825 | begin 826 | with VfsCritSection do begin 827 | Enter; 828 | result := GetMappingsReport_(Mappings); 829 | Leave; 830 | end; 831 | end; 832 | 833 | function CompareMappingsByRealPath (A, B: integer): integer; 834 | begin 835 | result := StrLib.CompareBinStringsW(TMapping(A).AbsRealPath, TMapping(B).AbsRealPath); 836 | end; 837 | 838 | function GetDetailedMappingsReport: WideString; 839 | var 840 | {O} DetailedMappings: {O} TList {of TMapping}; 841 | {Un} VfsItem: TVfsItem; 842 | 843 | begin 844 | DetailedMappings := DataLib.NewList(Utils.OWNS_ITEMS); 845 | VfsItem := nil; 846 | // * * * * * // 847 | with VfsCritSection do begin 848 | Enter; 849 | 850 | with DataLib.IterateDict(VfsItems) do begin 851 | while IterNext do begin 852 | VfsItem := TVfsItem(IterValue); 853 | 854 | // Note, item Attrs is not the same as directory mapping Flags 855 | DetailedMappings.Add(TMapping.Make(true, VfsItem.VirtPath, VfsItem.RealPath, false, VfsItem.Attrs)); 856 | end; 857 | end; 858 | 859 | Leave; 860 | end; 861 | 862 | DetailedMappings.CustomSort(CompareMappingsByRealPath); 863 | result := GetMappingsReport_(DetailedMappings); 864 | // * * * * * // 865 | SysUtils.FreeAndNil(DetailedMappings); 866 | end; 867 | 868 | begin 869 | VfsCritSection.Init; 870 | VfsItems := DataLib.NewDict(Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE); 871 | MappedFiles := DataLib.NewDict(not Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE); 872 | Mappings := DataLib.NewList(Utils.OWNS_ITEMS); 873 | end. -------------------------------------------------------------------------------- /VfsHooks.pas: -------------------------------------------------------------------------------- 1 | unit VfsHooks; 2 | (* 3 | Description: WinNT code hooks package. 4 | *) 5 | 6 | 7 | (***) interface (***) 8 | 9 | uses 10 | Windows, SysUtils, Math, 11 | Utils, WinNative, Concur, 12 | StrLib, Alg, WinUtils, 13 | VfsBase, VfsUtils, VfsPatching, 14 | VfsDebug, VfsApiDigger, VfsOpenFiles; 15 | 16 | 17 | (* Installs VFS hooks, if not already installed, in a thread-safe manner *) 18 | procedure InstallHooks; 19 | 20 | 21 | (***) implementation (***) 22 | 23 | 24 | var 25 | HooksCritSection: Concur.TCritSection; 26 | HooksInstalled: boolean = false; 27 | 28 | NativeNtQueryAttributesFile: WinNative.TNtQueryAttributesFile; 29 | NativeNtQueryFullAttributesFile: WinNative.TNtQueryFullAttributesFile; 30 | NativeNtOpenFile: WinNative.TNtOpenFile; 31 | NativeNtCreateFile: WinNative.TNtCreateFile; 32 | NativeNtClose: WinNative.TNtClose; 33 | NativeNtQueryDirectoryFile: WinNative.TNtQueryDirectoryFile; 34 | NativeNtQueryDirectoryFileEx: WinNative.TNtQueryDirectoryFileEx; 35 | 36 | 37 | NtQueryAttributesFilePatch: VfsPatching.TAppliedPatch; 38 | NtQueryFullAttributesFilePatch: VfsPatching.TAppliedPatch; 39 | NtOpenFilePatch: VfsPatching.TAppliedPatch; 40 | NtCreateFilePatch: VfsPatching.TAppliedPatch; 41 | NtClosePatch: VfsPatching.TAppliedPatch; 42 | NtQueryDirectoryFilePatch: VfsPatching.TAppliedPatch; 43 | NtQueryDirectoryFileExPatch: VfsPatching.TAppliedPatch; 44 | 45 | 46 | (* There is no 100% portable and reliable way to get file path by handle, unless file creation/opening 47 | was tracked. Thus we rely heavily on VfsOpenFiles. 48 | In Windows access to files in curren directory under relative paths is performed via [hDir, RelPath] pair, 49 | thus it's strongly recommended to ensure, that current directory handle is tracked by VfsOpenedFiles. 50 | It can be perfomed via SetCurrentDir(GetCurrentDir) after VFS was run *) 51 | function GetFilePathByHandle (hFile: THandle): WideString; 52 | begin 53 | result := VfsOpenFiles.GetOpenedFilePath(hFile); 54 | 55 | if (result = '') and VfsDebug.LoggingEnabled then begin 56 | WriteLog('GetFilePathByHandle', Format('Failed to get path for handle %x. Current directory is: %s', [integer(hFile), WinUtils.GetCurrentDirW])); 57 | end; 58 | end; 59 | 60 | (* Returns single absolute path, not dependant on RootDirectory member. '\??\' prefix is always removed, \\.\ and \\?\ paths remain not touched. *) 61 | function GetFileObjectPath (ObjectAttributes: POBJECT_ATTRIBUTES): WideString; 62 | var 63 | FilePath: WideString; 64 | DirPath: WideString; 65 | 66 | begin 67 | FilePath := ObjectAttributes.ObjectName.ToWideStr(); 68 | result := ''; 69 | 70 | if FilePath <> '' then begin 71 | if FilePath[1] = '\' then begin 72 | FilePath := VfsUtils.StripNtAbsPathPrefix(FilePath); 73 | end; 74 | 75 | if ObjectAttributes.RootDirectory <> 0 then begin 76 | DirPath := GetFilePathByHandle(ObjectAttributes.RootDirectory); 77 | 78 | if DirPath <> '' then begin 79 | if DirPath[Length(DirPath)] <> '\' then begin 80 | result := DirPath + '\' + FilePath; 81 | end else begin 82 | result := DirPath + FilePath; 83 | end; 84 | end; 85 | end else begin 86 | result := FilePath; 87 | end; 88 | end; // .if 89 | end; // .function GetFileObjectPath 90 | 91 | function Hook_NtQueryAttributesFile (OrigFunc: WinNative.TNtQueryAttributesFile; ObjectAttributes: POBJECT_ATTRIBUTES; FileInformation: PFILE_BASIC_INFORMATION): NTSTATUS; stdcall; 92 | var 93 | ExpandedPath: WideString; 94 | RedirectedPath: WideString; 95 | ReplacedObjAttrs: WinNative.TObjectAttributes; 96 | ReplacedPath: WinNative.UNICODE_STRING; 97 | FileInfo: TNativeFileInfo; 98 | HadTrailingDelim_: array [0..3] of byte; // Fix Delphi bug: HadTrailingDelim causes stack 4-bytes misalignment 99 | HadTrailingDelim: boolean absolute HadTrailingDelim_; 100 | 101 | begin 102 | if VfsDebug.LoggingEnabled then begin 103 | WriteLog('[ENTER] NtQueryAttributesFile', Format('Dir: %d.'#13#10'Path: "%s"', [ObjectAttributes.RootDirectory, ObjectAttributes.ObjectName.ToWideStr()])); 104 | end; 105 | 106 | ReplacedObjAttrs := ObjectAttributes^; 107 | ReplacedObjAttrs.Length := sizeof(ReplacedObjAttrs); 108 | ExpandedPath := GetFileObjectPath(ObjectAttributes); 109 | RedirectedPath := ''; 110 | 111 | if ExpandedPath <> '' then begin 112 | RedirectedPath := VfsBase.GetVfsItemRealPath(StrLib.ExcludeTrailingBackslashW(ExpandedPath, @HadTrailingDelim), @FileInfo); 113 | end; 114 | 115 | // Return cached VFS file info 116 | if RedirectedPath <> '' then begin 117 | if not HadTrailingDelim or Utils.Flags(FileInfo.Base.FileAttributes).Have(FILE_ATTRIBUTE_DIRECTORY) then begin 118 | FileInformation.CreationTime := FileInfo.Base.CreationTime; 119 | FileInformation.LastAccessTime := FileInfo.Base.LastAccessTime; 120 | FileInformation.LastWriteTime := FileInfo.Base.LastWriteTime; 121 | FileInformation.ChangeTime := FileInfo.Base.ChangeTime; 122 | FileInformation.FileAttributes := FileInfo.Base.FileAttributes; 123 | result := WinNative.STATUS_SUCCESS; 124 | end else begin 125 | result := WinNative.STATUS_NO_SUCH_FILE; 126 | end; 127 | end 128 | // Query file with real path 129 | else begin 130 | RedirectedPath := ExpandedPath; 131 | 132 | if RedirectedPath <> '' then begin 133 | if RedirectedPath[1] <> '\' then begin 134 | RedirectedPath := '\??\' + RedirectedPath; 135 | end; 136 | 137 | ReplacedObjAttrs.RootDirectory := 0; 138 | ReplacedObjAttrs.Attributes := ReplacedObjAttrs.Attributes or WinNative.OBJ_CASE_INSENSITIVE; 139 | ReplacedObjAttrs.ObjectName := @ReplacedPath; 140 | ReplacedObjAttrs.ObjectName.AssignExistingStr(RedirectedPath); 141 | end; 142 | 143 | result := OrigFunc(@ReplacedObjAttrs, FileInformation); 144 | end; // .else 145 | 146 | if VfsDebug.LoggingEnabled then begin 147 | WriteLog('[LEAVE] NtQueryAttributesFile', Format('Result: %x. Attrs: 0x%x.'#13#10'Expanded: "%s"'#13#10'Redirected: "%s"', [result, FileInformation.FileAttributes, string(ExpandedPath), string(RedirectedPath)])); 148 | end; 149 | end; // .function Hook_NtQueryAttributesFile 150 | 151 | function Hook_NtQueryFullAttributesFile (OrigFunc: WinNative.TNtQueryFullAttributesFile; ObjectAttributes: POBJECT_ATTRIBUTES; FileInformation: PFILE_NETWORK_OPEN_INFORMATION): NTSTATUS; stdcall; 152 | var 153 | ExpandedPath: WideString; 154 | RedirectedPath: WideString; 155 | ReplacedObjAttrs: WinNative.TObjectAttributes; 156 | ReplacedPath: WinNative.UNICODE_STRING; 157 | FileInfo: TNativeFileInfo; 158 | HadTrailingDelim_: array [0..3] of byte; // Fix Delphi bug: HadTrailingDelim causes stack 4-bytes misalignment 159 | HadTrailingDelim: boolean absolute HadTrailingDelim_; 160 | 161 | begin 162 | if VfsDebug.LoggingEnabled then begin 163 | WriteLog('[ENTER] NtQueryFullAttributesFile', Format('Dir: %d.'#13#10'Path: "%s"', [ObjectAttributes.RootDirectory, ObjectAttributes.ObjectName.ToWideStr()])); 164 | end; 165 | 166 | ReplacedObjAttrs := ObjectAttributes^; 167 | ReplacedObjAttrs.Length := sizeof(ReplacedObjAttrs); 168 | ExpandedPath := GetFileObjectPath(ObjectAttributes); 169 | RedirectedPath := ''; 170 | 171 | if ExpandedPath <> '' then begin 172 | RedirectedPath := VfsBase.GetVfsItemRealPath(StrLib.ExcludeTrailingBackslashW(ExpandedPath, @HadTrailingDelim), @FileInfo); 173 | end; 174 | 175 | // Return cached VFS file info 176 | if RedirectedPath <> '' then begin 177 | if not HadTrailingDelim or Utils.Flags(FileInfo.Base.FileAttributes).Have(FILE_ATTRIBUTE_DIRECTORY) then begin 178 | FileInformation.CreationTime := FileInfo.Base.CreationTime; 179 | FileInformation.LastAccessTime := FileInfo.Base.LastAccessTime; 180 | FileInformation.LastWriteTime := FileInfo.Base.LastWriteTime; 181 | FileInformation.ChangeTime := FileInfo.Base.ChangeTime; 182 | FileInformation.AllocationSize := FileInfo.Base.AllocationSize; 183 | FileInformation.EndOfFile := FileInfo.Base.EndOfFile; 184 | FileInformation.FileAttributes := FileInfo.Base.FileAttributes; 185 | FileInformation.Reserved := 0; 186 | result := WinNative.STATUS_SUCCESS; 187 | end else begin 188 | result := WinNative.STATUS_NO_SUCH_FILE; 189 | end; 190 | end 191 | // Query file with real path 192 | else begin 193 | RedirectedPath := ExpandedPath; 194 | 195 | if RedirectedPath <> '' then begin 196 | if RedirectedPath[1] <> '\' then begin 197 | RedirectedPath := '\??\' + RedirectedPath; 198 | end; 199 | 200 | ReplacedObjAttrs.RootDirectory := 0; 201 | ReplacedObjAttrs.Attributes := ReplacedObjAttrs.Attributes or WinNative.OBJ_CASE_INSENSITIVE; 202 | ReplacedObjAttrs.ObjectName := @ReplacedPath; 203 | ReplacedObjAttrs.ObjectName.AssignExistingStr(RedirectedPath); 204 | end; 205 | 206 | result := OrigFunc(@ReplacedObjAttrs, FileInformation); 207 | end; // .else 208 | 209 | if VfsDebug.LoggingEnabled then begin 210 | WriteLog('[LEAVE] NtQueryFullAttributesFile', Format('Result: %x. Attrs: 0x%x.'#13#10'Expanded: "%s"'#13#10'Redirected: "%s"', [result, FileInformation.FileAttributes, string(ExpandedPath), string(RedirectedPath)])); 211 | end; 212 | end; // .Hook_NtQueryFullAttributesFile 213 | 214 | function Hook_NtOpenFile (OrigFunc: WinNative.TNtOpenFile; FileHandle: PHANDLE; DesiredAccess: ACCESS_MASK; ObjectAttributes: POBJECT_ATTRIBUTES; 215 | IoStatusBlock: PIO_STATUS_BLOCK; ShareAccess: ULONG; OpenOptions: ULONG): NTSTATUS; stdcall; 216 | begin 217 | if VfsDebug.LoggingEnabled then begin 218 | WriteLog('NtOpenFile', ObjectAttributes.ObjectName.ToWideStr()); 219 | end; 220 | 221 | result := WinNative.NtCreateFile(FileHandle, DesiredAccess, ObjectAttributes, IoStatusBlock, nil, 0, ShareAccess, WinNative.FILE_OPEN, OpenOptions, nil, 0); 222 | end; 223 | 224 | function Hook_NtCreateFile (OrigFunc: WinNative.TNtCreateFile; FileHandle: PHANDLE; DesiredAccess: ACCESS_MASK; ObjectAttributes: POBJECT_ATTRIBUTES; IoStatusBlock: PIO_STATUS_BLOCK; 225 | AllocationSize: PLARGE_INTEGER; FileAttributes: ULONG; ShareAccess: ULONG; CreateDisposition: ULONG; CreateOptions: ULONG; EaBuffer: PVOID; EaLength: ULONG): NTSTATUS; stdcall; 226 | var 227 | ExpandedPath: WideString; 228 | RedirectedPath: WideString; 229 | ReplacedObjAttrs: WinNative.TObjectAttributes; 230 | ReplacedPath: WinNative.UNICODE_STRING; 231 | HadTrailingDelim_: array [0..3] of byte; // Fix Delphi bug: HadTrailingDelim causes stack 4-bytes misalignment 232 | HadTrailingDelim: boolean absolute HadTrailingDelim_; 233 | 234 | begin 235 | if VfsDebug.LoggingEnabled then begin 236 | WriteLog('[ENTER] NtCreateFile', Format('Access: 0x%x. CreateDisposition: 0x%x'#13#10'Path: "%s"', [Int(DesiredAccess), Int(CreateDisposition), ObjectAttributes.ObjectName.ToWideStr()])); 237 | end; 238 | 239 | ReplacedObjAttrs := ObjectAttributes^; 240 | ReplacedObjAttrs.Length := sizeof(ReplacedObjAttrs); 241 | ExpandedPath := GetFileObjectPath(ObjectAttributes); 242 | RedirectedPath := ''; 243 | 244 | if (ExpandedPath <> '') and ((DesiredAccess and WinNative.DELETE) = 0) and (CreateDisposition = WinNative.FILE_OPEN) then begin 245 | RedirectedPath := VfsBase.GetVfsItemRealPath(StrLib.ExcludeTrailingBackslashW(ExpandedPath, @HadTrailingDelim)); 246 | end; 247 | 248 | if RedirectedPath = '' then begin 249 | RedirectedPath := ExpandedPath; 250 | end else if HadTrailingDelim then begin 251 | RedirectedPath := RedirectedPath + '\'; 252 | end; 253 | 254 | if RedirectedPath <> '' then begin 255 | if RedirectedPath[1] <> '\' then begin 256 | RedirectedPath := '\??\' + RedirectedPath; 257 | end; 258 | 259 | ReplacedObjAttrs.RootDirectory := 0; 260 | ReplacedObjAttrs.Attributes := ReplacedObjAttrs.Attributes or WinNative.OBJ_CASE_INSENSITIVE; 261 | ReplacedObjAttrs.ObjectName := @ReplacedPath; 262 | ReplacedObjAttrs.ObjectName.AssignExistingStr(RedirectedPath); 263 | end; 264 | 265 | with VfsOpenFiles.OpenFilesCritSection do begin 266 | Enter; 267 | 268 | result := OrigFunc(FileHandle, DesiredAccess, @ReplacedObjAttrs, IoStatusBlock, AllocationSize, FileAttributes, ShareAccess, CreateDisposition, CreateOptions, EaBuffer, EaLength); 269 | 270 | if (result = WinNative.STATUS_SUCCESS) and (ExpandedPath <> '') then begin 271 | VfsOpenFiles.SetOpenedFileInfo(FileHandle^, TOpenedFile.Create(FileHandle^, VfsUtils.NormalizeAbsPath(ExpandedPath))); 272 | end; 273 | 274 | Leave; 275 | end; 276 | 277 | if VfsDebug.LoggingEnabled then begin 278 | if ExpandedPath <> StripNtAbsPathPrefix(RedirectedPath) then begin 279 | WriteLog('[LEAVE] NtCreateFile', Format('Handle: %x. Status: %x.'#13#10'Expanded: "%s"'#13#10'Redirected: "%s"', [FileHandle^, result, ExpandedPath, StripNtAbsPathPrefix(RedirectedPath)])); 280 | end else begin 281 | WriteLog('[LEAVE] NtCreateFile', Format('Handle: %x. Status: %x.'#13#10'Expanded: "%s"', [FileHandle^, result, ExpandedPath])); 282 | end; 283 | end; 284 | end; // .function Hook_NtCreateFile 285 | 286 | function Hook_NtClose (OrigFunc: WinNative.TNtClose; hData: HANDLE): NTSTATUS; stdcall; 287 | begin 288 | if VfsDebug.LoggingEnabled then begin 289 | WriteLog('[ENTER] NtClose', Format('Handle: %x', [integer(hData)])); 290 | end; 291 | 292 | with VfsOpenFiles.OpenFilesCritSection do begin 293 | Enter; 294 | 295 | result := OrigFunc(hData); 296 | 297 | if WinNative.NT_SUCCESS(result) then begin 298 | VfsOpenFiles.DeleteOpenedFileInfo(hData); 299 | end; 300 | 301 | Leave; 302 | end; 303 | 304 | if VfsDebug.LoggingEnabled then begin 305 | WriteLog('[LEAVE] NtClose', Format('Status: %x', [integer(result)])); 306 | end; 307 | end; // .function Hook_NtClose 308 | 309 | function IsSupportedFileInformationClass (FileInformationClass: integer): boolean; 310 | begin 311 | result := (FileInformationClass <= High(byte)) and (FILE_INFORMATION_CLASS(byte(FileInformationClass)) in [FileBothDirectoryInformation, FileDirectoryInformation, FileFullDirectoryInformation, FileIdBothDirectoryInformation, FileIdFullDirectoryInformation, FileNamesInformation]); 312 | end; 313 | 314 | type 315 | TFileInfoConvertResult = (TOO_SMALL_BUF, COPIED_ALL, TRUNCATED_NAME); 316 | TTruncatedNamesStrategy = (DONT_TRUNCATE_NAMES, TRUNCATE_NAMES); 317 | 318 | function ConvertFileInfoStruct (SrcInfo: PNativeFileInfo; TargetFormat: FILE_INFORMATION_CLASS; {n} Buf: pointer; BufSize: integer; TruncatedNamesStrategy: TTruncatedNamesStrategy; 319 | {OUT} var BytesWritten: integer): TFileInfoConvertResult; 320 | var 321 | {n} FileNameBuf: pointer; 322 | FileNameBufSize: integer; 323 | StructBaseSize: integer; 324 | StructFullSize: integer; 325 | 326 | begin 327 | {!} Assert(SrcInfo <> nil); 328 | {!} Assert(IsSupportedFileInformationClass(ord(TargetFormat)), Format('Unsupported file information class: %d', [ord(TargetFormat)])); 329 | FileNameBuf := nil; 330 | // * * * * * // 331 | BytesWritten := 0; 332 | StructBaseSize := WinNative.GetFileInformationClassSize(TargetFormat); 333 | StructFullSize := StructBaseSize + Int(SrcInfo.Base.FileNameLength); 334 | 335 | if (Buf = nil) or (BufSize < StructBaseSize) then begin 336 | result := TOO_SMALL_BUF; 337 | exit; 338 | end; 339 | 340 | result := COPIED_ALL; 341 | 342 | if BufSize < StructFullSize then begin 343 | result := TRUNCATED_NAME; 344 | 345 | if TruncatedNamesStrategy = DONT_TRUNCATE_NAMES then begin 346 | exit; 347 | end; 348 | end; 349 | 350 | case TargetFormat of 351 | FileNamesInformation: PFILE_NAMES_INFORMATION(Buf).FileNameLength := SrcInfo.Base.FileNameLength; 352 | 353 | FileBothDirectoryInformation, FileDirectoryInformation, FileFullDirectoryInformation, FileIdBothDirectoryInformation, FileIdFullDirectoryInformation: begin 354 | Utils.CopyMem(StructBaseSize, @SrcInfo.Base, Buf); 355 | end; 356 | else 357 | {!} Assert(IsSupportedFileInformationClass(ord(TargetFormat)), Format('Unexpected unsupported file information class: %d', [ord(TargetFormat)])); 358 | end; 359 | 360 | FileNameBufSize := Min(BufSize - StructBaseSize, SrcInfo.Base.FileNameLength) and not $00000001; 361 | FileNameBuf := Utils.PtrOfs(Buf, StructBaseSize); 362 | 363 | Utils.CopyMem(FileNameBufSize, PWideChar(SrcInfo.FileName), FileNameBuf); 364 | 365 | BytesWritten := StructBaseSize + FileNameBufSize; 366 | end; // .function ConvertFileInfoStruct 367 | 368 | const 369 | MASK_ALL_FILES: WideString = '*'#0; 370 | 371 | function Hook_NtQueryDirectoryFile (OrigFunc: WinNative.TNtQueryDirectoryFile; FileHandle: HANDLE; Event: HANDLE; ApcRoutine: pointer; ApcContext: PVOID; Io: PIO_STATUS_BLOCK; Buffer: PVOID; 372 | BufLength: ULONG; InfoClass: integer (* FILE_INFORMATION_CLASS *); SingleEntry: BOOLEAN; {n} Mask: PUNICODE_STRING; RestartScan: BOOLEAN): NTSTATUS; stdcall; 373 | const 374 | ENTRIES_ALIGNMENT = 8; 375 | 376 | type 377 | PPrevEntry = ^TPrevEntry; 378 | TPrevEntry = packed record 379 | NextEntryOffset: ULONG; 380 | FileIndex: ULONG; 381 | end; 382 | 383 | var 384 | {Un} OpenedFile: TOpenedFile; 385 | {Un} FileInfo: TFileInfo; 386 | {n} BufCaret: pointer; 387 | {n} PrevEntry: PPrevEntry; 388 | BufSize: integer; 389 | BufSizeLeft: integer; 390 | BytesWritten: integer; 391 | IsFirstEntry: boolean; 392 | Proceed: boolean; 393 | TruncatedNamesStrategy: TTruncatedNamesStrategy; 394 | StructConvertResult: TFileInfoConvertResult; 395 | EmptyMask: UNICODE_STRING; 396 | EntryName: WideString; 397 | VfsIsActive: boolean; 398 | 399 | begin 400 | OpenedFile := nil; 401 | FileInfo := nil; 402 | BufCaret := nil; 403 | PrevEntry := nil; 404 | BufSize := BufLength; 405 | // * * * * * // 406 | with VfsOpenFiles.OpenFilesCritSection do begin 407 | if VfsDebug.LoggingEnabled then begin 408 | WriteLog('[ENTER] NtQueryDirectoryFile', Format('Handle: %x. InfoClass: %s. Mask: %s. SingleEntry: %d', [Int(FileHandle), WinNative.FileInformationClassToStr(InfoClass), string(Mask.ToWideStr()), ord(SingleEntry)])); 409 | end; 410 | 411 | Enter; 412 | 413 | OpenedFile := VfsOpenFiles.GetOpenedFile(FileHandle); 414 | VfsIsActive := VfsBase.IsVfsActive; 415 | 416 | if RestartScan then begin 417 | SysUtils.FreeAndNil(OpenedFile.DirListing); 418 | end; 419 | 420 | if (OpenedFile = nil) or (not IsSupportedFileInformationClass(InfoClass) and (OpenedFile.DirListing = nil)) or (Event <> 0) or (ApcRoutine <> nil) or (ApcContext <> nil) or (not VfsIsActive) then begin 421 | Leave; 422 | WriteLog('[INNER] NtQueryDirectoryFile', Format('Calling native NtQueryDirectoryFile. OpenedFileRec: %x, VfsIsOn: %d, Event: %d. ApcRoutine: %d. ApcContext: %d', [Int(OpenedFile), ord(VfsIsActive), Int(Event), Int(ApcRoutine), Int(ApcContext)])); 423 | result := OrigFunc(FileHandle, Event, ApcRoutine, ApcContext, Io, Buffer, BufLength, InfoClass, SingleEntry, Mask, RestartScan); 424 | end else begin 425 | int(Io.Information) := 0; 426 | result := STATUS_SUCCESS; 427 | Proceed := true; 428 | 429 | // Disallow nil buffer 430 | if Proceed and (Buffer = nil) then begin 431 | Proceed := false; 432 | result := STATUS_ACCESS_VIOLATION; 433 | end; 434 | 435 | // Validate buffer size 436 | if Proceed and (int(BufLength) < WinNative.GetFileInformationClassSize(InfoClass)) then begin 437 | Proceed := false; 438 | result := STATUS_INFO_LENGTH_MISMATCH; 439 | end; 440 | 441 | // Validate information class 442 | if Proceed and not IsSupportedFileInformationClass(InfoClass) then begin 443 | Proceed := false; 444 | result := STATUS_INVALID_INFO_CLASS; 445 | end; 446 | 447 | // Fill internal listing 448 | if OpenedFile.DirListing = nil then begin 449 | // NIL mask must treated as * 450 | if Mask = nil then begin 451 | EmptyMask.AssignExistingStr(MASK_ALL_FILES); 452 | Mask := @EmptyMask; 453 | end; 454 | 455 | OpenedFile.FillDirListing(Mask.ToWideStr()); 456 | end; 457 | 458 | // Signal of scanning end, if necessary 459 | if Proceed and OpenedFile.DirListing.IsEnd then begin 460 | Proceed := false; 461 | 462 | if OpenedFile.DirListing.Count > 0 then begin 463 | result := STATUS_NO_MORE_FILES; 464 | end else begin 465 | result := STATUS_NO_SUCH_FILE; 466 | end; 467 | end; 468 | 469 | // Scan directory 470 | if Proceed then begin 471 | if VfsDebug.LoggingEnabled then begin 472 | WriteLog('[INNER] NtQueryDirectoryFile', Format('Writing entries for buffer of size %d. Single entry: %d', [BufSize, ord(SingleEntry)])); 473 | end; 474 | 475 | BufCaret := Buffer; 476 | BytesWritten := 1; 477 | 478 | while (BytesWritten > 0) and OpenedFile.DirListing.GetNextItem(FileInfo) do begin 479 | // Align next record to 8-bytes boundary from Buffer start 480 | BufCaret := pointer(int(Buffer) + Alg.IntRoundToBoundary(int(Io.Information), ENTRIES_ALIGNMENT)); 481 | BufSizeLeft := BufSize - (int(BufCaret) - int(Buffer)); 482 | 483 | IsFirstEntry := OpenedFile.DirListing.FileInd = 1; 484 | 485 | if IsFirstEntry then begin 486 | TruncatedNamesStrategy := TRUNCATE_NAMES; 487 | end else begin 488 | TruncatedNamesStrategy := DONT_TRUNCATE_NAMES; 489 | end; 490 | 491 | StructConvertResult := ConvertFileInfoStruct(@FileInfo.Data, FILE_INFORMATION_CLASS(byte(InfoClass)), BufCaret, BufSizeLeft, TruncatedNamesStrategy, BytesWritten); 492 | 493 | if VfsDebug.LoggingEnabled then begin 494 | EntryName := Copy(FileInfo.Data.FileName, 1, Min(BytesWritten - WinNative.GetFileInformationClassSize(InfoClass), FileInfo.Data.Base.FileNameLength) div 2); 495 | WriteLog('[INNER] NtQueryDirectoryFile', 'Written entry: ' + EntryName); 496 | end; 497 | 498 | if StructConvertResult <> TOO_SMALL_BUF then begin 499 | with PFILE_ID_BOTH_DIR_INFORMATION(BufCaret)^ do begin 500 | NextEntryOffset := 0; 501 | FileIndex := 0; 502 | end; 503 | end; 504 | 505 | if StructConvertResult = TOO_SMALL_BUF then begin 506 | OpenedFile.DirListing.SeekRel(-1); 507 | 508 | if IsFirstEntry then begin 509 | result := STATUS_INFO_LENGTH_MISMATCH; 510 | end; 511 | end else if StructConvertResult = TRUNCATED_NAME then begin 512 | if IsFirstEntry then begin 513 | result := STATUS_BUFFER_OVERFLOW; 514 | Inc(int(Io.Information), BytesWritten); 515 | end else begin 516 | OpenedFile.DirListing.SeekRel(-1); 517 | end; 518 | end else if StructConvertResult = COPIED_ALL then begin 519 | if PrevEntry <> nil then begin 520 | int(Io.Information) := int(BufCaret) - int(Buffer) + BytesWritten; 521 | end else begin 522 | int(Io.Information) := BytesWritten; 523 | end; 524 | end; // .else 525 | 526 | if (BytesWritten > 0) and (PrevEntry <> nil) then begin 527 | PrevEntry.NextEntryOffset := cardinal(int(BufCaret) - int(PrevEntry)); 528 | end; 529 | 530 | PrevEntry := BufCaret; 531 | 532 | if SingleEntry then begin 533 | BytesWritten := 0; 534 | end; 535 | end; // .while 536 | end; // .if 537 | 538 | Io.Status.Status := result; 539 | 540 | Leave; 541 | end; // .else 542 | end; // .with 543 | 544 | if VfsDebug.LoggingEnabled then begin 545 | WriteLog('[LEAVE] NtQueryDirectoryFile', Format('Handle: %x. Status: %x. Written: %d bytes', [int(FileHandle), int(result), int(Io.Information)])); 546 | end; 547 | end; // .function Hook_NtQueryDirectoryFile 548 | 549 | function Hook_NtQueryDirectoryFileEx (OrigFunc: WinNative.TNtQueryDirectoryFileEx; FileHandle: HANDLE; Event: HANDLE; ApcRoutine: pointer; ApcContext: PVOID; Io: PIO_STATUS_BLOCK; 550 | Buffer: PVOID; BufLength: ULONG; InfoClass: integer (* FILE_INFORMATION_CLASS *); QueryFlags: integer; Mask: PUNICODE_STRING): NTSTATUS; stdcall; 551 | var 552 | SingleEntry: LONGBOOL; 553 | RestartScan: LONGBOOL; 554 | 555 | begin 556 | if VfsDebug.LoggingEnabled then begin 557 | WriteLog('NtQueryDirectoryFileEx', Format('Handle: %x. QueryFlags: %x', [FileHandle, QueryFlags])); 558 | end; 559 | 560 | RestartScan := Utils.Flags(QueryFlags).Have(WinNative.SL_RESTART_SCAN); 561 | SingleEntry := Utils.Flags(QueryFlags).Have(WinNative.SL_RETURN_SINGLE_ENTRY); 562 | result := WinNative.NtQueryDirectoryFile(FileHandle, Event, ApcRoutine, ApcContext, Io, Buffer, BufLength, InfoClass, SingleEntry, Mask, RestartScan); 563 | end; 564 | 565 | procedure InstallHooks; 566 | var 567 | SetProcessDEPPolicy: function (dwFlags: integer): LONGBOOL; stdcall; 568 | hDll: Windows.THandle; 569 | NtdllHandle: integer; 570 | NtQueryDirectoryFileExAddr: WinNative.TNtQueryDirectoryFileEx; 571 | 572 | begin 573 | with HooksCritSection do begin 574 | Enter; 575 | 576 | if not HooksInstalled then begin 577 | HooksInstalled := true; 578 | 579 | (* Trying to turn off DEP *) 580 | SetProcessDEPPolicy := Windows.GetProcAddress(Windows.GetModuleHandle('kernel32.dll'), 'SetProcessDEPPolicy'); 581 | 582 | if @SetProcessDEPPolicy <> nil then begin 583 | if SetProcessDEPPolicy(0) then begin 584 | WriteLog('SetProcessDEPPolicy', 'DEP was turned off'); 585 | end else begin 586 | WriteLog('SetProcessDEPPolicy', 'Failed to turn DEP off'); 587 | end; 588 | end; 589 | 590 | // Ensure, that library with VFS hooks installed is never unloaded 591 | if System.IsLibrary then begin 592 | WinNative.GetModuleHandleExW(WinNative.GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS or WinNative.GET_MODULE_HANDLE_EX_FLAG_PIN, @InstallHooks, hDll); 593 | end; 594 | 595 | NtdllHandle:= Windows.GetModuleHandle('ntdll.dll'); 596 | {!} Assert(NtdllHandle <> 0, 'Failed to load ntdll.dll library'); 597 | 598 | WriteLog('InstallHook', 'Installing NtQueryAttributesFile hook'); 599 | NativeNtQueryAttributesFile := VfsPatching.SpliceWinApi 600 | ( 601 | VfsApiDigger.GetRealProcAddress(NtdllHandle, 'NtQueryAttributesFile'), 602 | @Hook_NtQueryAttributesFile, 603 | @NtQueryAttributesFilePatch 604 | ); 605 | 606 | WriteLog('InstallHook', 'Installing NtQueryFullAttributesFile hook'); 607 | NativeNtQueryFullAttributesFile := VfsPatching.SpliceWinApi 608 | ( 609 | VfsApiDigger.GetRealProcAddress(NtdllHandle, 'NtQueryFullAttributesFile'), 610 | @Hook_NtQueryFullAttributesFile, 611 | @NtQueryFullAttributesFilePatch 612 | ); 613 | 614 | WriteLog('InstallHook', 'Installing NtOpenFile hook'); 615 | NativeNtOpenFile := VfsPatching.SpliceWinApi 616 | ( 617 | VfsApiDigger.GetRealProcAddress(NtdllHandle, 'NtOpenFile'), 618 | @Hook_NtOpenFile, 619 | @NtOpenFilePatch 620 | ); 621 | 622 | WriteLog('InstallHook', 'Installing NtCreateFile hook'); 623 | NativeNtCreateFile := VfsPatching.SpliceWinApi 624 | ( 625 | VfsApiDigger.GetRealProcAddress(NtdllHandle, 'NtCreateFile'), 626 | @Hook_NtCreateFile, 627 | @NtCreateFilePatch 628 | ); 629 | 630 | WriteLog('InstallHook', 'Installing NtClose hook'); 631 | NativeNtClose := VfsPatching.SpliceWinApi 632 | ( 633 | VfsApiDigger.GetRealProcAddress(NtdllHandle, 'NtClose'), 634 | @Hook_NtClose, 635 | @NtClosePatch 636 | ); 637 | 638 | WriteLog('InstallHook', 'Installing NtQueryDirectoryFile hook'); 639 | NativeNtQueryDirectoryFile := VfsPatching.SpliceWinApi 640 | ( 641 | VfsApiDigger.GetRealProcAddress(NtdllHandle, 'NtQueryDirectoryFile'), 642 | @Hook_NtQueryDirectoryFile, 643 | @NtQueryDirectoryFilePatch 644 | ); 645 | 646 | NtQueryDirectoryFileExAddr := VfsApiDigger.GetRealProcAddress(NtdllHandle, 'NtQueryDirectoryFileEx'); 647 | 648 | if @NtQueryDirectoryFileExAddr <> nil then begin 649 | WriteLog('InstallHook', 'Installing NtQueryDirectoryFileEx hook'); 650 | NativeNtQueryDirectoryFileEx := VfsPatching.SpliceWinApi 651 | ( 652 | @NtQueryDirectoryFileExAddr, 653 | @Hook_NtQueryDirectoryFileEx, 654 | @NtQueryDirectoryFileExPatch 655 | ); 656 | end; 657 | end; // .if 658 | 659 | Leave; 660 | end; // .with 661 | end; // .procedure InstallHooks 662 | 663 | procedure UninstallHooks; 664 | begin 665 | with HooksCritSection do begin 666 | Enter; 667 | 668 | NtQueryAttributesFilePatch.Rollback; 669 | NtQueryFullAttributesFilePatch.Rollback; 670 | NtOpenFilePatch.Rollback; 671 | NtCreateFilePatch.Rollback; 672 | NtClosePatch.Rollback; 673 | NtQueryDirectoryFilePatch.Rollback; 674 | NtQueryDirectoryFileExPatch.Rollback; 675 | 676 | Leave; 677 | end; 678 | end; 679 | 680 | initialization 681 | System.IsMultiThread := true; 682 | HooksCritSection.Init; 683 | finalization 684 | with VfsBase.VfsCritSection do begin 685 | Enter; 686 | VfsBase.ResetVfs; 687 | UninstallHooks; 688 | Leave; 689 | end; 690 | end. --------------------------------------------------------------------------------