git_admin/Virtual-File-System
1
0
Fork 0
mirror of https://github.com/CloudDelphi/Virtual-File-System synced 2025-12-19 09:53:54 +01:00
Code Issues Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
Berserker 2019-04-30 17:26:37 +03:00
commit 933e714566
11 changed files with 1240 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitignore vendored Normal file
View File

@ -0,0 +1,5 @@
*.dcu
*.exe
*.ini
*.identcache
__history/

69
Tests/VfsDebugTest.pas Normal file
View File

@ -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.

18
Vfs.dpr Normal file
View File

@ -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.

47
Vfs.dproj Normal file
View File

@ -0,0 +1,47 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{e3e35df4-690f-11e9-a923-1681be663d3e}</ProjectGuid>
<MainSource>Vfs.dpr</MainSource>
<Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration>
<Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
<DCC_DependencyCheckOutputName>Vfs.dll</DCC_DependencyCheckOutputName>
</PropertyGroup>
<PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' ">
<Version>7.0</Version>
<DCC_DebugInformation>False</DCC_DebugInformation>
<DCC_LocalDebugSymbols>False</DCC_LocalDebugSymbols>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
<DCC_Define>RELEASE</DCC_Define>
</PropertyGroup>
<PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' ">
<Version>7.0</Version>
<DCC_Define>DEBUG</DCC_Define>
<DCC_IOChecking>False</DCC_IOChecking>
<DCC_WriteableConstants>True</DCC_WriteableConstants>
<DCC_Optimize>False</DCC_Optimize>
<DCC_UnitSearchPath>..\Lib\B2;.\Png</DCC_UnitSearchPath>
<DCC_ResourcePath>..\Lib\B2;.\Png</DCC_ResourcePath>
<DCC_ObjPath>..\Lib\B2;.\Png</DCC_ObjPath>
<DCC_IncludePath>..\Lib\B2;.\Png</DCC_IncludePath>
<DCC_MapFile>3</DCC_MapFile>
</PropertyGroup>
<ProjectExtensions>
<Borland.Personality>Delphi.Personality</Borland.Personality>
<Borland.ProjectType>VCLApplication</Borland.ProjectType>
<BorlandProject>
<BorlandProject><Delphi.Personality><Parameters><Parameters Name="UseLauncher">False</Parameters><Parameters Name="LoadAllSymbols">True</Parameters><Parameters Name="LoadUnspecifiedSymbols">False</Parameters></Parameters><VersionInfo><VersionInfo Name="IncludeVerInfo">False</VersionInfo><VersionInfo Name="AutoIncBuild">False</VersionInfo><VersionInfo Name="MajorVer">1</VersionInfo><VersionInfo Name="MinorVer">0</VersionInfo><VersionInfo Name="Release">0</VersionInfo><VersionInfo Name="Build">0</VersionInfo><VersionInfo Name="Debug">False</VersionInfo><VersionInfo Name="PreRelease">False</VersionInfo><VersionInfo Name="Special">False</VersionInfo><VersionInfo Name="Private">False</VersionInfo><VersionInfo Name="DLL">False</VersionInfo><VersionInfo Name="Locale">1049</VersionInfo><VersionInfo Name="CodePage">1251</VersionInfo></VersionInfo><VersionInfoKeys><VersionInfoKeys Name="CompanyName"></VersionInfoKeys><VersionInfoKeys Name="FileDescription"></VersionInfoKeys><VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys><VersionInfoKeys Name="InternalName"></VersionInfoKeys><VersionInfoKeys Name="LegalCopyright"></VersionInfoKeys><VersionInfoKeys Name="LegalTrademarks"></VersionInfoKeys><VersionInfoKeys Name="OriginalFilename"></VersionInfoKeys><VersionInfoKeys Name="ProductName"></VersionInfoKeys><VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys><VersionInfoKeys Name="Comments"></VersionInfoKeys></VersionInfoKeys><Source><Source Name="MainSource">Vfs.dpr</Source></Source><Excluded_Packages>
<Excluded_Packages Name="$(BDS)\bin\dcloffice2k100.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="$(BDS)\bin\dclofficexp100.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
</Excluded_Packages></Delphi.Personality></BorlandProject></BorlandProject>
</ProjectExtensions>
<Import Project="$(MSBuildBinPath)\Borland.Delphi.Targets" />
<ItemGroup>
<DelphiCompile Include="Vfs.dpr">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="Lua\Lua.pas" />
</ItemGroup>
</Project>

441
VfsBase.pas Normal file
View File

@ -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.

98
VfsDebug.pas Normal file
View File

@ -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.

