From 933e71456640b401f0bef21d0baf35f34da6458c Mon Sep 17 00:00:00 2001 From: Berserker Date: Tue, 30 Apr 2019 17:26:37 +0300 Subject: [PATCH] Initial commit --- .gitignore | 5 + Tests/VfsDebugTest.pas | 69 ++++++ Vfs.dpr | 18 ++ Vfs.dproj | 47 ++++ VfsBase.pas | 441 +++++++++++++++++++++++++++++++++++++ VfsDebug.pas | 98 +++++++++ VfsExport.pas | 20 ++ VfsTest.dpr | 11 + VfsTest.dproj | 48 ++++ VfsTest.dproj.local | 2 + VfsUtils.pas | 481 +++++++++++++++++++++++++++++++++++++++++ 11 files changed, 1240 insertions(+) create mode 100644 .gitignore create mode 100644 Tests/VfsDebugTest.pas create mode 100644 Vfs.dpr create mode 100644 Vfs.dproj create mode 100644 VfsBase.pas create mode 100644 VfsDebug.pas create mode 100644 VfsExport.pas create mode 100644 VfsTest.dpr create mode 100644 VfsTest.dproj create mode 100644 VfsTest.dproj.local create mode 100644 VfsUtils.pas diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..0a7db6d --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +*.dcu +*.exe +*.ini +*.identcache +__history/ \ No newline at end of file diff --git a/Tests/VfsDebugTest.pas b/Tests/VfsDebugTest.pas new file mode 100644 index 0000000..652c891 --- /dev/null +++ b/Tests/VfsDebugTest.pas @@ -0,0 +1,69 @@ +unit VfsDebugTest; +{$ASSERTIONS ON} + +(***) interface (***) + +uses + SysUtils, TestFramework, + Utils, VfsDebug; + +type + TestDebug = class (TTestCase) + published + procedure TestAssertHandler; + procedure TestLogging; + end; + +(***) implementation (***) + + +var + LogContents: string; + +procedure ClearLog; +begin + LogContents := ''; +end; + +function GetLog: string; +begin + result := LogContents; +end; + +procedure WriteLog (const Operation, Message: pchar); stdcall; +begin + LogContents := LogContents + Operation + ';' + Message; +end; + +procedure TestDebug.TestAssertHandler (); +var + Raised: boolean; + +begin + Raised := false; + + try + System.Assert(false, 'Some assertion message'); + except + on E: VfsDebug.EAssertFailure do Raised := true; + end; + + Check(Raised, 'Assertion should raise EAssertFailure exception'); +end; + +procedure TestDebug.TestLogging; +begin + ClearLog; + VfsDebug.SetLoggingProc(@WriteLog); + VfsDebug.WriteLog('TestOperation', 'TestMessage'); + Check(GetLog() = 'TestOperation;TestMessage', 'Custom logging proc should have written certain message to log'); + + ClearLog; + VfsDebug.SetLoggingProc(nil); + VfsDebug.WriteLog('TestOperation', 'TestMessage'); + Check(GetLog() = '', 'Nil logging proc must not write anything to log'); +end; + +begin + RegisterTest(TestDebug.Suite); +end. \ No newline at end of file diff --git a/Vfs.dpr b/Vfs.dpr new file mode 100644 index 0000000..06a6dfb --- /dev/null +++ b/Vfs.dpr @@ -0,0 +1,18 @@ +library Vfs; +(* + Author: Alexander Shostak aka Berserker aka EtherniDee. +*) + +uses Windows; + +procedure DLLEntryPoint (Reason: DWORD); +begin + // Stop VFS globally!!!!!!!!! +end; + +begin + if System.DllProc = nil then begin + System.DllProc := @DLLEntryPoint; + DllEntryPoint(Windows.DLL_PROCESS_ATTACH); + end; +end. diff --git a/Vfs.dproj b/Vfs.dproj new file mode 100644 index 0000000..1d40729 --- /dev/null +++ b/Vfs.dproj @@ -0,0 +1,47 @@ + + + {e3e35df4-690f-11e9-a923-1681be663d3e} + Vfs.dpr + Debug + AnyCPU + DCC32 + Vfs.dll + + + 7.0 + False + False + 0 + RELEASE + + + 7.0 + DEBUG + False + True + False + ..\Lib\B2;.\Png + ..\Lib\B2;.\Png + ..\Lib\B2;.\Png + ..\Lib\B2;.\Png + 3 + + + Delphi.Personality + VCLApplication + +FalseTrueFalseFalseFalse1000FalseFalseFalseFalseFalse104912511.0.0.01.0.0.0Vfs.dpr + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + + + MainSource + + + + \ No newline at end of file diff --git a/VfsBase.pas b/VfsBase.pas new file mode 100644 index 0000000..9b51d23 --- /dev/null +++ b/VfsBase.pas @@ -0,0 +1,441 @@ +unit VfsBase; +(* + Description: Implements in-memory virtual file system data storage. + Author: Alexander Shostak (aka Berserker aka EtherniDee aka BerSoft) + TODO: Use optimized hash-table storage for VfsItems instead of ansi-to-wide string keys in regular binary tree. +*) + + +(***) interface (***) + +uses + SysUtils, Math, Windows, + Utils, WinNative, Alg, Concur, TypeWrappers, Lists, DataLib, + StrLib, + VfsUtils; + +type + (* Import *) + TDict = DataLib.TDict; + TObjDict = DataLib.TObjDict; + TString = TypeWrappers.TString; + TList = Lists.TList; + +const + AUTO_PRIORITY = MAXLONGINT div 2; + INITIAL_OVERWRITING_PRIORITY = AUTO_PRIORITY + 1; + INITIAL_ADDING_PRIORITY = AUTO_PRIORITY - 1; + +type + (* + Specifies the order, in which files from different mapped directories will be listed in virtual directory. + Virtual directory sorting is performed by priorities firstly and lexicographically secondly. + SORT_FIFO - Items of the first mapped directory will be listed before the second mapped directory items. + SORT_LIFO - Items of The last mapped directory will be listed before all other mapped directory items. + *) + TDirListingSortType = (SORT_FIFO, SORT_LIFO); + + (* Single redirected VFS entry: file or directory *) + TVfsItem = class + private + function GetName: WideString; inline; + procedure SetName (const NewName: WideString); inline; + + public + (* Name in lower case, used for wildcard mask matching *) + SearchName: WideString; + + (* Absolute path to real file/folder location without trailing slash for non-drives *) + RealPath: WideString; + + (* The priority used in virtual directories sorting for listing *) + Priority: integer; + + (* List of directory child items or nil *) + {On} Children: {U} TList {OF TVfsItem}; + + (* Up to 32 special non-Windows attribute flags *) + Attrs: integer; + + (* Full file info *) + Info: TNativeFileInfo; + + function IsDir (): boolean; + + destructor Destroy; override; + + (* Name in original case. Automatically sets/converts SearchName, Info.FileName, Info.Base.FileNameLength *) + property Name: WideString read GetName write SetName; + end; // .class TVfsItem + + (* Allows to disable VFS temporarily for current thread only *) + TThreadVfsDisabler = record + PrevDisableVfsForThisThread: boolean; + + procedure DisableVfsForThread; + procedure RestoreVfsForThread; + end; + + +function GetThreadVfsDisabler: TThreadVfsDisabler; +procedure RunVfs (DirListingOrder: TDirListingSortType); +function ResetVfs: boolean; + + +(* Maps real directory contents to virtual path. Target must exist for success *) +function MapDir (const VirtPath, RealPath: WideString; OverwriteExisting: boolean; Flags: integer = 0): boolean; + + +(***) implementation (***) + + +var +(* + Global map of case-insensitive normalized path to file/directory => corresponding TVfsItem. + Access is controlled via critical section and global/thread switchers. + Represents the whole cached virtual file system contents. +*) +{O} VfsItems: {O} TDict {OF TVfsItem}; + + (* Global VFS access synchronizer *) + VfsCritSection: Concur.TCritSection; + + (* Global VFS state indicator. If false, all VFS search operations must fail *) + VfsIsRunning: boolean = false; + + (* Automatical VFS items priority management *) + OverwritingPriority: integer = INITIAL_OVERWRITING_PRIORITY; + AddingPriority: integer = INITIAL_ADDING_PRIORITY; + +// All threadvar variables are automatically zeroed during finalization, thus zero must be the safest default value +threadvar + DisableVfsForThisThread: boolean; + +function TVfsItem.IsDir: boolean; +begin + result := (Self.Info.Base.FileAttributes and Windows.FILE_ATTRIBUTE_DIRECTORY) <> 0; +end; + +function TVfsItem.GetName: WideString; +begin + result := Self.Info.FileName; +end; + +procedure TVfsItem.SetName (const NewName: WideString); +begin + Self.Info.SetFileName(NewName); + Self.SearchName := StrLib.WideLowerCase(NewName); +end; + +destructor TVfsItem.Destroy; +begin + SysUtils.FreeAndNil(Self.Children); +end; + +procedure TThreadVfsDisabler.DisableVfsForThread; +begin + Self.PrevDisableVfsForThisThread := DisableVfsForThisThread; + DisableVfsForThisThread := true; +end; + +procedure TThreadVfsDisabler.RestoreVfsForThread; +begin + DisableVfsForThisThread := Self.PrevDisableVfsForThisThread; +end; + +function GetThreadVfsDisabler: TThreadVfsDisabler; +begin +end; + +function EnterVfs: boolean; +begin + result := not DisableVfsForThisThread; + + if result then begin + VfsCritSection.Enter; + result := VfsIsRunning; + + if not result then begin + VfsCritSection.Leave; + end; + end; +end; + +procedure LeaveVfs; +begin + VfsCritSection.Leave; +end; + +(* Packs lower cased WideString bytes into AnsiString buffer *) +function WideStrToCaselessKey (const Str: WideString): string; +var + ProcessedPath: WideString; + +begin + result := ''; + + if Str <> '' then begin + ProcessedPath := StrLib.WideLowerCase(Str); + SetLength(result, Length(ProcessedPath) * sizeof(ProcessedPath[1]) div sizeof(result[1])); + Utils.CopyMem(Length(result) * sizeof(result[1]), PWideChar(ProcessedPath), PChar(result)); + end; +end; + +(* The opposite of WideStrToKey *) +function UnpackPath (const PackedPath: string): WideString; +begin + result := ''; + + if PackedPath <> '' then begin + SetLength(result, Length(PackedPath) * sizeof(PackedPath[1]) div sizeof(result[1])); + Utils.CopyMem(Length(result) * sizeof(result[1]), pchar(PackedPath), PWideChar(result)); + end; +end; + +function CompareVfsItemsByPriorityDescAndNameAsc (Item1, Item2: integer): integer; +begin + result := TVfsItem(Item2).Priority - TVfsItem(Item1).Priority; + + if result = 0 then begin + result := StrLib.CompareBinStringsW(TVfsItem(Item1).SearchName, TVfsItem(Item2).SearchName); + end; +end; + +function CompareVfsItemsByPriorityAscAndNameAsc (Item1, Item2: integer): integer; +begin + result := TVfsItem(Item1).Priority - TVfsItem(Item2).Priority; + + if result = 0 then begin + result := StrLib.CompareBinStringsW(TVfsItem(Item1).SearchName, TVfsItem(Item2).SearchName); + end; +end; + +procedure SortVfsListing ({U} List: DataLib.TList {OF TVfsItem}; SortType: TDirListingSortType); +begin + if SortType = SORT_FIFO then begin + List.CustomSort(CompareVfsItemsByPriorityDescAndNameAsc); + end else begin + List.CustomSort(CompareVfsItemsByPriorityAscAndNameAsc); + end; +end; + +procedure SortVfsDirListings (SortType: TDirListingSortType); +var +{Un} Children: DataLib.TList {OF TVfsItem}; + +begin + Children := nil; + // * * * * * // + with DataLib.IterateDict(VfsItems) do begin + while IterNext() do begin + Children := TVfsItem(IterValue).Children; + + if (Children <> nil) and (Children.Count > 1) then begin + SortVfsListing(Children, SortType); + end; + end; + end; +end; // .procedure SortVfsDirListings + +function FindVfsItemByNormalizedPath (const Path: WideString; {U} var {OUT} Res: TVfsItem): boolean; +var +{Un} VfsItem: TVfsItem; + +begin + VfsItem := VfsItems[WideStrToCaselessKey(Path)]; + result := VfsItem <> nil; + + if result then begin + Res := VfsItem; + end; +end; + +function FindVfsItemByPath (const Path: WideString; {U} var {OUT} Res: TVfsItem): boolean; +begin + result := FindVfsItemByNormalizedPath(NormalizePath(Path), Res); +end; + +(* All children list of VFS items MUST be empty *) +procedure BuildVfsItemsTree; +var +{Un} DirVfsItem: TVfsItem; + AbsDirPath: WideString; + +begin + DirVfsItem := nil; + // * * * * * // + with DataLib.IterateDict(VfsItems) do begin + while IterNext() do begin + AbsDirPath := StrLib.ExtractDirPathW(UnpackPath(IterKey)); + + if FindVfsItemByNormalizedPath(AbsDirPath, DirVfsItem) then begin + DirVfsItem.Children.Add(IterValue); + end; + end; + end; +end; // .procedure BuildVfsItemsTree + +procedure RunVfs (DirListingOrder: TDirListingSortType); +begin + with VfsCritSection do begin + Enter; + + if not VfsIsRunning then begin + BuildVfsItemsTree(); + SortVfsDirListings(DirListingOrder); + VfsIsRunning := true; + end; + + Leave; + end; +end; // .procedure RunVfs + +function ResetVfs: boolean; +begin + result := EnterVfs; + + if result then begin + VfsIsRunning := false; + VfsItems.Clear(); + LeaveVfs; + end; +end; + +procedure CopyFileInfoWithoutNames (var Src, Dest: WinNative.FILE_ID_BOTH_DIR_INFORMATION); +begin + Dest.FileIndex := 0; + Dest.CreationTime := Src.CreationTime; + Dest.LastAccessTime := Src.LastAccessTime; + Dest.LastWriteTime := Src.LastWriteTime; + Dest.ChangeTime := Src.ChangeTime; + Dest.EndOfFile := Src.EndOfFile; + Dest.AllocationSize := Src.AllocationSize; + Dest.FileAttributes := Src.FileAttributes; + Dest.EaSize := Src.EaSize; +end; + +(* Redirects single file/directory path (not including directory contents). Target must exist for success *) +function RedirectFile (const AbsVirtPath, AbsRealPath: WideString; {n} FileInfoPtr: WinNative.PFILE_ID_BOTH_DIR_INFORMATION; OverwriteExisting: boolean; Priority: integer): {Un} TVfsItem; +const + WIDE_NULL_CHAR_LEN = Length(#0); + +var +{Un} VfsItem: TVfsItem; + PackedVirtPath: string; + IsNewItem: boolean; + FileInfo: TNativeFileInfo; + Success: boolean; + +begin + VfsItem := nil; + result := nil; + // * * * * * // + PackedVirtPath := WideStrToCaselessKey(AbsVirtPath); + VfsItem := VfsItems[PackedVirtPath]; + IsNewItem := VfsItem = nil; + Success := true; + + if IsNewItem or OverwriteExisting then begin + if FileInfoPtr = nil then begin + Success := GetFileInfo(AbsRealPath, FileInfo); + end; + + if Success then begin + if IsNewItem then begin + VfsItem := TVfsItem.Create(); + VfsItems[PackedVirtPath] := VfsItem; + VfsItem.Name := StrLib.ExtractFileNameW(AbsVirtPath); + VfsItem.SearchName := StrLib.WideLowerCase(VfsItem.Name); + VfsItem.Info.Base.ShortNameLength := 0; + VfsItem.Info.Base.ShortName[0] := #0; + end; + + if FileInfoPtr <> nil then begin + CopyFileInfoWithoutNames(FileInfoPtr^, VfsItem.Info.Base); + end else begin + CopyFileInfoWithoutNames(FileInfo.Base, VfsItem.Info.Base); + end; + + VfsItem.RealPath := AbsRealPath; + VfsItem.Priority := Priority; + VfsItem.Attrs := 0; + end; // .if + end; // .if + + if Success then begin + result := VfsItem; + end; +end; // .function RedirectFile + +function _MapDir (const AbsVirtPath, AbsRealPath: WideString; {n} FileInfoPtr: WinNative.PFILE_ID_BOTH_DIR_INFORMATION; OverwriteExisting: boolean; Priority: integer): {Un} TVfsItem; +var +{O} Subdirs: {O} TList {OF TFileInfo}; +{U} SubdirInfo: TFileInfo; +{Un} DirVfsItem: TVfsItem; + Success: boolean; + FileInfo: TNativeFileInfo; + VirtPathPrefix: WideString; + RealPathPrefix: WideString; + i: integer; + +begin + DirVfsItem := nil; + Subdirs := DataLib.NewList(Utils.OWNS_ITEMS); + SubdirInfo := nil; + result := nil; + // * * * * * // + if Priority = AUTO_PRIORITY then begin + if OverwriteExisting then begin + Priority := OverwritingPriority; + Inc(OverwritingPriority); + end else begin + Priority := AddingPriority; + Dec(AddingPriority); + end; + end; + + DirVfsItem := RedirectFile(AbsVirtPath, AbsRealPath, FileInfoPtr, OverwriteExisting, Priority); + Success := DirVfsItem <> nil; + + if Success then begin + VirtPathPrefix := AbsVirtPath + '\'; + RealPathPrefix := AbsRealPath + '\'; + + if DirVfsItem.Children = nil then begin + DirVfsItem.Children := DataLib.NewList(not Utils.OWNS_ITEMS); + end; + + with SysScanDir(AbsRealPath, '*') do begin + while IterNext(FileInfo.FileName, @FileInfo.Base) do begin + if Utils.HasFlag(FileInfo.Base.FileAttributes, Windows.FILE_ATTRIBUTE_DIRECTORY) then begin + if (FileInfo.FileName <> '.') and (FileInfo.FileName <> '..') then begin + Subdirs.Add(TFileInfo.Create(@FileInfo)); + end; + end else begin + RedirectFile(VirtPathPrefix + FileInfo.FileName, RealPathPrefix + FileInfo.FileName, @FileInfo, OverwriteExisting, Priority); + end; + end; + end; + + for i := 0 to Subdirs.Count - 1 do begin + SubdirInfo := TFileInfo(Subdirs[i]); + _MapDir(VirtPathPrefix + SubdirInfo.Data.FileName, RealPathPrefix + SubdirInfo.Data.FileName, @SubdirInfo.Data, OverwriteExisting, Priority); + end; + end; // .if + + if Success then begin + result := DirVfsItem; + end; + // * * * * * // + SysUtils.FreeAndNil(Subdirs); +end; // .function _MapDir + +function MapDir (const VirtPath, RealPath: WideString; OverwriteExisting: boolean; Flags: integer = 0): boolean; +begin + result := _MapDir(NormalizePath(VirtPath), NormalizePath(RealPath), nil, OverwriteExisting, AUTO_PRIORITY) <> nil; +end; + +begin + VfsCritSection.Init; + VfsItems := DataLib.NewDict(Utils.OWNS_ITEMS, DataLib.CASE_SENSITIVE); +end. \ No newline at end of file diff --git a/VfsDebug.pas b/VfsDebug.pas new file mode 100644 index 0000000..1e942cf --- /dev/null +++ b/VfsDebug.pas @@ -0,0 +1,98 @@ +unit VfsDebug; +(* + Author: Alexander Shostak aka Berserker aka Ethernidee. + Description: Provides logging and debugging capabilities for VFS project. +*) + + +(***) interface (***) + +uses + Windows, SysUtils, + Utils, StrLib, Concur, DlgMes; + +type + TLoggingProc = procedure (Operation, Message: pchar); stdcall; + + EAssertFailure = class (Exception) + end; + + +function SetLoggingProc ({n} Handler: TLoggingProc): {n} TLoggingProc; stdcall; +procedure WriteLog (const Operation, Message: string); +procedure WriteLog_ (const Operation, Message: pchar); + + +var + (* For external non-100% reliable fast checks of logging subsystem state *) + LoggingEnabled: boolean = false; + + +(***) implementation (***) + + +var + LogCritSection: Concur.TCritSection; +{n} LoggingProc: TLoggingProc; + + +function SetLoggingProc ({n} Handler: TLoggingProc): {n} TLoggingProc; stdcall; +begin + with LogCritSection do begin + Enter; + result := @LoggingProc; + LoggingProc := Handler; + LoggingEnabled := @LoggingProc <> nil; + Leave; + end; +end; + +procedure WriteLog (const Operation, Message: string); +begin + WriteLog_(pchar(Operation), pchar(Message)); +end; + +procedure WriteLog_ (const Operation, Message: pchar); +begin + if LoggingEnabled then begin + with LogCritSection do begin + Enter; + + if @LoggingProc <> nil then begin + LoggingProc(Operation, Message); + end; + + Leave; + end; + end; +end; + +procedure AssertHandler (const Mes, FileName: string; LineNumber: integer; Address: pointer); +var + CrashMes: string; + +begin + CrashMes := StrLib.BuildStr + ( + 'Assert violation in file "~FileName~" on line ~Line~.'#13#10'Error at address: $~Address~.'#13#10'Message: "~Message~"', + [ + 'FileName', FileName, + 'Line', SysUtils.IntToStr(LineNumber), + 'Address', SysUtils.Format('%x', [integer(Address)]), + 'Message', Mes + ], + '~' + ); + + WriteLog('AssertHandler', CrashMes); + + DlgMes.MsgError(CrashMes); + + raise EAssertFailure.Create(CrashMes) at Address; +end; // .procedure AssertHandler + + +begin + LogCritSection.Init; + AssertErrorProc := AssertHandler; +end. \ No newline at end of file diff --git a/VfsExport.pas b/VfsExport.pas new file mode 100644 index 0000000..91579b2 --- /dev/null +++ b/VfsExport.pas @@ -0,0 +1,20 @@ +unit VfsExport; +(* + +*) + + +(***) interface (***) + +uses + VfsDebug; + +exports + VfsDebug.WriteLog_ name 'WriteLog', + VfsDebug.SetLoggingProc; + +(***) implementation (***) + +begin + +end. diff --git a/VfsTest.dpr b/VfsTest.dpr new file mode 100644 index 0000000..98be871 --- /dev/null +++ b/VfsTest.dpr @@ -0,0 +1,11 @@ +program VfsTest; + +uses + TestFramework, GuiTestRunner, + VfsUtils, VfsBase, VfsDebug, VfsExport, + VfsDebugTest; + +begin + TGUITestRunner.RunRegisteredTests; +end. + diff --git a/VfsTest.dproj b/VfsTest.dproj new file mode 100644 index 0000000..0c7f577 --- /dev/null +++ b/VfsTest.dproj @@ -0,0 +1,48 @@ + + + {c6015c7b-4070-47b6-8c8a-c2b54aba82d6} + VfsTest.dpr + Debug + AnyCPU + DCC32 + VfsTest.exe + + + 7.0 + False + False + 0 + RELEASE + + + 7.0 + DEBUG + False + ..\Lib\B2;.\Tests + ..\Lib\B2;.\Tests + ..\Lib\B2;.\Tests + ..\Lib\B2;.\Tests + + + Delphi.Personality + VCLApplication + +FalseTrueFalseFalseFalse1000FalseFalseFalseFalseFalse104912511.0.0.01.0.0.0VfsTest.dpr + + + + + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + + + + MainSource + + + \ No newline at end of file diff --git a/VfsTest.dproj.local b/VfsTest.dproj.local new file mode 100644 index 0000000..b3811b7 --- /dev/null +++ b/VfsTest.dproj.local @@ -0,0 +1,2 @@ + + diff --git a/VfsUtils.pas b/VfsUtils.pas new file mode 100644 index 0000000..bc19da0 --- /dev/null +++ b/VfsUtils.pas @@ -0,0 +1,481 @@ +unit VfsUtils; +(* + +*) + + +(***) interface (***) + +uses + SysUtils, Math, Windows, + Utils, WinNative, Alg, TypeWrappers, Lists, DataLib, + StrLib; + +type + (* Import *) + TDict = DataLib.TDict; + TObjDict = DataLib.TObjDict; + TString = TypeWrappers.TString; + TList = Lists.TList; + +const + MAX_FILENAME_SIZE = WinNative.MAX_FILENAME_LEN * sizeof(WideChar); + DRIVE_CHAR_INDEX_IN_NT_ABS_PATH = 5; // \??\D: + +type + TSysOpenFileMode = (OPEN_AS_ANY = 0, OPEN_AS_FILE = WinNative.FILE_NON_DIRECTORY_FILE, OPEN_AS_DIR = WinNative.FILE_DIRECTORY_FILE); + + (* WINNT widest file structre wrapper *) + PNativeFileInfo = ^TNativeFileInfo; + TNativeFileInfo = record + Base: WinNative.FILE_ID_BOTH_DIR_INFORMATION; + FileName: WideString; + + procedure SetFileName (const NewFileName: WideString); + function CopyFileNameToBuf ({ni} Buf: pbyte; BufSize: integer): boolean; + function GetFileSize: Int64; + end; + + (* TNativeFileInfo wrapper for dynamical data structures with memory manamement *) + TFileInfo = class + public + Data: TNativeFileInfo; + + constructor Create ({n} Data: PNativeFileInfo = nil); + end; + + (* Universal directory listing holder *) + TDirListing = class + private + {O} fFileList: {O} DataLib.TList {OF TFileInfo}; + fFileInd: integer; + + function GetCount: integer; + + public + constructor Create; + destructor Destroy; override; + + function IsEnd: boolean; + procedure AddItem ({U} FileInfo: PNativeFileInfo; const FileName: WideString = ''; const InsertBefore: integer = High(integer)); + function GetNextItem ({OUT} var Res: TFileInfo): boolean; + procedure Rewind; + + (* Always seeks as close as possible *) + function Seek (SeekInd: integer): boolean; + function SeekRel (RelInd: integer): boolean; + + property FileInd: integer read fFileInd; + property Count: integer read GetCount; + end; // .class TDirListing + + ISysDirScanner = interface + function IterNext ({OUT} var FileName: WideString; {n} FileInfo: WinNative.PFILE_ID_BOTH_DIR_INFORMATION = nil): boolean; + end; + + TSysDirScanner = class (Utils.TManagedObject, ISysDirScanner) + protected const + BUF_SIZE = (sizeof(WinNative.FILE_ID_BOTH_DIR_INFORMATION) + MAX_FILENAME_SIZE) * 10; + + protected + fOwnsDirHandle: boolean; + fDirHandle: Windows.THandle; + fMask: WideString; + fMaskU: WinNative.UNICODE_STRING; + fIsStart: boolean; + fIsEnd: boolean; + fBufPos: integer; + fBuf: array [0..BUF_SIZE - 1] of byte; + + public + constructor Create (const hDir: Windows.THandle; const Mask: WideString); overload; + constructor Create (const DirPath, Mask: WideString); overload; + destructor Destroy; override; + + function IterNext ({OUT} var FileName: WideString; {n} FileInfo: WinNative.PFILE_ID_BOTH_DIR_INFORMATION = nil): boolean; + end; // .class TSysDirScanner + + +(* Returns expanded unicode path, preserving trailing delimiter, or original path on error *) +function ExpandPath (const Path: WideString): WideString; + +(* Returns expanded path without trailing delimiter (for non-drives). Optionally returns flag, whether path had trailing delim or not. + The flag is false for drives *) +function NormalizePath (const Path: WideString; {n} HadTrailingDelim: pboolean = nil): WideString; + +(* Returns absolute normalized path with nt path prefix '\??\' (unless path already begins with '\' character). + Optionally returns flag, whether path had trailing delim or not. *) +function ToNtAbsPath (const Path: WideString; {n} HadTrailingDelim: pboolean = nil): WideString; + +(* Return true if path is valid absolute path to root drive like '\??\X:' with any/zero number of trailing slashes *) +function IsNtRootDriveAbsPath (const Path: WideString): boolean; + +(* Removes optional leading \??\ prefix from path *) +function StripNtAbsPathPrefix (const Path: WideString): WideString; + +(* Saves API result in external variable and returns result as is *) +function SaveAndRet (Res: integer; out ResCopy): integer; + +(* Opens file/directory using absolute NT path and returns success flag *) +function SysOpenFile (const NtAbsPath: WideString; {OUT} var Res: Windows.THandle; const OpenMode: TSysOpenFileMode = OPEN_AS_ANY; const AccessMode: integer = Int(GENERIC_READ) or SYNCHRONIZE): boolean; + +(* Returns TNativeFileInfo record for single file/directory. Short names and files indexes/ids in the result are always empty. *) +function GetFileInfo (const FilePath: WideString; {OUT} var Res: TNativeFileInfo): boolean; + +function SysScanDir (const hDir: Windows.THandle; const Mask: WideString): ISysDirScanner; overload; +function SysScanDir (const DirPath, Mask: WideString): ISysDirScanner; overload; + +(***) implementation (***) + + +function ExpandPath (const Path: WideString): WideString; +var + BufLen: integer; + NumCharsCopied: integer; + FileNameAddr: PWideChar; + +begin + result := ''; + + if Path <> '' then begin + BufLen := 0; + NumCharsCopied := Windows.GetFullPathNameW(PWideChar(Path), 0, nil, FileNameAddr); + + while NumCharsCopied > BufLen do begin + BufLen := NumCharsCopied; + SetLength(result, BufLen - 1); + NumCharsCopied := Windows.GetFullPathNameW(PWideChar(Path), BufLen, PWideChar(result), FileNameAddr); + end; + + if NumCharsCopied <= 0 then begin + result := Path; + end else begin + SetLength(result, NumCharsCopied); + end; + end; // .if +end; // .function ExpandPath + +function NormalizePath (const Path: WideString; {n} HadTrailingDelim: pboolean = nil): WideString; +begin + result := StrLib.ExcludeTrailingDelimW(ExpandPath(Path), HadTrailingDelim); + + if (Length(result) = 2) and (result[1] = ':') then begin + result := result + '\'; + + if HadTrailingDelim <> nil then begin + HadTrailingDelim^ := false; + end; + end; +end; + +function ToNtAbsPath (const Path: WideString; {n} HadTrailingDelim: pboolean = nil): WideString; +begin + result := NormalizePath(Path, HadTrailingDelim); + + if (result <> '') and (result[1] <> '\') then begin + result := '\??\' + result; + end; +end; + +function IsNtRootDriveAbsPath (const Path: WideString): boolean; +const + MIN_VALID_LEN = Length('\??\X:'); + +var + i: integer; + +begin + 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] = ':'); + + if result then begin + for i := MIN_VALID_LEN + 1 to Length(Path) do begin + if Path[i] <> '\' then begin + result := false; + exit; + end; + end; + end; +end; // .function IsNtRootDriveAbsPath + +function StripNtAbsPathPrefix (const Path: WideString): WideString; +begin + result := Path; + + if (Length(Path) >= 4) and (Path[1] = '\') and (Path[2] = '?') and (Path[3] = '?') and (Path[4] = '\') then begin + result := Copy(Path, 4 + 1); + end; +end; + +function SaveAndRet (Res: integer; out ResCopy): integer; +begin + integer(ResCopy) := Res; + result := Res; +end; + +procedure TNativeFileInfo.SetFileName (const NewFileName: WideString); +begin + Self.FileName := NewFileName; + Self.Base.FileNameLength := Length(NewFileName) * sizeof(WideChar); +end; + +function TNativeFileInfo.CopyFileNameToBuf ({ni} Buf: pbyte; BufSize: integer): boolean; +begin + {!} Assert(Utils.IsValidBuf(Buf, BufSize)); + result := integer(Self.Base.FileNameLength) <= BufSize; + + if BufSize > 0 then begin + Utils.CopyMem(Self.Base.FileNameLength, PWideChar(Self.FileName), Buf); + end; +end; + +function TNativeFileInfo.GetFileSize: Int64; +begin + result := Self.Base.EndOfFile.QuadPart; +end; + +constructor TFileInfo.Create ({n} Data: PNativeFileInfo = nil); +begin + if Data <> nil then begin + Self.Data := Data^; + end; +end; + +constructor TDirListing.Create; +begin + Self.fFileList := DataLib.NewList(Utils.OWNS_ITEMS); + Self.fFileInd := 0; +end; + +destructor TDirListing.Destroy; +begin + SysUtils.FreeAndNil(Self.fFileList); +end; + +procedure TDirListing.AddItem (FileInfo: PNativeFileInfo; const FileName: WideString = ''; const InsertBefore: integer = High(integer)); +var +{O} Item: TFileInfo; + +begin + {!} Assert(FileInfo <> nil); + // * * * * * // + Item := TFileInfo.Create(FileInfo); + + if FileName <> '' then begin + Item.Data.SetFileName(FileName); + end; + + if InsertBefore >= Self.fFileList.Count then begin + Self.fFileList.Add(Item); Item := nil; + end else begin + Self.fFileList.Insert(Item, InsertBefore); Item := nil; + end; + // * * * * * // + SysUtils.FreeAndNil(Item); +end; // .procedure TDirListing.AddItem + +function TDirListing.GetCount: integer; +begin + result := Self.fFileList.Count; +end; + +function TDirListing.IsEnd: boolean; +begin + result := Self.fFileInd >= Self.fFileList.Count; +end; + +function TDirListing.GetNextItem ({OUT} var Res: TFileInfo): boolean; +begin + result := Self.fFileInd < Self.fFileList.Count; + + if result then begin + Res := TFileInfo(Self.fFileList[Self.fFileInd]); + Inc(Self.fFileInd); + end; +end; + +procedure TDirListing.Rewind; +begin + Self.fFileInd := 0; +end; + +function TDirListing.Seek (SeekInd: integer): boolean; +begin + Self.fFileInd := Alg.ToRange(SeekInd, 0, Self.fFileList.Count - 1); + result := Self.fFileInd = SeekInd; +end; + +function TDirListing.SeekRel (RelInd: integer): boolean; +begin + result := Self.Seek(Self.fFileInd + RelInd); +end; + +function SysOpenFile (const NtAbsPath: WideString; {OUT} var Res: Windows.THandle; const OpenMode: TSysOpenFileMode = OPEN_AS_ANY; const AccessMode: integer = Int(GENERIC_READ) or SYNCHRONIZE): boolean; +var + FilePathU: WinNative.UNICODE_STRING; + hFile: Windows.THandle; + ObjAttrs: WinNative.OBJECT_ATTRIBUTES; + IoStatusBlock: WinNative.IO_STATUS_BLOCK; + +begin + FilePathU.AssignExistingStr(NtAbsPath); + ObjAttrs.Init(@FilePathU); + + result := WinNative.NtOpenFile(@hFile, AccessMode, @ObjAttrs, @IoStatusBlock, FILE_SHARE_READ or FILE_SHARE_WRITE, ord(OpenMode) or FILE_SYNCHRONOUS_IO_NONALERT) = WinNative.STATUS_SUCCESS; + + if result then begin + Res := hFile; + end; +end; // .function SysOpenFile + +function GetFileInfo (const FilePath: WideString; {OUT} var Res: TNativeFileInfo): boolean; +const + BUF_SIZE = sizeof(WinNative.FILE_ALL_INFORMATION) + MAX_FILENAME_SIZE; + +var +{U} FileAllInfo: WinNative.PFILE_ALL_INFORMATION; + NtAbsPath: WideString; + hFile: Windows.THandle; + Buf: array [0..BUF_SIZE - 1] of byte; + IoStatusBlock: WinNative.IO_STATUS_BLOCK; + +begin + FileAllInfo := @Buf; + // * * * * * // + NtAbsPath := ToNtAbsPath(FilePath); + result := SysOpenFile(NtAbsPath, hFile, OPEN_AS_ANY); + + if not result then begin + exit; + end; + + if IsNtRootDriveAbsPath(NtAbsPath) then begin + // Return fake info for root drive + result := SaveAndRet(Windows.GetFileAttributesW(PWideChar(StripNtAbsPathPrefix(NtAbsPath))), FileAllInfo.BasicInformation.FileAttributes) <> integer(Windows.INVALID_HANDLE_VALUE); + + if result then begin + FillChar(Res.Base, sizeof(Res.Base), 0); + Res.Base.FileAttributes := FileAllInfo.BasicInformation.FileAttributes; + Res.SetFileName(NtAbsPath[DRIVE_CHAR_INDEX_IN_NT_ABS_PATH] + WideString(':\'#0)); + end; + end else begin + result := WinNative.NtQueryInformationFile(hFile, @IoStatusBlock, FileAllInfo, BUF_SIZE, ord(WinNative.FileAllInformation)) = WinNative.STATUS_SUCCESS; + + if result then begin + Res.Base.FileIndex := 0; + Res.Base.CreationTime := FileAllInfo.BasicInformation.CreationTime; + Res.Base.LastAccessTime := FileAllInfo.BasicInformation.LastAccessTime; + Res.Base.LastWriteTime := FileAllInfo.BasicInformation.LastWriteTime; + Res.Base.ChangeTime := FileAllInfo.BasicInformation.ChangeTime; + Res.Base.FileAttributes := FileAllInfo.BasicInformation.FileAttributes; + Res.Base.EndOfFile := FileAllInfo.StandardInformation.EndOfFile; + Res.Base.AllocationSize := FileAllInfo.StandardInformation.AllocationSize; + Res.Base.EaSize := FileAllInfo.EaInformation.EaSize; + Res.Base.ShortNameLength := 0; + Res.Base.ShortName[0] := #0; + Res.Base.FileNameLength := FileAllInfo.NameInformation.FileNameLength; + Res.Base.FileId.LowPart := 0; + Res.Base.FileId.HighPart := 0; + + Res.SetFileName(StrLib.ExtractFileNameW(StrLib.WideStringFromBuf( + @FileAllInfo.NameInformation.FileName, + Max(0, Min(integer(IoStatusBlock.Information) - sizeof(FileAllInfo^), FileAllInfo.NameInformation.FileNameLength)) div sizeof(WideChar) + ))); + end; // .if + end; // .else + + WinNative.NtClose(hFile); +end; // .function GetFileInfo + +constructor TSysDirScanner.Create (const hDir: Windows.THandle; const Mask: WideString); +begin + Self.fOwnsDirHandle := false; + Self.fDirHandle := hDir; + Self.fMask := StrLib.WideLowerCase(Mask); + Self.fMaskU.AssignExistingStr(Self.fMask); + Self.fIsStart := true; + Self.fIsEnd := false; + Self.fBufPos := 0; +end; + +constructor TSysDirScanner.Create (const DirPath, Mask: WideString); +var + hDir: Windows.THandle; + +begin + hDir := Windows.INVALID_HANDLE_VALUE; + SysOpenFile(ToNtAbsPath(DirPath), hDir, OPEN_AS_DIR); + + Self.Create(hDir, Mask); + + if hDir <> Windows.INVALID_HANDLE_VALUE then begin + Self.fOwnsDirHandle := true; + end else begin + Self.fIsEnd := true; + end; +end; // .constructor TSysDirScanner.Create + +destructor TSysDirScanner.Destroy; +begin + if Self.fOwnsDirHandle then begin + WinNative.NtClose(Self.fDirHandle); + end; +end; + +function TSysDirScanner.IterNext ({OUT} var FileName: WideString; {n} FileInfo: WinNative.PFILE_ID_BOTH_DIR_INFORMATION = nil): boolean; +const + MULTIPLE_ENTRIES = false; + +var +{n} FileInfoInBuf: WinNative.PFILE_ID_BOTH_DIR_INFORMATION; + IoStatusBlock: WinNative.IO_STATUS_BLOCK; + FileNameLen: integer; + Status: integer; + +begin + FileInfoInBuf := nil; + // * * * * * // + result := not Self.fIsEnd and (Self.fDirHandle <> Windows.INVALID_HANDLE_VALUE); + + if not result then begin + exit; + end; + + if not Self.fIsStart and (Self.fBufPos < Self.BUF_SIZE) then begin + FileInfoInBuf := @Self.fBuf[Self.fBufPos]; + FileNameLen := Min(FileInfoInBuf.FileNameLength, Self.BUF_SIZE - Self.fBufPos) div sizeof(WideChar); + FileName := StrLib.WideStringFromBuf(@FileInfoInBuf.FileName, FileNameLen); + + if FileInfo <> nil then begin + FileInfo^ := FileInfoInBuf^; + FileInfo.FileNameLength := FileNameLen * sizeof(WideChar); + end; + + //VarDump(['Read entry: ', FileName]); + + Self.fBufPos := Utils.IfThen(FileInfoInBuf.NextEntryOffset <> 0, Self.fBufPos + integer(FileInfoInBuf.NextEntryOffset), Self.BUF_SIZE); + end else begin + Self.fBufPos := 0; + Status := WinNative.NtQueryDirectoryFile(Self.fDirHandle, 0, nil, nil, @IoStatusBlock, @Self.fBuf, Self.BUF_SIZE, ord(WinNative.FileIdBothDirectoryInformation), MULTIPLE_ENTRIES, @Self.fMaskU, Self.fIsStart); + result := (Status = WinNative.STATUS_SUCCESS) and (integer(IoStatusBlock.Information) <> 0); + //VarDump([Format('Called NtQueryDirectoryFile. Status: %x. Io.Information: %d', [Status, int(IoStatusBlock.Information)])]); + Self.fIsStart := false; + + if result then begin + result := Self.IterNext(FileName, FileInfo); + end else begin + Self.fIsEnd := true; + end; + end; // .else +end; // .function TSysDirScanner.IterNext + +function SysScanDir (const hDir: Windows.THandle; const Mask: WideString): ISysDirScanner; overload; +begin + result := TSysDirScanner.Create(hDir, Mask); +end; + +function SysScanDir (const DirPath, Mask: WideString): ISysDirScanner; overload; +begin + result := TSysDirScanner.Create(DirPath, Mask); +end; + +end. \ No newline at end of file