commit 68e94bd8d49091f95d05e437477ddd24a2ff12eb Author: Bergmann89 Date: Tue Feb 2 19:28:49 2016 +0100 * initial commit diff --git a/uvfsFolder.pas b/uvfsFolder.pas new file mode 100644 index 0000000..2a07299 --- /dev/null +++ b/uvfsFolder.pas @@ -0,0 +1,211 @@ +unit uvfsFolder; + +interface + +uses + SysUtils, Classes, uvfsManager; + +type + + { TvfsFileSystemFolder } + + TvfsFileSystemFolder = class(TvfsProvider) + private + FRoot: string; + function ExpandPath(P:string): string; + procedure DeleteEmptyDir(aDir: String); + public + constructor Create(const FileSpec:string; const ExtendedData: string=''); override; + class function StorageName: string; override; + function StorageGetFileSpec: string; override; + // ACHTUNG: FileInfo.Size wird mit einem Integer gefüllt. Bei Dateien > 2GB aufpassen! + function GetFileInfo(const FileName: string; out FileInfo: TvfsFileInfo): Boolean; override; + function Open(const FileName: string; const OpenMode: TvfsFileOpenMode; out Stream: IStreamHandle): boolean; override; + function Rename(const OldName, NewName: string): boolean; override; + function Delete(const aName: String): boolean; override; + procedure DirectoryIndex(AddFunction: TvfsDirectoryAddFunc; List: TvfsDirectoryList; Path: string; Subdirs: boolean); override; + + function Root: string; + end; + + +implementation + +{ TvfsFileSystemFolder } + +constructor TvfsFileSystemFolder.Create(const FileSpec: string; const ExtendedData: string); +begin + inherited; + FRoot:= vfsSystemPathDelim(FileSpec); +end; + +class function TvfsFileSystemFolder.StorageName: string; +begin + Result:= 'folder'; +end; + +function TvfsFileSystemFolder.StorageGetFileSpec: string; +begin + Result:= Self.Root; +end; + +procedure TvfsFileSystemFolder.DirectoryIndex(AddFunction: TvfsDirectoryAddFunc; List: TvfsDirectoryList; Path: string; Subdirs: boolean); + procedure FindFiles(sRoot, sPfad: String); + var + Rec:TSearchRec; + s: string; + a: TvfsDirectoryEntry; + begin + if sPfad>'' then + sPfad:= IncludeTrailingPathDelimiter(sPfad); + if FindFirst(sRoot+sPfad+'*', faAnyFile,Rec)=0 then + repeat + if (Rec.Name<>'.') and (Rec.Name<>'..') then begin + s:= sPfad+Rec.Name; + a:= TvfsDirectoryEntry.Create; + a.FileInfo.Size:= Rec.Size; + a.FileInfo.Attributes:= Rec.Attr; + a.FileInfo.ModDate:= FileDateToDateTime(Rec.Time); + if (Rec.Attr and faDirectory = faDirectory) then begin + AddFunction(IncludeTrailingPathDelimiter(s), a, List); + if Subdirs then + FindFiles(sRoot, s); + end else + AddFunction(s, a, List); + end; + until FindNext(Rec)<>0; + Findclose(Rec); + end; +begin + FindFiles(IncludeTrailingPathDelimiter(FRoot),Path); +end; + +function TvfsFileSystemFolder.ExpandPath(P: string): string; +begin + Result:= vfsSystemPathDelim(IncludeTrailingPathDelimiter(FRoot)+P); +end; + +procedure TvfsFileSystemFolder.DeleteEmptyDir(aDir: String); + + function FileCount(aDir: String): Integer; + var + sr: TSearchRec; + found: Integer; + begin + result := 0; + if (Length(aDir) > 0) and (aDir[Length(aDir)] <> '\') then + aDir := aDir + '\'; + found := FindFirst(aDir+'*.*', faAnyFile, sr); + while found = 0 do begin + if (sr.Name <> '.') and (sr.Name <> '..') then + inc(result); + found := FindNext(sr); + end; + FindClose(sr); + end; + +begin + while DirectoryExists(aDir) and (FileCount(aDir) = 0) do begin + RemoveDir(aDir); + if (Length(aDir) > 0) and (aDir[Length(aDir)] = '\') then + System.Delete(aDir, Length(aDir), 1); + aDir := ExtractFilePath(aDir); + end; +end; + +function TvfsFileSystemFolder.GetFileInfo(const FileName: String; out FileInfo: TvfsFileInfo): Boolean; +var + sr: TSearchRec; +begin + Result:= FindFirst(ExpandPath(FileName),faAnyFile, sr) = 0; + try + if Result then begin + FileInfo.Size:= sr.Size; + FileInfo.Attributes:= sr.Attr; + FileInfo.ModDate:= FileDateToDateTime(sr.Time); + end; + finally + FindClose(sr); + end; +end; + +function TvfsFileSystemFolder.Open(const FileName: string; const OpenMode: TvfsFileOpenMode; out Stream: IStreamHandle): boolean; +var + fs: TFileStream; + mode: word; +begin + Stream:= nil; + Result:= false; + try + case OpenMode of + omCreateAlways: mode:= fmCreate; + else + begin + if FileExists(ExpandPath(FileName)) then + case OpenMode of + omReadOnly: mode:= fmOpenRead or fmShareDenyWrite; + omReadWrite, + omReadWriteCreate: mode:= fmOpenReadWrite; + end + else + case OpenMode of + omReadOnly, + omReadWrite: exit; + omReadWriteCreate: mode:= fmCreate; + end; + end; + end; + if (mode and fmCreate) > 0 then + ForceDirectories(ExtractFilePath(ExpandPath(FileName))); + try + fs:= TFileStream.Create(ExpandPath(FileName), mode); + except + fs := nil; + end; + Result:= Assigned(fs); + if Result then begin + if OpenMode = omReadOnly then + Stream:= TvfsStreamHandleRead.Create(fs) + else + Stream:= TvfsStreamHandleWrite.Create(fs, nil, nil, 0); + end; + except + FreeAndNil(fs); + raise; + end; +end; + +function TvfsFileSystemFolder.Rename(const OldName, NewName: string): boolean; +var + oldFile, newFile: String; +begin + oldFile := ExpandPath(OldName); + newFile := ExpandPath(NewName); + result := ForceDirectories(ExtractFilePath(newFile)); + if result then begin + Result:= RenameFile(oldFile, newFile); + DeleteEmptyDir(ExtractFilePath(oldFile)); + end; +end; + +function TvfsFileSystemFolder.Delete(const aName: String): boolean; +var + filename: String; +begin + filename := ExpandPath(aName); + result := DeleteFile(filename); + if not result then + result := RemoveDir(filename); + DeleteEmptyDir(ExtractFilePath(filename)); +end; + +function TvfsFileSystemFolder.Root: string; +begin + Result:= FRoot; +end; + + +initialization + VFSManager.RegisterProvider(TvfsFileSystemFolder); +end. + diff --git a/uvfsManager.pas b/uvfsManager.pas new file mode 100644 index 0000000..0a233e8 --- /dev/null +++ b/uvfsManager.pas @@ -0,0 +1,978 @@ +{ + Virtual File System. + + Overlay identifiziert über Layer-Nummer (oder direkt als Overlay-Objekt) + + UnionFS: Shadowing, höhere Overlay überdecken untere + Lesen: oberste existierende Datei wird abgerufen + Schreiben: Nur direkt über Layer; ggf. via Layer ID abrufbar + + Mountpunkte werden prefix-artig verwendet; erlauben das Verwenden von Datenquellen + als Unterverzeichnisse +} +unit uvfsManager; + +interface + +uses Classes, SysUtils, Contnrs; + +type + TvfsLayer = type Word; // größere Werte überdecken kleinere + + TvfsFileInfo = record + Size: Int64; + Attributes: Integer; + ModDate: TDateTime; + end; + + TvfsOverlay = class; + TvfsDirectoryList = class; + TvfsListingOptions = set of (loLayer, loPath, loRecursive, loFilter, loAttrib); + + TvfsDirectoryEntry = class + Source: TvfsOverlay; + FileInfo: TvfsFileInfo; + end; + + EvfsError = class(Exception); + + IStreamHandle = interface + ['{57F8D713-B231-4268-81CA-EE3CE25664FE}'] + function GetStream: TStream; + end; + + TvfsDirectoryAddFunc = procedure (FileName: string; Entry: TvfsDirectoryEntry; List: TvfsDirectoryList) of object; + + + { TvfsStreamHandleRead } + + TvfsStreamHandleRead = class(TInterfacedObject, IStreamHandle) + private + fStream: TStream; + public + constructor Create(aStream: TStream); + destructor Destroy; override; + function GetStream: TStream; + end; + + { TvfsStreamHandleWrite } + TvfsStreamHandleWrite = class; + TvfsWriteFunc = procedure(Handle: TvfsStreamHandleWrite; Data: Pointer; DataSize: integer) of object; + TvfsStreamHandleWrite = class(TvfsStreamHandleRead) + private + fData: Pointer; + fSize: Integer; + fFlushFunction: TvfsWriteFunc; + public + constructor Create(aStream: TStream; aFlushFunction: TvfsWriteFunc; Data: Pointer; DataSize: integer); + destructor Destroy; override; + end; + + (* Alles, was mit den wirklichen Daten spricht ist von [TvfsProvider] abgeleitet. + * + * Methoden: + * FileExists - Existiert diese Datei? + * Open - Öffnen einer Datei, siehe TvfsFileOpenMode + * Rename - Datei oder Verzeichnis umbenennen + * DirectoryIndex - Alle verfügbaren Dateien listen. + * StorageName - Name, unter dem dieser Provider in VFSTAB geführt wird + * StorageGetData - Daten für das ExtendedData-Feld der VFSTAB erzeugen + * + * Dateinamen sind immer relativ auf den Mountpunkt, also FileSpec im Konstruktor + *) + + { TvfsProvider } + TvfsFileOpenMode = (omReadOnly, // read-only, fail if not exists + omReadWrite, // read/write, fail if not exists + omReadWriteCreate, // read/write, create if not exists + omCreateAlways); // read/write, always create empty + + TvfsProvider = class + // Achievement Get: WTF FPC? -- virtueller Konstruktor, damit "class of" funktioniert, H- damit der leere Body keine Warnungen spammt + constructor Create(const {%H-}FileSpec: string; const {%H-}ExtendedData: string=''); virtual; + function GetFileInfo(const FileName: string; out FileInfo: TvfsFileInfo): boolean; virtual; abstract; + function Open(const FileName: string; const OpenMode: TvfsFileOpenMode; out Stream: IStreamHandle): boolean; virtual; abstract; + function Rename(const OldName, NewName: string): boolean; virtual; abstract; + function Delete(const aName: String): boolean; virtual; abstract; + procedure DirectoryIndex(AddFunction: TvfsDirectoryAddFunc; List: TvfsDirectoryList; Path: string; Subdirs: boolean); virtual; abstract; + + class function StorageName: string; virtual; abstract; + function StorageGetFileSpec: string; virtual; abstract; + function StorageGetData: string; virtual; + end; + TvfsProviderClass = class of TvfsProvider; + + { TvfsOverlay } + + TvfsOverlay = class + private + FListingAttrib: integer; + FListingFilter: string; + procedure DirectoryAdd(FileName: string; Entry: TvfsDirectoryEntry; List: TvfsDirectoryList); + public + Layer: TvfsLayer; + Provider: TvfsProvider; + Mountpoint: string; + function TranslatePath(const FileName: string; out RelativeName: string): boolean; + constructor Create(aLayer: TvfsLayer; aProvider: TvfsProvider; aMountpoint: string); + destructor Destroy; override; + + function GetFileInfo(const FileName: string; out FileInfo: TvfsFileInfo): boolean; + function OpenRead(const FileName: string; out Stream: IStreamHandle): boolean; + function OpenWrite(const FileName: string; const CanCreate: boolean; out Stream: IStreamHandle): boolean; + function CreateFile(const FileName: string; out Stream: IStreamHandle): boolean; + function Rename(const OldName, NewName: string): boolean; + function Delete(const aName: String): Boolean; + procedure Listing(List: TvfsDirectoryList; const Options: TvfsListingOptions; const Path: string; const Filter: string; const Attrib: integer); + end; + + TvfsDirectoryList = class(TStringList) + private + function GetEntry(Index: Integer): TvfsDirectoryEntry; + protected + procedure ClearObjects; + public + destructor Destroy; override; + procedure Delete(Index: Integer); override; + procedure Clear; override; + property Entry[Index: Integer]: TvfsDirectoryEntry read GetEntry; + // Eintrag einfügen. Im Fall eines Duplikats wird AObject direkt freigegeben + function AddEntry(const S: String; AObject: TvfsDirectoryEntry): Integer; + end; + + (* + * Here's the magic :) + *) + + { TvfsManager } + + TvfsManager = class + private + FLayers: TObjectList; + function LocateFile(const Filename: string; const FilterLayer: boolean; const Layer: TvfsLayer): TvfsOverlay; + function GetCount: integer; + function GetOverlay(Index: integer): TvfsOverlay; + protected + FRegisteredProviders: TClassList; + procedure InsertOverlay(Overlay: TvfsOverlay); + public + constructor Create; + destructor Destroy; override; + + // Overlay hinzufügen + function AddOverlay(const Layer: TvfsLayer; const Mountpoint: string; Provider: TvfsProvider): TvfsOverlay; overload; + // Overlay (vollständig) entfernen + procedure Remove(const Layer: TvfsLayer); overload; + procedure Remove(const Overlay: TvfsOverlay); overload; + procedure RemoveAll; + + // Zugriff auf den obersten Overlay mit dieser LayerID + function FindOverlay(const Layer: TvfsLayer): TvfsOverlay; + + // Direktzugriff auf Provider + property OverlayCount: integer read GetCount; + property Overlay[Index: integer]: TvfsOverlay read GetOverlay; + + // Verzeichnislisting + // List -> muss vorher erstellt werden + // Options: loRecursive, sonst gibts nur das gewählte Verzeichnis (oder Root, wenn loPath nicht verwendet wird) + // andere Options aktivieren die Parameter + procedure Listing(List: TvfsDirectoryList; const Options: TvfsListingOptions; const Layer: TvfsLayer = 0; + const Path: string = ''; const Filter: string = '*.*'; + const Attrib: integer = 0); + + // Datei aus der obersten Ebene lesen. + function FileExists(const FileName: String): Boolean; + function DirectoryExists(const FileName: String): Boolean; + function ReadFile(const Filename: string; out Stream: IStreamHandle): Boolean; + function WriteFile(const Filename: String; const CanCreate: boolean; out Stream: IStreamHandle): Boolean; + function CreateFile(const Filename: String; out Stream: IStreamHandle): Boolean; + function DeleteFile(const Filename: String): Integer; + function RenameFile(const aOld, aNew: String): Integer; + function ImmediateOverlay(const Filename: string): TvfsOverlay; + + // Provider registrieren + procedure RegisterProvider(const ClassRef: TvfsProviderClass); + // Provider zum Storage-Name suchen, nil wenn keiner gefunden + function FindProvider(const StorageName: string): TvfsProviderClass; + // Provider nach Einfügereihenfolge, nil wenn Index ungültig + function GetProvider(const Index: integer): TvfsProviderClass; + // Konfigurationsdaten speichern + procedure SaveConfigFile(const Filename: string; PathBase: string=''); + // Konfigurationsdaten dazuladen + procedure ApplyConfigFile(const Filename: string; PathBase: string=''); + end; + +const + VFS_PATH_DELIM = '/'; + +operator := (hdl: IStreamHandle): TStream; + +function vfsManager: TvfsManager; +function vfsSystemPathDelim(s: String): string; +function vfsVirtualPathDelim(s: String): string; +function vfsChangePathDelim(s: String; const newPathDelim: char): string; +function vfsExpandFileName(const Filename, Base: string): string; +function vfsFileNameLike(const AString, APattern: String): Boolean; +function vfsFileNameGlob(const AString, APattern: String): Boolean; + +implementation + +uses uutlCommon; + +const + VFSTAB_COMMENT = '#'; + VFSTAB_QUOTE = '"'; + VFSTAB_SEPARATOR = #9; + +operator:=(hdl: IStreamHandle): TStream; +begin + Result:= hdl.GetStream; +end; + +var + VFSSingleton: TvfsManager = nil; + +function vfsManager: TvfsManager; +begin + if not Assigned(VFSSingleton) then + VFSSingleton:= TvfsManager.Create; + Result:= VFSSingleton; +end; + +function vfsSystemPathDelim(s: String): string; +var i:integer; +begin + for i:= 1 to Length(s) do + if s[i] in ['\','/'] then + s[i]:= PathDelim; + Result:= S; +end; + +function vfsVirtualPathDelim(s: String): string; +var i:integer; +begin + for i:= 1 to Length(s) do + if s[i] in ['\','/'] then + s[i]:= VFS_PATH_DELIM; + Result:= S; +end; + +function vfsChangePathDelim(s: String; const newPathDelim: char): string; +var i:integer; +begin + for i:= 1 to Length(s) do + if s[i] in ['\','/'] then + s[i]:= newPathDelim; + Result:= S; +end; + + +function vfsExpandFileName(const Filename, Base: string): string; +begin +{$IF defined(WIN32) or defined(WIN64)} + if (ExtractFileDrive(Filename)>'') then +{$ELSE} + if (Copy(Filename,1,1)=PathDelim) then +{$IFEND} + Result:= Filename + else + Result:= IncludeTrailingPathDelimiter(Base)+Filename; +end; + +{ Like('Delphi', 'D*p?i') -> true.} + {Michael Winter} +function Like(const AString, APattern: String): Boolean; +var + StringPtr, PatternPtr: PChar; + StringRes, PatternRes: PChar; +begin + Result:=false; + StringPtr:=PChar(AString); + PatternPtr:=PChar(APattern); + StringRes:=nil; + PatternRes:=nil; + if APattern='*' then begin Result:= true; exit end; + repeat + repeat // ohne vorangegangenes "*" + case PatternPtr^ of + #0: begin + Result:=StringPtr^=#0; + if Result or (StringRes=nil) or (PatternRes=nil) then + Exit; + StringPtr:=StringRes; + PatternPtr:=PatternRes; + Break; + end; + '*': begin + inc(PatternPtr); + PatternRes:=PatternPtr; + Break; + end; + '?': begin + if StringPtr^=#0 then + Exit; + inc(StringPtr); + inc(PatternPtr); + end; + else begin + if StringPtr^=#0 then + Exit; + if StringPtr^<>PatternPtr^ then begin + if (StringRes=nil) or (PatternRes=nil) then + Exit; + StringPtr:=StringRes; + PatternPtr:=PatternRes; + Break; + end + else begin + inc(StringPtr); + inc(PatternPtr); + end; + end; + end; + until false; + repeat // mit vorangegangenem "*" + case PatternPtr^ of + #0: begin + Result:=true; + Exit; + end; + '*': begin + inc(PatternPtr); + PatternRes:=PatternPtr; + end; + '?': begin + if StringPtr^=#0 then + Exit; + inc(StringPtr); + inc(PatternPtr); + end; + else begin + repeat + if StringPtr^=#0 then + Exit; + if StringPtr^=PatternPtr^ then + Break; + inc(StringPtr); + until false; + inc(StringPtr); + StringRes:=StringPtr; + inc(PatternPtr); + Break; + end; + end; + until false; + until false; +end; + +function vfsFileNameLike(const AString, APattern: String): Boolean; +begin + Result:= Like(AnsiLowerCaseFileName(AString), AnsiLowerCaseFileName(APattern)); +end; + +function GlobMatchPattern(Str, Pattern: PChar): boolean; +var + pe: PChar; + sp: TStringList; + pp: string; +begin + Result:= false; + if (Str^=#0) or (Pattern^=#0) then + Exit(Str^ = Pattern^); + + case Pattern^ of + '?': ; //can't be wrong, since we already know we have at least one character left + '*': begin + inc(Pattern); + repeat + inc(Str); + until (Str^= #0) or GlobMatchPattern(Str, Pattern); + if (Str^= #0) then + Exit(StrLen(Pattern) = 0); + end; + '{': begin + inc(Pattern); + pe:= strscan(Pattern, '}'); + if pe = nil then + Exit(false); + sp:= TStringList.Create; + try + sp.Delimiter:= ','; + sp.DelimitedText:= Copy(Pattern, 1, {%H-}PtrUInt(pe)-{%H-}PtrUInt(Pattern)); + inc(pe); + Pattern:= pe; + for pp in sp do + if GlobMatchPattern(Str, PChar(pp + Pattern)) then + Exit(true); + Exit(false); + finally + FreeAndNil(sp); + end; + end + else + if Pattern^ <> Str^ then + Exit(false); + end; + inc(Pattern); + inc(Str); + Result:= GlobMatchPattern(Str, Pattern); +end; + +function vfsFileNameGlob(const AString, APattern: String): Boolean; +begin + Result:= GlobMatchPattern(PChar(AString), PChar(APattern)); +end; + +{ TvfsStreamHandleRead } + +constructor TvfsStreamHandleRead.Create(aStream: TStream); +begin + inherited Create; + fStream:= aStream; +end; + +destructor TvfsStreamHandleRead.Destroy; +begin + fStream.Free; + fStream:= nil; + inherited Destroy; +end; + +function TvfsStreamHandleRead.GetStream: TStream; +begin + Result:= fStream; +end; + +{ TvfsStreamHandleWrite } + +constructor TvfsStreamHandleWrite.Create(aStream: TStream; aFlushFunction: TvfsWriteFunc; Data: Pointer; DataSize: integer); +begin + inherited Create(aStream); + fFlushFunction:= aFlushFunction; + if Assigned(Data) and (DataSize>0) then begin + GetMem(fData, DataSize); + Move(Data^, fData^, DataSize); + end else + fData:= nil; + fSize:= DataSize; +end; + +destructor TvfsStreamHandleWrite.Destroy; +begin + if Assigned(fFlushFunction) then + fFlushFunction(Self, fData, fSize); + if Assigned(fData) then + Freememory(fData); + inherited Destroy; +end; + +{ TvfsProvider } + +constructor TvfsProvider.Create(const FileSpec: string; const ExtendedData: string); +begin + inherited Create; +end; + +function TvfsProvider.StorageGetData: string; +begin + Result:= ''; +end; + +{ TvfsOverlay } + +constructor TvfsOverlay.Create(aLayer: TvfsLayer; aProvider: TvfsProvider; aMountpoint: string); +var mp: string; +begin + Layer:= aLayer; + Provider:= aProvider; + mp:= vfsSystemPathDelim(aMountpoint); + mp:= IncludeTrailingPathDelimiter(mp); + while (mp>'') and (mp[1]=PathDelim) do + System.Delete(mp, 1, 1); + Self.Mountpoint:= mp; +end; + +destructor TvfsOverlay.Destroy; +begin + FreeAndNil(Provider); + inherited; +end; + +function TvfsOverlay.GetFileInfo(const FileName: string; out FileInfo: TvfsFileInfo): boolean; +var fn: string; +begin + Result:= TranslatePath(Filename, fn) and Provider.GetFileInfo(fn, FileInfo); +end; + +function TvfsOverlay.OpenRead(const FileName: string; out Stream: IStreamHandle): boolean; +var fn: string; +begin + Result:= TranslatePath(Filename, fn) and Provider.Open(fn, omReadOnly, Stream); +end; + +function TvfsOverlay.OpenWrite(const FileName: string; const CanCreate: boolean; out Stream: IStreamHandle): boolean; +const + OpenModes:array[Boolean] of TvfsFileOpenMode = (omReadWrite, omReadWriteCreate); +var + fn: string; +begin + Result:= TranslatePath(Filename, fn) and Provider.Open(fn, OpenModes[CanCreate], Stream); +end; + +function TvfsOverlay.CreateFile(const FileName: string; out Stream: IStreamHandle): boolean; +var fn: string; +begin + Result:= TranslatePath(Filename, fn) and Provider.Open(fn, omCreateAlways, Stream); +end; + +function TvfsOverlay.Rename(const OldName, NewName: string): boolean; +var fon, fnn: string; +begin + Result:= TranslatePath(OldName, fon) and TranslatePath(NewName, fnn) and Provider.Rename(fon, fnn); +end; + +function TvfsOverlay.Delete(const aName: String): Boolean; +var fName: string; +begin + Result := TranslatePath(aName, fName) and Provider.Delete(fName); +end; + +procedure TvfsOverlay.Listing(List: TvfsDirectoryList; const Options: TvfsListingOptions; const Path: string; const Filter: string; const Attrib: integer); +var + subpath: string; + e: TvfsDirectoryEntry; + m: string; +begin + subpath:= vfsSystemPathDelim(IncludeTrailingPathDelimiter(Path)); + if not (loPath in Options) or TranslatePath(Path, subpath) then begin + m:= vfsSystemPathDelim(Mountpoint); + while m>'' do begin + if (not (loPath in Options)) or (0=AnsiCompareStr(Path, Copy(m, 1, Length(Path)))) then begin + e:= TvfsDirectoryEntry.Create; + e.FileInfo.Attributes:= faDirectory or faSymLink; + e.FileInfo.ModDate:= 0; + e.FileInfo.Size:= 0; + e.Source:= Self; + List.AddEntry(m, e); + end; + System.Delete(m, Length(m),1); + m:= copy(m, 1, LastDelimiter(PathDelim, m)); + end; + if loAttrib in Options then + FListingAttrib:= Attrib + else + FListingAttrib:= Integer($FFFFFFFF); + if loFilter in Options then + FListingFilter:= Filter + else + FListingFilter:= '*'; + if not (loPath in Options) then + subpath:= ''; + Provider.DirectoryIndex({$IFDEF FPC}@{$ENDIF}DirectoryAdd, List, subpath, loRecursive in Options); + end; +end; + +procedure TvfsOverlay.DirectoryAdd(FileName: string; Entry: TvfsDirectoryEntry; List: TvfsDirectoryList); +var fn: string; +begin + Entry.Source:= Self; + fn:= ExtractFileName(FileName); + if ((FListingAttrib and Entry.FileInfo.Attributes) > 0) and // Attrib passt + ({(Entry.FileInfo.Attributes and faDirectory >0) or } // Ist Verzeichnis, oder... ACHTUNG!!! vorerst deaktiviert. KP warum das so drin war... + vfsFileNameLike(fn, FListingFilter)) then // ...DATEIname passt auf Maske + List.AddEntry(vfsVirtualPathDelim(Mountpoint+Filename), Entry) + else + Entry.Free; +end; + +function TvfsOverlay.TranslatePath(const FileName: string; out RelativeName: string): boolean; +var ff: string; +begin + ff:= Copy(vfsSystemPathDelim(FileName),1, Length(Mountpoint)); + Result:= 0 = AnsiCompareText(ff, Mountpoint); + if Result then + RelativeName:= Copy(vfsSystemPathDelim(FileName),length(ff)+1, Maxint); +end; + +{ TvfsDirectoryList } + +destructor TvfsDirectoryList.Destroy; +begin + ClearObjects; + inherited; +end; + +procedure TvfsDirectoryList.Clear; +begin + ClearObjects; + inherited; +end; + +procedure TvfsDirectoryList.Delete(Index: Integer); +var + f: TvfsDirectoryEntry; +begin + f:= TvfsDirectoryEntry(Objects[Index]); + Objects[Index]:= nil; + F.Free; + inherited; +end; + +procedure TvfsDirectoryList.ClearObjects; +var + i: integer; + f: TvfsDirectoryEntry; +begin + for i:= 0 to Count-1 do begin + f:= TvfsDirectoryEntry(Objects[i]); + Objects[i]:= nil; + F.Free; + end; +end; + +function TvfsDirectoryList.GetEntry(Index: Integer): TvfsDirectoryEntry; +begin + Result:= TvfsDirectoryEntry(Objects[Index]); +end; + +function TvfsDirectoryList.AddEntry(const S: String; AObject: TvfsDirectoryEntry): Integer; +begin + if IndexOf(S)>=0 then begin + Result:= -1; + AObject.Free; + end else + Result:= AddObject(S, AObject); +end; + +{ TvfsManager } + +constructor TvfsManager.Create; +begin + inherited Create; + FLayers:= TObjectList.Create(true); + FRegisteredProviders:= TClassList.Create; +end; + +destructor TvfsManager.Destroy; +begin + FreeAndNil(FRegisteredProviders); + FreeAndNil(FLayers); + inherited; +end; + +function TvfsManager.AddOverlay(const Layer: TvfsLayer; const Mountpoint: string; Provider: TvfsProvider): TvfsOverlay; +var ol: TvfsOverlay; +begin + Result:= nil; + ol:= TvfsOverlay.Create(Layer, Provider, Mountpoint); + try + InsertOverlay(ol); + Result:= ol; + except + FreeAndNil(ol); + raise; + end; +end; + +procedure TvfsManager.InsertOverlay(Overlay: TvfsOverlay); +var + i: integer; +begin + // add on top of the matching layer + for i:= 0 to FLayers.Count-1 do begin + if TvfsOverlay(FLayers[i]).Layer > Overlay.Layer then begin + FLayers.Insert(i, Overlay); + Exit; + end; + end; + // not inserted anything? then new layer is larger than anything before + FLayers.Add(Overlay); +end; + +function TvfsManager.LocateFile(const Filename: string; const FilterLayer: boolean; const Layer: TvfsLayer): TvfsOverlay; +var + i: integer; + ol: TvfsOverlay; + dummy: TvfsFileInfo; +begin + Result:= nil; + for i:= FLayers.Count-1 downto 0 do begin + ol:= TvfsOverlay(FLayers[i]); + if not FilterLayer or (ol.Layer=Layer) then begin + if ol.GetFileInfo(FileName, dummy) then begin + Result:= ol; + exit; + end; + end; + end; +end; + +function TvfsManager.ReadFile(const Filename: string; out Stream: IStreamHandle): Boolean; +var + ol: TvfsOverlay; +begin + ol:= LocateFile(Filename,false,0); + Result:= Assigned(ol) and ol.OpenRead(FileName, Stream); +end; + +function TvfsManager.WriteFile(const Filename: String; const CanCreate: boolean; out Stream: IStreamHandle): Boolean; +var + ol: TvfsOverlay; +begin + ol := ImmediateOverlay(Filename); + result := Assigned(ol) and ol.OpenWrite(Filename, CanCreate, Stream); +end; + +function TvfsManager.CreateFile(const Filename: String; out Stream: IStreamHandle): Boolean; +var + ol: TvfsOverlay; +begin + ol := ImmediateOverlay(Filename); + result := Assigned(ol) and ol.CreateFile(Filename, Stream); +end; + +function TvfsManager.DeleteFile(const Filename: String): Integer; +var + i: integer; + ol: TvfsOverlay; + d: string; +begin + result := 0; + for i := FLayers.Count-1 downto 0 do begin + ol := TvfsOverlay(FLayers[i]); + if ol.TranslatePath(Filename, d) then begin + if ol.Delete(Filename) then + inc(result); + end; + end; +end; + +function TvfsManager.RenameFile(const aOld, aNew: String): Integer; +var + i: integer; + ol: TvfsOverlay; + d: string; +begin + result := 0; + for i := FLayers.Count-1 downto 0 do begin + ol := TvfsOverlay(FLayers[i]); + if ol.TranslatePath(aOld, d) and ol.TranslatePath(aNew, d) then begin + if ol.Rename(aOld, aNew) then + inc(result); + end; + end; +end; + +function TvfsManager.ImmediateOverlay(const Filename: string): TvfsOverlay; +var + i: integer; + ol: TvfsOverlay; + d: string; +begin + Result:= nil; + for i:= FLayers.Count-1 downto 0 do begin + ol:= TvfsOverlay(FLayers[i]); + if ol.TranslatePath(Filename, d) then begin + Result:= ol; + exit; + end; + end; +end; + +procedure TvfsManager.Remove(const Layer: TvfsLayer); +var + i: integer; +begin + for i:= FLayers.Count-1 downto 0 do + if TvfsOverlay(FLayers[i]).Layer=Layer then + FLayers.Delete(i); +end; + +procedure TvfsManager.Remove(const Overlay: TvfsOverlay); +begin + FLayers.Remove(Overlay); +end; + +procedure TvfsManager.RemoveAll; +begin + FLayers.Clear; +end; + +function TvfsManager.FindOverlay(const Layer: TvfsLayer): TvfsOverlay; +var + i: integer; +begin + Result:= nil; + for i:= FLayers.Count-1 downto 0 do + if TvfsOverlay(FLayers[i]).Layer=Layer then begin + Result:= TvfsOverlay(FLayers[i]); + exit; + end; +end; + +procedure TvfsManager.Listing(List: TvfsDirectoryList; const Options: TvfsListingOptions; + const Layer: TvfsLayer; const Path: string; const Filter: string; + const Attrib: integer); +var + i: integer; +begin + List.Sorted:= true; + List.Duplicates:= dupIgnore; + for i:= FLayers.Count-1 downto 0 do + if not (loLayer in Options) or (TvfsOverlay(FLayers[i]).Layer=Layer) then begin + TvfsOverlay(FLayers[i]).Listing(List, Options - [loLayer], Path, Filter, Attrib); + end; +end; + +function TvfsManager.FileExists(const FileName: String): Boolean; +var + ol: TvfsOverlay; + fi: TvfsFileInfo; +begin + ol:= LocateFile(Filename,false,0); + Result:= Assigned(ol) and ol.GetFileInfo(FileName, fi) and ((fi.Attributes and faDirectory)=0); +end; + +function TvfsManager.DirectoryExists(const FileName: String): Boolean; +var + ol: TvfsOverlay; + fi: TvfsFileInfo; +begin + ol:= LocateFile(Filename,false,0); + Result:= Assigned(ol) and ol.GetFileInfo(FileName, fi) and ((fi.Attributes and faDirectory)>0); +end; + +function TvfsManager.GetCount: integer; +begin + Result:= FLayers.Count; +end; + +function TvfsManager.GetOverlay(Index: integer): TvfsOverlay; +begin + Result:= TvfsOverlay(FLayers[Index]); +end; + + +procedure TvfsManager.RegisterProvider(const ClassRef: TvfsProviderClass); +begin + if Assigned(ClassRef) and (FRegisteredProviders.IndexOf(ClassRef)<0) then + FRegisteredProviders.Add(ClassRef); +end; + +function TvfsManager.FindProvider(const StorageName: string): TvfsProviderClass; +var + i: integer; +begin + Result:= nil; + for i:= FRegisteredProviders.Count-1 downto 0 do + if AnsiCompareText(StorageName, TvfsProviderClass(FRegisteredProviders[i]).StorageName)=0 then begin + Result:= TvfsProviderClass(FRegisteredProviders[i]); + break; + end; +end; + +function TvfsManager.GetProvider(const Index: integer): TvfsProviderClass; +begin + if (Index>=0) and (Index4 then + mo:= cols[4] + else + mo:= ''; + tcc:= FindProvider(tp); + if Assigned(tcc) then begin + tc:= tcc.Create(fs, mo); + AddOverlay(ly, mp, tc); + end else + raise EvfsError.CreateFmt('Unsupported Overlay Provider: "%s"',[tp]); + end; + finally + FreeAndNil(cols); + end; + finally + FreeAndNil(tab); + end; +end; + +initialization +finalization + FreeAndNil(VFSSingleton); +end. diff --git a/uvfsSpecialFolder.pas b/uvfsSpecialFolder.pas new file mode 100644 index 0000000..ff409bd --- /dev/null +++ b/uvfsSpecialFolder.pas @@ -0,0 +1,137 @@ +{ + Virtual File System: OS Special Folders provider + + FileSpec ist relativ zu einem Special Folder, der in der ExtendedData angegeben + wird. Mögliche Schlüssel: + + 'LOCALAPPDATA' : User Application Data (machine local) + 'APPDATA' : User Application Data (roaming profile) + 'COMMONAPPDATA': Common Application Data + 'LOCALTEMP' : User-Local Temporary files + 'TEMP' : Temporary files (global) + 'HOME', + 'USERPROFILE' : User profile root ($HOME) + 'PROGRAM' : Application Binary path + (Maßgeblich ist das was in vfsResolveSystemPath steht!) + +} +unit uvfsSpecialFolder; + +interface + +uses + SysUtils, Classes, uvfsManager, uvfsFolder; + +type + TvfsSpecialFolder = class(TvfsFileSystemFolder) + private + FUserRoot, + FUserSpec: string; + public + constructor Create(const FileSpec:string; const ExtendedData: string=''); override; + class function StorageName: string; override; + function StorageGetFileSpec: string; override; + function StorageGetData: string; override; + end; + +function vfsRealGetAppConfigDir(Global: Boolean): string; +function vfsResolveSystemPath(const PathSpec: string): string; + +implementation + +{$IFDEF MSWINDOWS} +uses + windirs; +{$ENDIF} + +{ TvfsSpecialFolder } + +Function NoVendorAppNameEvent : String; +begin + Result:= ''; +end; + +{ + GetAppConfigDir appends a subdirectory for vendor and another for application name. + This behaviour cannot be disabled, and there is no unified cross-platform way to + get *only* the %APPDATA% direcory. + This hack temporarily returns empty vendor and appname, which works with the current + implementation. YMMV. +} +function vfsRealGetAppConfigDir(Global: Boolean): string; +var + vn: TGetVendorNameEvent; + an: TGetAppNameEvent; +begin + vn:= OnGetVendorName; + an:= OnGetApplicationName; + try + OnGetApplicationName:= @NoVendorAppNameEvent; + OnGetVendorName:= @NoVendorAppNameEvent; + Result:= GetAppConfigDir(Global); + finally + OnGetApplicationName:= an; + OnGetVendorName:= vn; + end; +end; + +function vfsResolveSystemPath(const PathSpec: string): string; +begin + Result:= ''; + case UpperCase(PathSpec) of + 'LOCALAPPDATA' : // User Application Data (machine local) + Result:= vfsRealGetAppConfigDir(false); + 'APPDATA' : // User Application Data (roaming profile) + {$IFDEF MSWINDOWS} + Result:= GetWindowsSpecialDir(CSIDL_APPDATA); + {$ELSE} + Result:= vfsResolveSystemPath('LOCALAPPDATA'); + {$ENDIF} + 'COMMONAPPDATA': // Common Application Data + Result:= vfsRealGetAppConfigDir(true); + 'LOCALTEMP' : // User-Local Temporary files + Result:= GetTempDir(false); + 'TEMP' : // Temporary files (global) + Result:= GetTempDir(true); + 'HOME', + 'USERPROFILE' : // User profile root ($HOME) + Result:= GetUserDir; + 'PROGRAM' : // Application Binary path + Result:= ExtractFilePath(ParamStr(0)); + end; +end; + + + +constructor TvfsSpecialFolder.Create(const FileSpec: string; const ExtendedData: string); +var + relroot: string; +begin + relroot:= vfsResolveSystemPath(ExtendedData); + relroot:= vfsExpandFileName(FileSpec, relroot); + inherited Create(relroot, ''); + FUserRoot:= FileSpec; + FUserSpec:= ExtendedData; +end; + +class function TvfsSpecialFolder.StorageName: string; +begin + Result:= 'special'; +end; + +function TvfsSpecialFolder.StorageGetFileSpec: string; +begin + Result:= FUserRoot; +end; + +function TvfsSpecialFolder.StorageGetData: string; +begin + Result:= FUserSpec; +end; + + + +initialization + VFSManager.RegisterProvider(TvfsSpecialFolder); +end. + diff --git a/uvfsTarArchive.pas b/uvfsTarArchive.pas new file mode 100644 index 0000000..805059f --- /dev/null +++ b/uvfsTarArchive.pas @@ -0,0 +1,225 @@ +unit uvfsTarArchive; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, libtar, syncobjs, + + uvfsManager, uutlExceptions; + +type +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// + TvfsTarArchive = class(TvfsProvider) + private + fStream: TStream; + fOwnsStream: Boolean; + fFileSpec: String; + fTar: TTarArchive; + fTarCS: TCriticalSection; + + private + function FindFile(const aFilename: String; out aRec: TTarDirRec): Boolean; + function PrepareFilename(const aFilename: String): String; + + public { TvfsProvider } + class function StorageName: string; override; + + public { TvfsProvider } + function StorageGetFileSpec: string; override; + function GetFileInfo(const FileName: string; out FileInfo: TvfsFileInfo): Boolean; override; + function Open(const FileName: string; const OpenMode: TvfsFileOpenMode; out Stream: IStreamHandle): boolean; override; + function Rename(const OldName, NewName: string): boolean; override; + function Delete(const aName: String): boolean; override; + procedure DirectoryIndex(AddFunction: TvfsDirectoryAddFunc; List: TvfsDirectoryList; Path: string; Subdirs: boolean); override; + + public + constructor Create(const FileSpec: string; const ExtendedData: string = ''); override; + constructor Create(const aStream: TStream; const aOwnsStream: Boolean); + destructor Destroy; override; + end; + + +implementation + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +//TvfsTarArchive//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +function TvfsTarArchive.FindFile(const aFilename: String; out aRec: TTarDirRec): Boolean; +var + fn: String; +begin + fn := PrepareFilename(aFilename); + fTar.Reset; + result := true; + while fTar.FindNext(aRec{%H-}) do begin + if (aRec.Name = fn) then + exit; + end; + result := false; +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +function TvfsTarArchive.PrepareFilename(const aFilename: String): String; +var + sl: TStringList; + i: Integer; +begin + sl := TStringList.Create; + try + sl.Delimiter := VFS_PATH_DELIM; + sl.StrictDelimiter := true; + sl.DelimitedText := vfsVirtualPathDelim(aFilename); + i := 0; + while (i < sl.Count) do begin + if (sl[i] = '..') and (i > 0) then begin + sl.Delete(i); + dec(i); + sl.Delete(i); + end else + inc(i); + end; + result := sl.DelimitedText; + finally + FreeAndNil(sl); + end; +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +class function TvfsTarArchive.StorageName: string; +begin + result := 'tar'; +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +function TvfsTarArchive.StorageGetFileSpec: string; +begin + result := fFileSpec; +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +function TvfsTarArchive.GetFileInfo(const FileName: string; out FileInfo: TvfsFileInfo): Boolean; +var + rec: TTarDirRec; +begin + result := FindFile(FileName, rec); + if result then begin + FileInfo.Size := rec.Size; + FileInfo.ModDate := rec.DateTime; + FileInfo.Attributes := 0; + end; +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +function TvfsTarArchive.Open(const FileName: string; const OpenMode: TvfsFileOpenMode; out Stream: IStreamHandle): boolean; +var + ms: TMemoryStream; + rec: TTarDirRec; +begin + result := false; + fTarCS.Enter; + try + if not FindFile(FileName, rec) then + exit; + + ms := TMemoryStream.Create; + fTar.ReadFile(ms); + + case OpenMode of + omReadOnly: begin + ms.Position := 0; + Stream := TvfsStreamHandleRead.Create(ms); + end; + else + raise ENotSupported.Create('tar archive only supports read operations'); + end; + + result := Assigned(Stream); + if not result then + FreeAndNil(ms); + finally + fTarCS.Leave; + end; +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +function TvfsTarArchive.Rename(const OldName, NewName: string): boolean; +begin + result := false; +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +function TvfsTarArchive.Delete(const aName: String): boolean; +begin + result := false; +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +procedure TvfsTarArchive.DirectoryIndex(AddFunction: TvfsDirectoryAddFunc; List: TvfsDirectoryList; Path: string; Subdirs: boolean); +var + rec: TTarDirRec; + dirOK: Boolean; + fp: String; + a: TvfsDirectoryEntry; +begin + fTarCS.Enter; + try + fTar.Reset; + while fTar.FindNext(rec{%H-}) do begin + fp := ExtractFilePath(rec.Name); + if Subdirs then + dirOK := (AnsiCompareStr(Path, copy(fp, 1, Length(Path))) = 0) + else + dirOk := (AnsiCompareFileName(Path, fp) = 0); + + if dirOK then begin + a := TvfsDirectoryEntry.Create; + a.FileInfo.Size := rec.Size; + a.FileInfo.ModDate := rec.DateTime; + a.FileInfo.Attributes := 0; + AddFunction(rec.Name, a, List); + end; + end; + finally + fTarCS.Leave; + end; +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +constructor TvfsTarArchive.Create(const FileSpec: string; const ExtendedData: string); +var + fs: TFileStream; +begin + fFileSpec := FileSpec; + if not FileExists(fFileSpec) then + EFileNotFound.Create(fFileSpec); + fs := TFileStream.Create(fFileSpec, fmOpenRead); + Create(fs, true); +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +constructor TvfsTarArchive.Create(const aStream: TStream; const aOwnsStream: Boolean); +begin + inherited Create('', ''); + fOwnsStream := aOwnsStream; + fStream := aStream; + fTar := TTarArchive.Create(fStream); + fTarCS := TCriticalSection.Create; +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +destructor TvfsTarArchive.Destroy; +begin + FreeAndNil(fTar); + FreeAndNil(fTarCS); + if (fOwnsStream) then + FreeAndNil(fStream); + inherited Destroy; +end; + +initialization + vfsManager.RegisterProvider(TvfsTarArchive); + +end. + diff --git a/uvfsUtils.pas b/uvfsUtils.pas new file mode 100644 index 0000000..fd773a0 --- /dev/null +++ b/uvfsUtils.pas @@ -0,0 +1,53 @@ +unit uvfsUtils; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, + uutlSerialization; + +type +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// + TvfsFileWriter = class(TInterfacedObject, IutlFileWriter) + public + procedure SaveStream(const aFilename: String; const aStream: TStream); + end; + + TvfsFileReader = class(TInterfacedObject, IutlFileReader) + public + function LoadStream(const aFilename: String; const aStream: TStream): Boolean; + end; + +implementation + +uses + uvfsManager; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +//TvfsFileReader//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +function TvfsFileReader.LoadStream(const aFilename: String; const aStream: TStream): Boolean; +var + s: IStreamHandle; +begin + result := vfsManager.ReadFile(aFilename, s); + if result then + aStream.CopyFrom(s, s.GetStream.Size - s.GetStream.Position); +end; + +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +//TvfsFileWriter//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// +procedure TvfsFileWriter.SaveStream(const aFilename: String; const aStream: TStream); +var + s: IStreamHandle; +begin + if not vfsManager.WriteFile(aFilename, true, s) then + raise EvfsError.Create('unable to create file: ' + aFilename); + s.GetStream.CopyFrom(aStream, aStream.Size - aStream.Position); +end; + +end. + diff --git a/uvfsZipArchive.pas b/uvfsZipArchive.pas new file mode 100644 index 0000000..ee3e3ef --- /dev/null +++ b/uvfsZipArchive.pas @@ -0,0 +1,244 @@ +unit uvfsZipArchive; + +interface + +uses + SysUtils, Classes, uvfsManager, KAZip, syncobjs; + +type + + { TvfsZipArchive } + + TvfsZipArchive = class(TvfsProvider) + private + FZipActionCS: TCriticalSection; + FZipper: TKAZip; + procedure Flush(Handle: TvfsStreamHandleWrite; Data: Pointer; DataSize: integer); + function PrepareFilename(const aFilename: String): String; + public + constructor Create(const FileSpec:string; const ExtendedData: string=''); override; + destructor Destroy; override; + class function StorageName: string; override; + function StorageGetFileSpec: string; override; + function GetFileInfo(const FileName: string; out FileInfo: TvfsFileInfo): Boolean; override; + function Open(const FileName: string; const OpenMode: TvfsFileOpenMode; out Stream: IStreamHandle): boolean; override; + function Rename(const OldName, NewName: string): boolean; override; + function Delete(const aName: String): boolean; override; + procedure DirectoryIndex(AddFunction: TvfsDirectoryAddFunc; List: TvfsDirectoryList; Path: string; Subdirs: boolean); override; + + function ZipFilename: string; + end; + +implementation + +{ TvfsZipArchive } + +constructor TvfsZipArchive.Create(const FileSpec: string; const ExtendedData: string); +var + path: String; + dir: String; +begin + inherited; + FZipActionCS := TCriticalSection.Create; + FZipper:= TKAZip.Create(nil); + path := vfsSystemPathDelim(FileSpec); + if not FileExists(path) then begin + dir := ExtractFilePath(path); + if (dir <> '') then + ForceDirectories(dir); + FZipper.CreateZip(path); + end; + FZipper.Open(path); + FZipper.CompressionType:= ctNone; +end; + +destructor TvfsZipArchive.Destroy; +begin + if Assigned(FZipper) then begin + FZipActionCS.Acquire; + try + FreeAndNil(FZipper); + finally + FZipActionCS.Release; + end; + end; + FreeAndNil(FZipActionCS); + inherited; +end; + +class function TvfsZipArchive.StorageName: string; +begin + Result:= 'zip'; +end; + +function TvfsZipArchive.StorageGetFileSpec: string; +begin + Result:= Self.ZipFileName; +end; + +procedure TvfsZipArchive.DirectoryIndex(AddFunction: TvfsDirectoryAddFunc; List: TvfsDirectoryList; Path: string; Subdirs: boolean); +var + i: integer; + a: TvfsDirectoryEntry; + e: TKAZipEntriesEntry; + fp: string; + dirOk: boolean; +begin + FZipActionCS.Acquire; + try + for i:= 0 to FZipper.Entries.Count-1 do begin + e:= FZipper.Entries.Items[i]; + fp:= FZipper.GetFilePath(e.FileName); + if Subdirs then + dirOk:= 0=AnsiCompareStr(Path, Copy(fp, 1, Length(Path))) + else + dirOk:= 0=AnsiCompareFileName(Path, fp); + if dirOk then begin + a:= TvfsDirectoryEntry.Create; + a.FileInfo.Size:= e.SizeUncompressed; + a.FileInfo.Attributes:= e.Attributes; + a.FileInfo.ModDate:= e.Date; + AddFunction(fp+FZipper.GetFileName(e.FileName), a, List); + end; + end; + finally + FZipActionCS.Release; + end; +end; + +function TvfsZipArchive.GetFileInfo(const FileName: string; out FileInfo: TvfsFileInfo): Boolean; +var + i:integer; +begin + FZipActionCS.Acquire; + try + i:= FZipper.Entries.IndexOf(PrepareFilename(vfsSystemPathDelim(FileName))); + Result:= i>=0; + if Result then begin + FileInfo.Size:= FZipper.Entries.Items[i].SizeUncompressed; + FileInfo.Attributes:= FZipper.Entries.Items[i].Attributes; + FileInfo.ModDate:= FZipper.Entries.Items[i].Date; + end; + finally + FZipActionCS.Release; + end; +end; + +function TvfsZipArchive.Open(const FileName: string; const OpenMode: TvfsFileOpenMode; out Stream: IStreamHandle): boolean; +var + ms: TMemoryStream; + eid: Integer; +begin + ms:= nil; + Stream:= nil; + Result:= false; + try + FZipActionCS.Acquire; + try + eid:= FZipper.Entries.IndexOf(PrepareFilename(vfsSystemPathDelim(FileName))); + + if (eid>=0) and (OpenMode<>omCreateAlways) then begin + ms:= TMemoryStream.Create; + FZipper.Entries.Items[eid].ExtractToStream(ms); + end; + finally + FZipActionCS.Release; + end; + + case OpenMode of + omReadOnly: if Assigned(ms) then begin + ms.Position:= 0; + Stream:= TvfsStreamHandleRead.Create(ms); + end; + omReadWrite: if Assigned(ms) then begin + ms.Position:= ms.Size; + Stream:= TvfsStreamHandleWrite.Create(ms, @Self.Flush, PChar(FileName), 1+strlen(PChar(FileName))); + end; + omReadWriteCreate: begin + if not Assigned(ms) then + ms:= TMemoryStream.Create; + ms.Position:= ms.Size; + Stream:= TvfsStreamHandleWrite.Create(ms, @Self.Flush, PChar(FileName), 1+strlen(PChar(FileName))); + end; + omCreateAlways: begin + ms:= TMemoryStream.Create; + Stream:= TvfsStreamHandleWrite.Create(ms, @Self.Flush, PChar(FileName), 1+strlen(PChar(FileName))); + end; + end; + Result:= Assigned(Stream); + if not Result then + FreeAndNil(ms); + except + FreeAndNil(ms); + raise; + end; +end; + +function TvfsZipArchive.Rename(const OldName, NewName: string): boolean; +begin + FZipActionCS.Acquire; + try + if FZipper.Entries.IndexOf(OldName)>=0 then + FZipper.Rename(OldName, NewName) + else + FZipper.RenameFolder(OldName, NewName); + finally + FZipActionCS.Release; + end; + Result:= true; +end; + +function TvfsZipArchive.Delete(const aName: String): boolean; +begin + //TODO: delete file from zip + Result:= false; + raise Exception.Create('not yet implemented'); +end; + +procedure TvfsZipArchive.Flush(Handle: TvfsStreamHandleWrite; Data: Pointer; DataSize: integer); +var s:string; +begin + s:= StrPas(Data); + Handle.GetStream.Position:= 0; + FZipActionCS.Acquire; + try + FZipper.AddStream(s, Handle.GetStream); + finally + FZipActionCS.Release; + end; +end; + +function TvfsZipArchive.PrepareFilename(const aFilename: String): String; +var + sl: TStringList; + i: Integer; +begin + sl := TStringList.Create; + try + sl.Delimiter := PathDelim; + sl.StrictDelimiter := true; + sl.DelimitedText := aFilename; + i := 0; + while (i < sl.Count) do begin + if (sl[i] = '..') and (i > 0) then begin + sl.Delete(i); + dec(i); + sl.Delete(i); + end else + inc(i); + end; + result := sl.DelimitedText; + finally + FreeAndNil(sl); + end; +end; + +function TvfsZipArchive.ZipFilename: string; +begin + Result:= FZipper.FileName; +end; + +initialization + vfsManager.RegisterProvider(TvfsZipArchive); +end. +