commit 933e71456640b401f0bef21d0baf35f34da6458c Author: Berserker Date: Tue Apr 30 17:26:37 2019 +0300 Initial commit 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