Browse Source

* initial commit

master
Bergmann89 8 years ago
commit
68e94bd8d4
6 changed files with 1848 additions and 0 deletions
  1. +211
    -0
      uvfsFolder.pas
  2. +978
    -0
      uvfsManager.pas
  3. +137
    -0
      uvfsSpecialFolder.pas
  4. +225
    -0
      uvfsTarArchive.pas
  5. +53
    -0
      uvfsUtils.pas
  6. +244
    -0
      uvfsZipArchive.pas

+ 211
- 0
uvfsFolder.pas View File

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


+ 978
- 0
uvfsManager.pas View File

@@ -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 (Index<FRegisteredProviders.Count) then
Result:= TvfsProviderClass(FRegisteredProviders[Index])
else
Result:= nil;
end;

procedure TvfsManager.SaveConfigFile(const Filename: string; PathBase: string);
var
tab: TStringList;
cols: TutlCSVList;
i: integer;
o: TvfsOverlay;
begin
if PathBase='' then
PathBase:= ExtractFilePath(Filename);
PathBase:= IncludeTrailingPathDelimiter(vfsSystemPathDelim(PathBase));
tab:= TStringList.Create;
try
tab.Add(VFSTAB_COMMENT+'GENERATED FILE; DO NOT EDIT');
cols:= TutlCSVList.Create;
try
cols.Delimiter:= VFSTAB_SEPARATOR;
cols.QuoteChar:= VFSTAB_QUOTE;

for i:= 0 to OverlayCount-1 do begin
o:= Overlay[i];
cols.Clear;
cols.Add(IntToStr(o.Layer));
cols.Add(o.Mountpoint);
cols.Add(o.Provider.StorageName);
cols.Add(ExtractRelativepath(PathBase,o.Provider.StorageGetFileSpec));
cols.Add(o.Provider.StorageGetData);
tab.Add(cols.StrictDelimitedText);
end;
tab.SaveToFile(Filename);
finally
FreeAndNil(cols);
end;
finally
FreeAndNil(tab);
end;
end;

procedure TvfsManager.ApplyConfigFile(const Filename: string; PathBase: string);
var
tab: TStringList;
cols: TutlCSVList;
l: integer;
line, s: string;
ly: TvfsLayer;
mp,tp,fs,mo: string;
tc: TvfsProvider;
tcc: TvfsProviderClass;
begin
if PathBase = '' then begin
s := IncludeTrailingPathDelimiter(GetCurrentDir) + Filename;
if SysUtils.FileExists(s) then
PathBase := ExtractFilePath(s)
else
PathBase := ExtractFilePath(Filename);
end;
PathBase:= IncludeTrailingPathDelimiter(vfsSystemPathDelim(PathBase));
tab:= TStringList.Create;
try
cols:= TutlCSVList.Create;
try
cols.Delimiter:= VFSTAB_SEPARATOR;
cols.QuoteChar:= VFSTAB_QUOTE;
cols.SkipDelims:= true;
tab.LoadFromFile(Filename);
for l:= 0 to tab.Count - 1 do begin
line:= trim(tab[l]);
if (line='') or (line[1]=VFSTAB_COMMENT) then
continue;
cols.StrictDelimitedText:= line;
ly:= StrToInt(cols[0]);
mp:= cols[1];
tp:= cols[2];
fs:= vfsExpandFileName(cols[3], PathBase);
if cols.Count>4 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.

+ 137
- 0
uvfsSpecialFolder.pas View File

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


+ 225
- 0
uvfsTarArchive.pas View File

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


+ 53
- 0
uvfsUtils.pas View File

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


+ 244
- 0
uvfsZipArchive.pas View File

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


Loading…
Cancel
Save