20
VfsExport.pas Normal file
View File

@ -0,0 +1,20 @@
unit VfsExport;
(*
*)
(***) interface (***)
uses
VfsDebug;
exports
VfsDebug.WriteLog_ name 'WriteLog',
VfsDebug.SetLoggingProc;
(***) implementation (***)
begin
end.

11
VfsTest.dpr Normal file
View File

@ -0,0 +1,11 @@
program VfsTest;
uses
TestFramework, GuiTestRunner,
VfsUtils, VfsBase, VfsDebug, VfsExport,
VfsDebugTest;
begin
TGUITestRunner.RunRegisteredTests;
end.

48
VfsTest.dproj Normal file
View File

@ -0,0 +1,48 @@
<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{c6015c7b-4070-47b6-8c8a-c2b54aba82d6}</ProjectGuid>
<MainSource>VfsTest.dpr</MainSource>
<Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration>
<Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
<DCC_DependencyCheckOutputName>VfsTest.exe</DCC_DependencyCheckOutputName>
</PropertyGroup>
<PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' ">
<Version>7.0</Version>
<DCC_DebugInformation>False</DCC_DebugInformation>
<DCC_LocalDebugSymbols>False</DCC_LocalDebugSymbols>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
<DCC_Define>RELEASE</DCC_Define>
</PropertyGroup>
<PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' ">
<Version>7.0</Version>
<DCC_Define>DEBUG</DCC_Define>
<DCC_IOChecking>False</DCC_IOChecking>
<DCC_UnitSearchPath>..\Lib\B2;.\Tests</DCC_UnitSearchPath>
<DCC_ResourcePath>..\Lib\B2;.\Tests</DCC_ResourcePath>
<DCC_ObjPath>..\Lib\B2;.\Tests</DCC_ObjPath>
<DCC_IncludePath>..\Lib\B2;.\Tests</DCC_IncludePath>
</PropertyGroup>
<ProjectExtensions>
<Borland.Personality>Delphi.Personality</Borland.Personality>
<Borland.ProjectType>VCLApplication</Borland.ProjectType>
<BorlandProject>
<BorlandProject><Delphi.Personality><Parameters><Parameters Name="UseLauncher">False</Parameters><Parameters Name="LoadAllSymbols">True</Parameters><Parameters Name="LoadUnspecifiedSymbols">False</Parameters></Parameters><VersionInfo><VersionInfo Name="IncludeVerInfo">False</VersionInfo><VersionInfo Name="AutoIncBuild">False</VersionInfo><VersionInfo Name="MajorVer">1</VersionInfo><VersionInfo Name="MinorVer">0</VersionInfo><VersionInfo Name="Release">0</VersionInfo><VersionInfo Name="Build">0</VersionInfo><VersionInfo Name="Debug">False</VersionInfo><VersionInfo Name="PreRelease">False</VersionInfo><VersionInfo Name="Special">False</VersionInfo><VersionInfo Name="Private">False</VersionInfo><VersionInfo Name="DLL">False</VersionInfo><VersionInfo Name="Locale">1049</VersionInfo><VersionInfo Name="CodePage">1251</VersionInfo></VersionInfo><VersionInfoKeys><VersionInfoKeys Name="CompanyName"></VersionInfoKeys><VersionInfoKeys Name="FileDescription"></VersionInfoKeys><VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys><VersionInfoKeys Name="InternalName"></VersionInfoKeys><VersionInfoKeys Name="LegalCopyright"></VersionInfoKeys><VersionInfoKeys Name="LegalTrademarks"></VersionInfoKeys><VersionInfoKeys Name="OriginalFilename"></VersionInfoKeys><VersionInfoKeys Name="ProductName"></VersionInfoKeys><VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys><VersionInfoKeys Name="Comments"></VersionInfoKeys></VersionInfoKeys><Source><Source Name="MainSource">VfsTest.dpr</Source></Source> <Excluded_Packages>
<Excluded_Packages Name="$(BDS)\bin\dcloffice2k100.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
<Excluded_Packages Name="$(BDS)\bin\dclofficexp100.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages>
</Excluded_Packages>
</Delphi.Personality></BorlandProject></BorlandProject>
</ProjectExtensions>
<Import Project="$(MSBuildBinPath)\Borland.Delphi.Targets" />
<ItemGroup>
<DelphiCompile Include="VfsTest.dpr">
<MainSource>MainSource</MainSource>
</DelphiCompile>
</ItemGroup>
</Project>

2
VfsTest.dproj.local Normal file
View File

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

481
VfsUtils.pas Normal file
View File

@ -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.