pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

New implementation to read and write OLE documents (Excel BIFF 5 & 8).

Browse Source 
Now BIFF 5 & 8 should be possible to be generated in non Windows environment but this fact has not been tested.
To use the older mode replace uses "fpolebasic" by "fpolestorage".
Extensive tests are needed.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@792 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
Joshy
2009-05-09 15:41:38 +00:00
parent 6ececd5c96
commit 181a1e0a98
10 changed files with 3476 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

108
components/fpspreadsheet/fpolebasic.pas Normal file
View File

@@ -0,0 +1,108 @@
{
fpolestorage.pas
Writes an OLE document using the OLE virtual layer.
Note: Compatibility with previous version (fpolestorage.pas).
}
unit fpolebasic;
interface
uses
Classes, SysUtils,
uvirtuallayer_ole;
type
{ Describes an OLE Document }
TOLEDocument = record
// Information about the document
Stream: TMemoryStream;
end;
{ TOLEStorage }
TOLEStorage = class
private
public
constructor Create;
destructor Destroy; override;
procedure WriteOLEFile(AFileName: string; AOLEDocument: TOLEDocument; const AStreamName: UTF8String='Book');
procedure ReadOLEFile(AFileName: string; AOLEDocument: TOLEDocument; const AStreamName: UTF8String='Book');
procedure FreeOLEDocumentData(AOLEDocument: TOLEDocument);
end;
implementation
constructor TOLEStorage.Create;
begin
inherited Create;
end;
destructor TOLEStorage.Destroy;
begin
inherited Destroy;
end;
{@@
Writes the OLE document specified in AOLEDocument
to the file with name AFileName. The routine will fail
if the file already exists, or if the directory where
it should be placed doesn't exist.
}
procedure TOLEStorage.WriteOLEFile(AFileName: string;
AOLEDocument: TOLEDocument; const AStreamName: UTF8String);
var
RealFile: TFileStream;
fsOLE: TVirtualLayer_OLE;
OLEStream: TStream;
VLAbsolutePath: UTF8String;
begin
VLAbsolutePath:='/'+AStreamName; //Virtual layer always use absolute paths.
RealFile:=TFileStream.Create(AFileName,fmCreate);
fsOLE:=TVirtualLayer_OLE.Create(RealFile);
fsOLE.Format(); //Initialize and format the OLE container.
OLEStream:=fsOLE.CreateStream(VLAbsolutePath,fmCreate);
AOLEDocument.Stream.Position:=0; //Ensures it is in the begining.
OLEStream.CopyFrom(AOLEDocument.Stream,AOLEDocument.Stream.Size);
OLEStream.Free;
fsOLE.Free;
RealFile.Free;
end;
{@@
Reads an OLE file.
}
procedure TOLEStorage.ReadOLEFile(AFileName: string;
AOLEDocument: TOLEDocument; const AStreamName: UTF8String);
var
RealFile: TFileStream;
fsOLE: TVirtualLayer_OLE;
OLEStream: TStream;
VLAbsolutePath: UTF8String;
begin
VLAbsolutePath:='/'+AStreamName; //Virtual layer always use absolute paths.
RealFile:=TFileStream.Create(AFileName,fmOpenRead);
fsOLE:=TVirtualLayer_OLE.Create(RealFile);
fsOLE.Initialize(); //Initialize the OLE container.
OLEStream:=fsOLE.CreateStream(VLAbsolutePath,fmOpenRead);
AOLEDocument.Stream:=TMemoryStream.Create;
AOLEDocument.Stream.CopyFrom(OLEStream,OLEStream.Size);
OLEStream.Free;
fsOLE.Free;
RealFile.Free;
end;
{@@
Frees all internal objects storable in a TOLEDocument structure
}
procedure TOLEStorage.FreeOLEDocumentData(AOLEDocument: TOLEDocument);
begin
if Assigned(AOLEDocument.Stream) then FreeAndNil(AOLEDocument.Stream);
end;
end.

30
components/fpspreadsheet/laz_fpspreadsheet.lpk
View File

@@ -14,7 +14,7 @@
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Files Count="10">
<Files Count="17">
<Item1>
<Filename Value="fpolestorage.pas"/>
<UnitName Value="fpolestorage"/>
@@ -55,6 +55,34 @@
<Filename Value="fpszipper.pp"/>
<UnitName Value="fpszipper"/>
</Item10>
<Item11>
<Filename Value="uvirtuallayer_types.pas"/>
<UnitName Value="uvirtuallayer_types"/>
</Item11>
<Item12>
<Filename Value="uvirtuallayer.pas"/>
<UnitName Value="uvirtuallayer"/>
</Item12>
<Item13>
<Filename Value="uvirtuallayer_ole.pas"/>
<UnitName Value="uvirtuallayer_ole"/>
</Item13>
<Item14>
<Filename Value="uvirtuallayer_ole_helpers.pas"/>
<UnitName Value="uvirtuallayer_ole_helpers"/>
</Item14>
<Item15>
<Filename Value="uvirtuallayer_ole_types.pas"/>
<UnitName Value="uvirtuallayer_ole_types"/>
</Item15>
<Item16>
<Filename Value="uvirtuallayer_stream.pas"/>
<UnitName Value="uvirtuallayer_stream"/>
</Item16>
<Item17>
<Filename Value="fpolebasic.pas"/>
<UnitName Value="fpolebasic"/>
</Item17>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="1">

987
components/fpspreadsheet/uvirtuallayer.pas Normal file
View File

@@ -0,0 +1,987 @@
unit uvirtuallayer;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,strutils, Graphics,
uvirtuallayer_types,uvirtuallayer_stream;
type
{ TVirtualLayer }
TVirtualLayer=class(TObject)
private
FMountPoints: array of TVirtualMountPoint;
m_Critical: TRTLCriticalSection;
FFreeLayerStreamOnFree: Boolean;
function GetIsWritableMedia: Boolean;
function GetMountPath: UTF8String;
function GetRootLayer: TVirtualLayer;
procedure SetParentLayer(const AValue: TVirtualLayer);
function PathMountedInCurrentLayer(const APath: UTF8String): TVirtualLayer;
function BuildPathFromIndex(const ASplittedPath: TStringList; const Index: integer): UTF8String;
function FindMounted(const APath: UTF8String; out ARemainPath: UTF8String): TVirtualLayer; overload;
function FindMounted(const APath: UTF8String): TVirtualLayer; overload;
function PreviousPath(const APath: UTF8String): UTF8String;
function StripMountPoints(const APath: UTF8String): UTF8String;
protected
FParentLayer: TVirtualLayer;
FVirtualLayerStream: TStream;
FMountedInPath: UTF8String;
procedure SplitPath(const APath: UTF8String;const ASplittedPath: TStringList);
function FileToVirtualLayer(const ATargetFileName: UTF8String;out TargetVL: TVirtualLayer): Boolean;
function AcrossLayersCopy(const ASourceFileName,ATargetFileName: UTF8String): Boolean;
function AcrossLayersMove(const ASourceFileName,ATargetFileName: UTF8String): Boolean;
function NormalizePath(const APath: UTF8String): UTF8String;
function RemoveRootPathDelimiter(const APath: UTF8String): UTF8String;
function Initialize(): boolean; virtual;
//Functions to be implemented in specializations
function intfOpenFile(const AFileName: UTF8String; const AMode: cardinal): TvlHandle; virtual; abstract;
function intfCloseFile(const Handle: TvlHandle): Boolean; virtual; abstract;
function intfFindList(const APath: UTF8String; const AMask: UTF8String): TVirtualLayer_FolderList; virtual; abstract;
function intfSeek(const AHandle: TvlHandle; const APosition: int64; const Origin: word): int64; virtual; abstract;
function intfRead(const Handle: TvlHandle; const Buffer: PBYTE; const Size: int64): int64; virtual; abstract;
function intfWrite(const Handle: TvlHandle; const Buffer: PBYTE; const Size: int64): int64; virtual; abstract;
function intfGetFileSize(const AHandle: TvlHandle): int64; virtual; abstract;
function intfSetFileSize(const AHandle: TvlHandle; const ANewFileSize: int64): Boolean; virtual; abstract;
function intfDeleteFile(const AFileName: UTF8String): boolean; virtual; abstract;
function intfGetFreeSpace(const APath: UTF8String): int64; virtual; abstract;
function intfIsWritableMedia(): Boolean; virtual; abstract;
function intfMakeFolder(const AFolder: UTF8String): Boolean; virtual; abstract;
function intfRemoveFolder(const AFolder: UTF8String): Boolean; virtual; abstract;
function intfCopy(const ASourceFileName,ATargetFileName: UTF8String): Boolean; virtual;
function intfMove(const ASourceFileName,ATargetFileName: UTF8String): Boolean; virtual;
function IntfGetIcon(const APath: UTF8String): TIcon; virtual;
procedure Lock(); virtual;
procedure Unlock(); virtual;
public
function MakeFolder(const AFolder: UTF8String): Boolean;
function RemoveFolder(const AFolder: UTF8String): Boolean;
function DeleteFile(const AFileName: UTF8String): Boolean;
function Read(const Handle: TvlHandle; const Buffer: PBYTE; const Size: int64): int64;
function Write(const Handle: TvlHandle; const Buffer: PBYTE; const Size: int64): int64;
function FindList(const APath: UTF8String; const AMask: UTF8String): TVirtualLayer_FolderList;
function OpenFile(const FileName: UTF8String; const Mode: cardinal): TvlHandle;
function CloseFile(const Handle: TvlHandle): Boolean;
function GetFileSize(const AHandle: TvlHandle): int64;
function SetFileSize(const AHandle: TvlHandle; const ANewSize: int64): Boolean;
function Seek(const AHandle: TvlHandle; const APosition: int64; const Origin: Word): int64;
function FileExists(const AFileName: UTF8String): Boolean; virtual;
function MoveFile(const ASourceFileName,ATargetFileName: UTF8String): Boolean; virtual;
function CopyFile(const ASourceFileName,ATargetFileName: UTF8String): Boolean; virtual;
function GetFreeSpace(const APath: UTF8String): int64;
function FindFirst(const APath: String;const Attr: LongInt;out Rlst: sysutils.TSearchRec): LongInt;
function FindNext(var Rlst: sysutils.TSearchRec): LongInt;
procedure FindClose(Rlst: sysutils.TSearchRec);
procedure SplitFileNamePath(const AFullPath: UTF8String; out APath: UTF8String; out AFileName: UTF8String);
function PathToVirtualLayer(const APath: UTF8String): TVirtualLayer;
function CreateStream(const AFileName: UTF8String; const AMode: Cardinal): TVirtualLayer_Stream;
function Mount(const AMountPath: UTF8String; const AVirtualLayer: TVirtualLayer): Boolean;
function UnMount(const AMountPath: UTF8String; const FreeAssociatedVirtualLayer: Boolean=true): Boolean;
property FreeLayerStreamOnFree: Boolean read FFreeLayerStreamOnFree write FFreeLayerStreamOnFree;
property IsWritableMedia: Boolean read GetIsWritableMedia;
property MountPath: UTF8String read GetMountPath;
property RootLayer: TVirtualLayer read GetRootLayer;
property ParentLayer: TVirtualLayer read FParentLayer write SetParentLayer;
function GetIcon(const APath: UTF8String): TIcon;
Constructor Create(const AVirtualLayerStream: TStream);
procedure PrepareDestroy(); virtual;
Destructor Destroy(); override;
end;
implementation
type
TFileRecLocal=record
FL: TVirtualLayer_FolderList;
Attr: LongInt;
end;
PFileRecLocal=^TFileRecLocal;
{ TVirtualLayer }
procedure TVirtualLayer.SplitPath(const APath: UTF8String;const ASplittedPath: TStringList);
var
j,k: integer;
LB: integer;
Chunk: UTF8String;
ChunkC: integer;
begin
ASplittedPath.Clear;
LB:=1;
for j := 1 to Length(APath) do begin
if APath[j]='/' then begin
SetLength(Chunk,j-LB);
ChunkC:=1;
for k := LB to j-1 do begin
Chunk[ChunkC]:=APath[k];
inc(ChunkC);
end;
if Chunk<>'' Then begin
ASplittedPath.Add(Chunk);
end;
LB:=j+1;
end;
end;
if LB<Length(APath) then begin
ChunkC:=1;
SetLength(Chunk,Length(APath)-LB+1);
for k := LB to Length(APath) do begin
Chunk[ChunkC]:=APath[k];
inc(ChunkC);
end;
if Chunk<>'' Then begin
ASplittedPath.Add(Chunk);
end;
end;
end;
procedure TVirtualLayer.SetParentLayer(const AValue: TVirtualLayer);
begin
if AValue<>nil Then begin
DoneCriticalsection(m_Critical);
end;
FParentLayer:=AValue;
end;
function TVirtualLayer.GetIsWritableMedia: Boolean;
begin
Result:=false;
if intfIsWritableMedia() Then begin
//If this media is writable, all parents must be also.
if Assigned(FParentLayer) Then begin
if FParentLayer.IsWritableMedia Then begin
Result:=true;
end;
end else begin
Result:=true;
end;
end;
end;
function TVirtualLayer.FileToVirtualLayer(const ATargetFileName: UTF8String;
out TargetVL: TVirtualLayer): Boolean;
var
FileName: UTF8String;
Path: UTF8String;
begin
TargetVL:=nil;
SplitFileNamePath(ATargetFileName, Path, FileName);
if FileName='' then begin
Result:=false;
exit;
end;
TargetVL:=FindMounted(Path);
if TargetVL=nil then begin
result:=false;
exit;
end;
Result:=true;
end;
function TVirtualLayer.GetMountPath: UTF8String;
begin
if Assigned(FParentLayer) then begin
Result:=FParentLayer.MountPath+copy(FMountedInPath,2,Length(FMountedInPath));
end else begin
Result:='/';
end;
end;
function TVirtualLayer.GetRootLayer: TVirtualLayer;
var
PL: TVirtualLayer;
begin
if FParentLayer<>nil then begin
PL:=FParentLayer.GetRootLayer;
if PL=nil then begin
Result:=Self;
end else begin
Result:=PL;
end;
end else begin
Result:=Self;
end;
end;
function TVirtualLayer.PathMountedInCurrentLayer(const APath: UTF8String): TVirtualLayer;
var
j: integer;
Count: integer;
begin
Result:=nil;
Lock();
Count:=Length(FMountPoints);
for j := 0 to Count-1 do begin
with FMountPoints[j] do begin
if MountPath=APath Then begin
Result:=TVirtualLayer(MountedVirtual);
break;
end;
end;
end;
Unlock();
end;
function TVirtualLayer.BuildPathFromIndex(const ASplittedPath: TStringList;
const Index: integer): UTF8String;
var
GluePath: UTF8String;
j: integer;
begin
GluePath:='';
for j := Index to ASplittedPath.Count-1 do begin
GluePath:=GluePath+'/'+ASplittedPath[j];
end;
Result:=GluePath;
end;
procedure TVirtualLayer.Lock();
begin
if Assigned(FParentLayer) then begin
FParentLayer.Lock();
end else begin
EnterCriticalsection(m_Critical);
end;
end;
procedure TVirtualLayer.Unlock();
begin
if Assigned(FParentLayer) then begin
FParentLayer.Unlock();
end else begin
LeaveCriticalsection(m_Critical);
end;
end;
function TVirtualLayer.MakeFolder(const AFolder: UTF8String): Boolean;
var
VL: TVirtualLayer;
RemainPath: UTF8String;
begin
VL:=FindMounted(AFolder,RemainPath);
if Assigned(VL) Then begin
Result:=VL.MakeFolder(RemainPath);
end else begin
Result:=intfMakeFolder(AFolder);
end;
end;
function TVirtualLayer.RemoveFolder(const AFolder: UTF8String): Boolean;
var
VL: TVirtualLayer;
RemainPath: UTF8String;
begin
VL:=FindMounted(AFolder,RemainPath);
if Assigned(VL) Then begin
Result:=VL.RemoveFolder(RemainPath);
end else begin
Result:=intfRemoveFolder(AFolder);
end;
end;
function TVirtualLayer.DeleteFile(const AFileName: UTF8String): Boolean;
var
VL: TVirtualLayer;
RemainPath: UTF8String;
begin
VL:=FindMounted(AFileName,RemainPath);
if Assigned(VL) Then begin
Result:=VL.DeleteFile(RemainPath);
end else begin
Result:=intfDeleteFile(AFileName);
end;
end;
function TVirtualLayer.Read(const Handle: TvlHandle; const Buffer: PBYTE;
const Size: int64): int64;
var
vlHandleRecord: PvlHandleRecord;
begin
vlHandleRecord:=PvlHandleRecord(Handle);
Result:=TVirtualLayer(vlHandleRecord^.VirtualLayer).intfRead(vlHandleRecord^.Handle,Buffer,Size);
end;
function TVirtualLayer.Write(const Handle: TvlHandle; const Buffer: PBYTE;
const Size: int64): int64;
var
vlHandleRecord: PvlHandleRecord;
begin
vlHandleRecord:=PvlHandleRecord(Handle);
Result:=TVirtualLayer(vlHandleRecord^.VirtualLayer).intfWrite(vlHandleRecord^.Handle,Buffer,Size);
end;
function TVirtualLayer.FindList(const APath: UTF8String; const AMask: UTF8String
): TVirtualLayer_FolderList;
var
VL: TVirtualLayer;
RemainPath: UTF8String;
MyPath: UTF8String;
FullPath: UTF8String;
j: integer;
VI: TVirtualLayer_Item;
MountP: UTF8String;
Found: Boolean;
begin
FullPath:=NormalizePath(APath);
VL:=FindMounted(FullPath,RemainPath);
MyPath:=LeftStr(FullPath,Length(FullPath)-Length(RemainPath));
if Assigned(VL) Then begin
Result:=VL.FindList(NormalizePath(RemainPath),AMask);
if Result<>nil Then begin
Result.AddInheritedPath(MyPath);
end;
end else begin
Result:=intfFindList(FullPath,AMask);
//Add mount points for this folder
for j := 0 to Length(FMountPoints)-1 do begin
MountP:=PreviousPath(FMountPoints[j].MountPath);
if MountP<>'' Then begin
if MountP=MyPath Then begin
VI:=TVirtualLayer_Item.Create;
VI.Name:=RightStr(FMountPoints[j].MountPath,Length(FMountPoints[j].MountPath)-Length(MountP));
VI.Name:=LeftStr(VI.Name,Length(VI.Name)-1);
VI.Size:=0;
VI.IsFolder:=true;
Result.Add(VI);
end;
end;
end;
//Verify ".." folder exists (previous folder)
//Unless the current folder is the Top one.
Found:=false;
for j := 0 to Result.Count-1 do begin
VI:=TVirtualLayer_Item(Result[j]);
if VI.Name='..' Then begin
Found:=True;
break;
end;
end;
if (not Found) and (FParentLayer<>nil) Then begin
VI:=TVirtualLayer_Item.Create;
VI.Name:='..';
VI.Size:=0;
VI.IsFolder:=true;
Result.Insert(0,VI);
end;
end;
end;
function TVirtualLayer.FindMounted(const APath: UTF8String; out ARemainPath: UTF8String): TVirtualLayer;
var
PathList: TStringList;
j: integer;
CurPath: UTF8String;
VirtualLayer: TVirtualLayer;
begin
ARemainPath:='';
Result:=nil;
PathList:=TStringList.Create;
SplitPath(NormalizePath(APath),PathList);
//Remove empty strings
for j := PathList.Count-1 downto 0 do begin
if PathList[j]='' Then begin
PathList.Delete(j);
end;
end;
Lock();
CurPath:='/';
for j := 0 to PathList.Count-1 do begin
CurPath:=NormalizePath(Curpath+PathList[j]);
VirtualLayer:=PathMountedInCurrentLayer(CurPath);
if VirtualLayer<>nil Then begin;
Result:=VirtualLayer;
ARemainPath:=BuildPathFromIndex(PathList,j+1);
break;
end;
end;
PathList.Free;
Unlock();
end;
function TVirtualLayer.FindMounted(const APath: UTF8String): TVirtualLayer;
var
Remain: UTF8String;
VL: TVirtualLayer;
Path: UTF8String;
begin
Remain:=APath;
VL:=nil;
Repeat
Result:=VL;
Path:=Remain;
VL:=FindMounted(Path,Remain);
until VL=nil;
end;
function TVirtualLayer.NormalizePath(const APath: UTF8String): UTF8String;
//It should also resolve /../ path expressions.
var
j: integer;
PL: TStringList;
Skip: Boolean;
begin
if RightStr(APath,1)<>'/' then begin
Result:=APath+'/';
end else begin
Result:=APath;
end;
if LeftStr(Result,1)<>'/' then begin
Result:='/'+Result;
end;
Result:=StringReplace(Result,'/./','/',[]);
if PosEx('../',Result)>0 then begin
//Dissasemble path and reassemble it to remove the /../ path
PL:=TStringList.Create;
SplitPath(Result,PL);
for j := PL.Count-1 downto 0 do begin
if PL[j]='' Then PL.Delete(j);
end;
Skip:=False;
for j := PL.Count-1 downto 0 do begin
if Skip then begin
PL.Delete(j);
Skip:=false;
end else begin
if PL[j]='..' Then begin
PL.Delete(j);
Skip:=true;
end;
end;
end;
Result:='/';
for j := 0 to PL.Count-1 do begin
Result:=Result+PL[j]+'/';
end;
PL.Free;
end;
end;
function TVirtualLayer.RemoveRootPathDelimiter(const APath: UTF8String
): UTF8String;
begin
if Length(APath)>0 then begin
if APath[1]='/' then begin
Result:=Copy(APath,2,length(APath)-1);
end;
end;
end;
function TVirtualLayer.PreviousPath(const APath: UTF8String): UTF8String;
var
PathParts: TStringList;
j: integer;
begin
PathParts:=TStringList.Create;
SplitPath(APath,PathParts);
for j := PathParts.Count-1 downto 0 do begin
if PathParts[j]='' Then begin
PathParts.Delete(j);
end;
end;
Result:='/';
for j := 0 to PathParts.Count-2 do begin
Result:=Result+PathParts[j]+'/';
end;
PathParts.Free;
end;
function TVirtualLayer.StripMountPoints(const APath: UTF8String): UTF8String;
var
PathList: TStringList;
j: integer;
CurPath: UTF8String;
VirtualLayer: TVirtualLayer;
ARemainPath: UTF8String;
OtherPath: UTF8String;
begin
ARemainPath:='';
PathList:=TStringList.Create;
SplitPath(NormalizePath(APath),PathList);
//Remove empty strings
for j := PathList.Count-1 downto 0 do begin
if PathList[j]='' Then begin
PathList.Delete(j);
end;
end;
Lock();
CurPath:='/';
for j := 0 to PathList.Count-1 do begin
CurPath:=NormalizePath(Curpath+PathList[j]);
VirtualLayer:=PathMountedInCurrentLayer(CurPath);
if VirtualLayer<>nil Then begin;
ARemainPath:=BuildPathFromIndex(PathList,j+1);
OtherPath:=VirtualLayer.StripMountPoints(ARemainPath);
if OtherPath='' Then begin
Result:=ARemainPath;
end;
break;
end;
end;
PathList.Free;
Unlock();
end;
function TVirtualLayer.Initialize(): boolean;
begin
result:=true;
end;
function TVirtualLayer.intfCopy(const ASourceFileName,
ATargetFileName: UTF8String): Boolean;
var
L: TVirtualLayer;
begin
L:=RootLayer;
Result:=L.AcrossLayersCopy(MountPath+RemoveRootPathDelimiter(ASourceFileName),
MountPath+RemoveRootPathDelimiter(ATargetFileName));
end;
function TVirtualLayer.intfMove(const ASourceFileName,
ATargetFileName: UTF8String): Boolean;
begin
Result:=AcrossLayersMove(MountPath+RemoveRootPathDelimiter(ASourceFileName),
MountPath+RemoveRootPathDelimiter(ATargetFileName));
end;
function TVirtualLayer.IntfGetIcon(const APath: UTF8String): TIcon;
begin
Result:=nil;
if Length(APath)=0 then Result:=nil; //Avoid hint.
end;
function TVirtualLayer.AcrossLayersMove(const ASourceFileName,
ATargetFileName: UTF8String): Boolean;
begin
//By default move a file creating a new copy and deleting the old one.
//This function should be specialized for each layer.
if not intfCopy(ASourceFileName,ATargetFileName) then begin
DeleteFile(ATargetFileName);
result:=false;
end else begin
DeleteFile(ASourceFileName);
result:=true;
end;
end;
function TVirtualLayer.AcrossLayersCopy(const ASourceFileName,
ATargetFileName: UTF8String): Boolean;
var
SourceHandle, TargetHandle: TvlHandle;
FileSize: int64;
Buffer: array [0..1023] of BYTE;
WriteBytes: int64;
begin
//By default copy a file.
//This function should be specialized for each layer.
Result:=true;
SourceHandle:=OpenFile(ASourceFileName,fmOpenRead);
if SourceHandle=nil Then begin
Result:=false;
Exit;
end;
TargetHandle:=OpenFile(ATargetFileName,fmCreate);
if TargetHandle=nil Then begin
CloseFile(SourceHandle);
Result:=false;
Exit;
end;
FileSize:=GetFileSize(SourceHandle);
while FileSize>0 do begin
if FileSize>1024 Then begin
if Read(SourceHandle,@Buffer[0],1024)<>1024 Then begin
Result:=false;
break;
end else begin
WriteBytes:=1024;
dec(FileSize,1024);
end;
end else begin
if Read(SourceHandle,@Buffer[0],FileSize)<>FileSize Then begin
Result:=false;
break;
end else begin
WriteBytes:=FileSize;
FileSize:=0;
end;
end;
if Write(TargetHandle,@Buffer[0],WriteBytes)<>WriteBytes Then begin
Result:=false;
break;
end;
end;
CloseFile(SourceHandle);
CloseFile(TargetHandle);
end;
function TVirtualLayer.MoveFile(const ASourceFileName,
ATargetFileName: UTF8String): Boolean;
var
SourceVL,TargetVL: TVirtualLayer;
begin
if not FileToVirtualLayer(ATargetFileName,TargetVL) Then begin
Result:=false;
exit;
end;
if not FileToVirtualLayer(ASourceFileName,SourceVL) Then begin
Result:=false;
exit;
end;
if SourceVL=TargetVL then begin
//Move in the same virtual layer. invoke intfmove.
Result:=SourceVL.intfMove(StripMountPoints(ASourceFileName),StripMountPoints(ATargetFileName));
end else begin
Result:=intfMove(ASourceFileName,ATargetFileName);
end;
end;
function TVirtualLayer.CopyFile(const ASourceFileName, ATargetFileName: UTF8String
): Boolean;
var
SourceVL,TargetVL: TVirtualLayer;
begin
if not FileToVirtualLayer(ATargetFileName,TargetVL) Then begin
Result:=false;
exit;
end;
if not FileToVirtualLayer(ASourceFileName,SourceVL) Then begin
Result:=false;
exit;
end;
if SourceVL=TargetVL then begin
//Move in the same virtual layer. invoke intfmove.
Result:=SourceVL.intfCopy(StripMountPoints(ASourceFileName),StripMountPoints(ATargetFileName));
end else begin
Result:=AcrossLayersCopy(ASourceFileName,ATargetFileName);
end;
end;
function TVirtualLayer.OpenFile(const FileName: UTF8String; const Mode: cardinal): TvlHandle;
var
VL: TVirtualLayer;
RemainPath: UTF8String;
vlHandleRecord: PvlHandleRecord;
Handle: TvlHandle;
begin
VL:=FindMounted(FileName,RemainPath);
if Assigned(VL) Then begin
Result:=VL.OpenFile(RemainPath,Mode);
end else begin
vlHandleRecord:=nil;
Handle:=intfOpenFile(FileName,Mode);
if Handle=VL_INVALID_HANDLE then begin
Result:=VL_INVALID_HANDLE;
end else begin
GetMem(vlHandleRecord,sizeof(TvlHandleRecord));
vlHandleRecord^.Handle:=Handle;
vlHandleRecord^.VirtualLayer:=Self;
Result:=TvlHandle(vlHandleRecord);
end;
end;
end;
function TVirtualLayer.CloseFile(const Handle: TvlHandle): Boolean;
var
vlHandleRecord: PvlHandleRecord;
begin
vlHandleRecord:=PvlHandleRecord(Handle);
Result:=TVirtualLayer(vlHandleRecord^.VirtualLayer).intfCloseFile(vlHandleRecord^.Handle);
FreeMem(vlHandleRecord);
end;
function TVirtualLayer.GetFileSize(const AHandle: TvlHandle): int64;
var
vlHandleRecord: PvlHandleRecord;
begin
vlHandleRecord:=PvlHandleRecord(AHandle);
Result:=TVirtualLayer(vlHandleRecord^.VirtualLayer).intfGetFileSize(vlHandleRecord^.Handle);
end;
function TVirtualLayer.SetFileSize(const AHandle: TvlHandle;
const ANewSize: int64): Boolean;
var
vlHandleRecord: PvlHandleRecord;
begin
vlHandleRecord:=PvlHandleRecord(AHandle);
Result:=TVirtualLayer(vlHandleRecord^.VirtualLayer).intfSetFileSize(vlHandleRecord^.Handle,ANewSize);
end;
function TVirtualLayer.Seek(const AHandle: TvlHandle; const APosition: int64; const Origin: Word): int64;
var
vlHandleRecord: PvlHandleRecord;
begin
vlHandleRecord:=PvlHandleRecord(AHandle);
Result:=TVirtualLayer(vlHandleRecord^.VirtualLayer).intfSeek(vlHandleRecord^.Handle,APosition,Origin);
end;
function TVirtualLayer.FileExists(const AFileName: UTF8String): Boolean;
var
fl: TVirtualLayer_FolderList;
Path: UTF8String;
FileName: UTF8String;
j: integer;
begin
Result:=false;
SplitFileNamePath(AFileName,Path,FileName);
fl:=FindList(Path,FileName);
for j := 0 to FL.Count-1 do begin
if TVirtualLayer_Item(FL[j]).Name=FileName Then begin
Result:=true;
break;
end;
end;
fl.Free;
end;
procedure TVirtualLayer.SplitFileNamePath(const AFullPath: UTF8String; out
APath: UTF8String; out AFileName: UTF8String);
var
j: integer;
begin
APath:=AFullPath;
AFileName:='';
for j := Length(AFullPath) downto 1 do begin
if AFullPath[j]='/' Then begin
APath:=LeftStr(AFullPath,j);
AFileName:=RightStr(AFullPath,Length(AFullPath)-Length(APath));
break;
end;
end;
end;
function TVirtualLayer.Mount(const AMountPath: UTF8String;
const AVirtualLayer: TVirtualLayer): Boolean;
var
j: integer;
VL: TVirtualLayer;
RemainPath: UTF8String;
begin
if AVirtualLayer.FParentLayer<>nil Then begin
Result:=false;
Exit;
end;
Lock();
VL:=FindMounted(AMountPath,RemainPath);
if Assigned(VL) Then begin
Result:=VL.Mount(RemainPath,AVirtualLayer);
end else begin
j:=Length(FMountPoints);
SetLength(FMountPoints,j+1);
FMountPoints[j].MountPath:=NormalizePath(AMountPath);
FMountPoints[j].MountedVirtual:=AVirtualLayer;
AVirtualLayer.SetParentLayer(Self);
AVirtualLayer.FMountedInPath:=FMountPoints[j].MountPath;
Result:=true;
end;
Unlock();
end;
function TVirtualLayer.UnMount(const AMountPath: UTF8String;
const FreeAssociatedVirtualLayer: Boolean): Boolean;
var
j,k: integer;
VirtualLayer: TVirtualLayer;
RemainPath: UTF8String;
begin
Result:=false;
Lock();
VirtualLayer:=FindMounted(AMountPath,RemainPath);
if Assigned(VirtualLayer) Then begin
Result:=VirtualLayer.UnMount(RemainPath,FreeAssociatedVirtualLayer);
end else begin
for j := 0 to Length(FMountPoints)-1 do begin
if FMountPoints[j].MountPath=AMountPath Then begin
VirtualLayer:=TVirtualLayer(FMountPoints[j].MountedVirtual);
for k := j+1 to Length(FMountPoints)-1 do begin
FMountPoints[k-1].MountPath:=FMountPoints[k].MountPath;
FMountPoints[k-1].MountedVirtual:=FMountPoints[k].MountedVirtual;
end;
SetLength(FMountPoints,Length(FMountPoints)-1);
if FreeAssociatedVirtualLayer Then begin
VirtualLayer.Free;
end;
Result:=true;
break;
end;
end;
end;
Unlock();
end;
function TVirtualLayer.GetIcon(const APath: UTF8String): TIcon;
var
VL: TVirtualLayer;
RemainPath: UTF8String;
begin
VL:=FindMounted(APath,RemainPath);
if Assigned(VL) Then begin
Result:=VL.IntfGetIcon(RemainPath);
end else begin
Result:=IntfGetIcon(APath);
end;
end;
function TVirtualLayer.PathToVirtualLayer(const APath: UTF8String
): TVirtualLayer;
var
RemainPath: UTF8String;
begin
Result:=FindMounted(APath,RemainPath);
if Result=nil Then Result:=Self;
end;
function TVirtualLayer.CreateStream(const AFileName: UTF8String;
const AMode: Cardinal): TVirtualLayer_Stream;
begin
try
result:=TVirtualLayer_Stream.Create(Self,AFileName,AMode);
except
on E: EStreamError do begin
Result:=nil;
end;
end;
end;
function TVirtualLayer.GetFreeSpace(const APath: UTF8String): int64;
var
VL: TVirtualLayer;
RemainPath: UTF8String;
begin
VL:=FindMounted(APath,RemainPath);
if Assigned(VL) Then begin
Result:=VL.GetFreeSpace(RemainPath);
end else begin
Result:=intfGetFreeSpace(APath);
end;
end;
function TVirtualLayer.FindFirst(const APath: String; const Attr: LongInt; out
Rlst: sysutils.TSearchRec): LongInt;
var
FindL: TVirtualLayer_FolderList;
Path: UTF8String;
Mask: UTF8String;
LHandle: PFileRecLocal;
begin
Result:=-1;
with Rlst do begin
Time:=0;
Size:=0;
Attr:=0;
Name:='';
ExcludeAttr:=0;
end;
SplitFileNamePath(APath,Path,Mask);
FindL:=FindList(APath,Mask);
LHandle:=nil;
GetMem(LHandle,sizeof(TFileRecLocal));
LHandle^.FL:=FindL;
LHandle^.Attr:=Attr;
{$HINTS OFF}
Rlst.FindHandle:=PtrUint(LHandle);
{$HINTS ON}
if Assigned(FindL) Then begin
if FindL.Count>0 Then begin
With FindL[0] do begin
Rlst.Name:=Name;
Rlst.Size:=Size;
if IsFolder or IsMountPoint Then begin
Rlst.Attr:=Rlst.Attr+faDirectory;
end;
end;
FindL.Delete(0);
Result:=0;
end;
end;
end;
function TVirtualLayer.FindNext(var Rlst: sysutils.TSearchRec): LongInt;
var
FindL: TVirtualLayer_FolderList;
LHandle: PFileRecLocal;
begin
Result:=-1;
with Rlst do begin
Time:=0;
Size:=0;
Attr:=0;
Name:='';
ExcludeAttr:=0;
end;
LHandle:=PFileRecLocal(Rlst.FindHandle);
FindL:=TVirtualLayer_FolderList(LHandle^.FL);
if Assigned(FindL) Then begin
if FindL.Count>0 Then begin
With FindL[0] do begin
Rlst.Name:=Name;
Rlst.Size:=Size;
if IsFolder or IsMountPoint Then begin
Rlst.Attr:=Rlst.Attr or faDirectory;
end;
end;
FindL.Delete(0);
Result:=0;
end;
end;
end;
procedure TVirtualLayer.FindClose(Rlst: sysutils.TSearchRec);
var
FindL: TVirtualLayer_FolderList;
LHandle: PFileRecLocal;
begin
LHandle:=PFileRecLocal(Rlst.FindHandle);
FindL:=TVirtualLayer_FolderList(LHandle^.FL);
if Assigned(FindL) Then FindL.Free;
FreeMem(LHandle);
end;
constructor TVirtualLayer.Create(const AVirtualLayerStream: TStream);
begin
InitCriticalSection(m_Critical);
FVirtualLayerStream:=AVirtualLayerStream;
if Assigned(FVirtualLayerStream) Then FVirtualLayerStream.Position:=0;
end;
procedure TVirtualLayer.PrepareDestroy();
begin
//Do nothing by default.
end;
destructor TVirtualLayer.Destroy();
var
j: integer;
begin
//Notify mounted layers to write anything they need to.
for j := Length(FMountPoints)-1 downto 0 do begin
TVirtualLayer(FMountPoints[j].MountedVirtual).PrepareDestroy();
end;
//Destroy mounted layers, they must also close related handles.
for j := Length(FMountPoints)-1 downto 0 do begin
TVirtualLayer(FMountPoints[j].MountedVirtual).Free;
end;
if FFreeLayerStreamOnFree Then begin
if Assigned(FVirtualLayerStream) Then begin
FVirtualLayerStream.Free;
end;
end;
if not Assigned(FParentLayer) then begin
DoneCriticalsection(m_Critical);
end;
inherited Destroy();
end;
end.

682
components/fpspreadsheet/uvirtuallayer_ole.pas Normal file
View File

@@ -0,0 +1,682 @@
{
uvirtuallayer_ole.pas
Creates a virtual layer over a stream to access an Microsoft OLE document
using similar functionality as a regular file in a disk. It can create streams
and storages and, read and enumerate them.
Based in the TVirtualLayer class, so it can be stacked (mounted).
Status of operations:
* Enumerate streams and storages: Operative.
* Create stream: Currently only on "Root Folder".
* Create storage: Not working.
* Read stream: Operative.
* Delete stream: Not working.
* Delete storage: Not working.
* Attributes read: Not working.
* Attributes write: Not working.
* Regular streams: Operative.
* Mini streams: Operative.
* Streams read/write concurrence: Not fully operative.
* Root directory coloring: All are black.
* 32/64 bits: Not tested (mostly compliant).
* Multithreading: Not working (*1).
* Little endian platform: Operative.
* Big endian platform: Operative (tests needed).
* Create LE OLE files: Operative.
* Create BE OLE files: Not supported by default (use format func.).
* OLE bigger than 2 GB: Not working.
* Known bugs: Streams multiple of sector size will have
one sector allocated in excess.
* Whole status: Alpha (9 May 2009)
*1: Multithreading is not implemented by design in TVirtualLayer and its
descendants will not be multithreading safe. This does not means that
you can not use them in a Multithreading environment, but concurrent
access to any layer from different threads at the same time will give
unpredictable results. Basic blocking is provided by TVirtualLayer but
this means that accesses will not be truly concurrent. Different layers
will expose different stability when called from several threads at the
same time, so in other words do not access virtual layers from different
threads at the same time or the world could KBOOM! :)
OLE comments: OLE files, aka "Windows Compound Binary Format", presents some
limitations. In version 3 they can not be bigger than 2 GB even
when the storage format allows more than 2 TB. Sector size even
when defined in the header it is tied to the "DllVersion" and not
to the "FileVersion" which means version 3 = 512 bytes per sector
and version 4 = 4096 bytes per sector. Version 4 should be able to
read sectors of 512 bytes and 4096 but this point has not been
tested as no version 4 real files to test has been found.
Related files: uvirtuallayer_ole
uvirtuallayer_ole_helpers
uvirtuallayer_ole_types
AUTHORS: José Mejuto Porral
}
unit uvirtuallayer_ole;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Masks
,uvirtuallayer_types
,uvirtuallayer
,uvirtuallayer_ole_helpers
,uvirtuallayer_ole_types
;
type
{ TVirtualLayer_wincompound }
TVirtualLayer_OLE=class(TVirtualLayer)
private
procedure UseParameter(const Parameter);
procedure SwapEndian_Record(var D: TWCBFStructuredStorageHeader);
procedure SwapEndian_Record(var D: TWCBFStructuredStorageDirectoryEntry);
Procedure NotImplemented();
function ReadData(const Index: integer; const Buffer: PBYTE; const Size: int64): int64;
function GetStorageFirstSID(const APath: UTF8String): SID;
function GetStreamSID(const APath: UTF8String): SID;
function FindFreeOpenFile(): integer;
procedure DeleteSIDData(const ASID: SID);
function CreateNewSID(const AType: etagSTGTY): SID;
procedure InsertInDirectoryTree(const ASID,AMasterSID: SID);
OpenedStreams: array of TWCBFOpenStream;
FFATIndirect: TFATIndirect;
protected
function intfGetFreeSpace(const APath: UTF8String): int64; override;
function intfIsWritableMedia(): Boolean; override;
function intfFindList(const APath: UTF8String; const AMask: UTF8String): TVirtualLayer_FolderList; override;
function intfOpenFile(const AFileName: UTF8String; const AMode: cardinal): TvlHandle; override;
function intfCloseFile(const Handle: TvlHandle): Boolean; override;
function intfRead(const Handle: TvlHandle; const Buffer: PBYTE; const Size: int64): int64; override;
function intfSeek(const AHandle: TvlHandle; const APosition: int64; const Origin: word): int64; override;
function intfGetFileSize(const AHandle: TvlHandle): int64; override;
//Not implemented....
function intfWrite(const Handle: TvlHandle; const Buffer: PBYTE; const Size: int64): int64; override;
function intfSetFileSize(const AHandle: TvlHandle; const ANewFileSize: int64): Boolean; override;
function intfDeleteFile(const AFileName: UTF8String): boolean; override;
function intfMakeFolder(const AFolder: UTF8String): Boolean; override;
function intfRemoveFolder(const AFolder: UTF8String): Boolean; override;
//..Not implemented
FDirectory: array of TWCBFStructuredStorageDirectoryEntry;
procedure AfterConstruction; override;
public
procedure Format();
function Initialize():boolean; override;
destructor Destroy(); override;
end;
implementation
function HandleToIndex(const Handle: TvlHandle; out Index: integer): Boolean;
var
X: PtrUInt;
begin
{$HINTS OFF}
X:=PtrUInt(Handle);
{$HINTS ON}
index:=X-1;
if (Index<0) Then begin
Result:=false;
end else begin
Result:=true;
end;
end;
function IndexToHandle(const Index: integer): TvlHandle;
begin
{$HINTS OFF}
Result:=TvlHandle(Index+1);
{$HINTS ON}
end;
{ TVirtualLayer_OLE }
{$HINTS OFF}
procedure TVirtualLayer_OLE.UseParameter(const Parameter);
begin
//Do nothing
end;
{$HINTS ON}
procedure TVirtualLayer_OLE.SwapEndian_Record(var D: TWCBFStructuredStorageHeader);
var
j: integer;
begin
{$IFDEF FPC}
{$IFDEF FPC_LITTLE_ENDIAN}
UseParameter(D);
j:=0;
UseParameter(j);
{$ELSE}
d._csectDif:=SwapEndian(d._csectDif);
d._csectFat:=SwapEndian(d._csectFat);
d._csectMiniFat:=SwapEndian(d._csectMiniFat);
d._sectDifStart:=SwapEndian(d._sectDifStart);
d._sectDirStart:=SwapEndian(d._sectDirStart);
d._uMinorVersion:=SwapEndian(d._uMinorVersion);
d._uDllVersion:=SwapEndian(d._uDllVersion);
d._uByteOrder:=SwapEndian(d._uByteOrder);
d._uSectorShift:=SwapEndian(d._uSectorShift);
d._uMiniSectorShift:=SwapEndian(d._uMiniSectorShift);
d._signature:=SwapEndian(d._signature);
d._ulMiniSectorCutoff:=SwapEndian(d._ulMiniSectorCutoff);
d._sectMiniFatStart:=SwapEndian(d._sectMiniFatStart);
for j := 0 to 108 do begin
d._sectFat[j]:=SwapEndian(d._sectFat[j]);
end;
{$ENDIF}
{$ENDIF}
end;
procedure TVirtualLayer_OLE.SwapEndian_Record(
var D: TWCBFStructuredStorageDirectoryEntry);
var
j: integer;
begin
{$IFDEF FPC}
{$IFDEF FPC_LITTLE_ENDIAN}
j:=0;
UseParameter(D);
UseParameter(j);
{$ELSE}
for j := 0 to 31 do begin
d._ab[j]:=WChar(SwapEndian(WORD(d._ab[j])));
end;
d._time[0].dwHighDateTime:=SwapEndian(d._time[0].dwHighDateTime);
d._time[0].dwLowDateTime :=SwapEndian(d._time[0].dwLowDateTime);
d._time[1].dwHighDateTime:=SwapEndian(d._time[1].dwHighDateTime);
d._time[1].dwLowDateTime :=SwapEndian(d._time[1].dwLowDateTime);
d._cb :=SwapEndian(d._cb);
d._mse :=SwapEndian(d._mse);
d._bflags :=SwapEndian(d._bflags);
d._sidLeftSib :=SwapEndian(d._sidLeftSib);
d._sidRightSib :=SwapEndian(d._sidRightSib);
d._sidChild :=SwapEndian(d._sidChild);
d._dwUserFlags :=SwapEndian(d._dwUserFlags);
d._sectStart :=SwapEndian(d._sectStart);
d._ulSize :=SwapEndian(d._ulSize);
d._dptPropType :=SwapEndian(d._dptPropType);
{$ENDIF}
{$ENDIF}
end;
procedure TVirtualLayer_OLE.NotImplemented();
begin
Raise Exception.Create('Not implemented or not possible to be done.');
end;
function TVirtualLayer_OLE.ReadData(const Index: integer;
const Buffer: PBYTE; const Size: int64): int64;
begin
Result:=FFATIndirect.ReadData(OpenedStreams[Index].Context,Buffer,Size);
end;
function TVirtualLayer_OLE.GetStorageFirstSID(const APath: UTF8String
): SID;
var
Splitted: TStringList;
j: integer;
SIDChild: SID;
function FindSiblingWithName(const AName: WideString; const AStartSibling: integer): SID;
begin
if (FDirectory[AStartSibling]._ab=AName) and (FDirectory[AStartSibling]._mse<>BYTE(STGTY_INVALID)) then begin
Result:=FDirectory[AStartSibling]._sidChild;
end else begin
Result:=WINCOMPOUND_NOSID;
if FDirectory[AStartSibling]._sidLeftSib<>WINCOMPOUND_NOSID then begin
Result:=FindSiblingWithName(AName,FDirectory[AStartSibling]._sidLeftSib);
end;
if Result<>WINCOMPOUND_NOSID then exit;
if FDirectory[AStartSibling]._sidRightSib<>WINCOMPOUND_NOSID then begin
Result:=FindSiblingWithName(AName,FDirectory[AStartSibling]._sidRightSib);
end;
end;
end;
begin
Splitted:=TStringList.Create;
SplitPath(APath,Splitted);
if Length(FDirectory)<=1 then begin
Splitted.Free;
Result:=WINCOMPOUND_NOSID;
Exit;
end;
SIDChild:=FDirectory[0]._sidChild;
for j := 0 to Splitted.Count-1 do begin
SIDChild:=FindSiblingWithName(UTF8Decode(Splitted[j]),SIDChild);
if SIDChild=WINCOMPOUND_NOSID then break;
end;
Splitted.Free;
Result:=SIDChild;
end;
function TVirtualLayer_OLE.GetStreamSID(const APath: UTF8String): SID;
var
Splitted: TStringList;
j: integer;
SIDChild: SID;
function FindSiblingWithName(const AName: WideString; const AStartSibling: integer): SID;
begin
if (FDirectory[AStartSibling]._ab=AName) and (FDirectory[AStartSibling]._mse<>BYTE(STGTY_INVALID)) then begin
Result:=AStartSibling;
end else begin
Result:=WINCOMPOUND_NOSID;
if FDirectory[AStartSibling]._sidLeftSib<>WINCOMPOUND_NOSID then begin
Result:=FindSiblingWithName(AName,FDirectory[AStartSibling]._sidLeftSib);
end;
if Result<>WINCOMPOUND_NOSID then exit;
if FDirectory[AStartSibling]._sidRightSib<>WINCOMPOUND_NOSID then begin
Result:=FindSiblingWithName(AName,FDirectory[AStartSibling]._sidRightSib);
end;
end;
end;
begin
Splitted:=TStringList.Create;
SplitPath(APath,Splitted);
if Length(FDirectory)<=1 then begin
Splitted.Free;
Result:=WINCOMPOUND_NOSID;
Exit;
end;
SIDChild:=0;
for j := 0 to Splitted.Count-1 do begin
SIDChild:=FDirectory[SIDChild]._sidChild;
SIDChild:=FindSiblingWithName(UTF8Decode(Splitted[j]),SIDChild);
if SIDChild=WINCOMPOUND_NOSID then break;
end;
Splitted.Free;
Result:=SIDChild;
end;
function TVirtualLayer_OLE.intfFindList(const APath: UTF8String;
const AMask: UTF8String): TVirtualLayer_FolderList;
var
LI: TVirtualLayer_FolderList;
Mask: TMask;
SSID: SID;
function AddNamesWithSID(const AStartSibling: SID): SID;
var
Name: WideString;
VI: TVirtualLayer_Item;
begin
Name:=UTF8Encode(FDirectory[AStartSibling]._ab);
if Mask.Matches(Name) Then begin
VI:=TVirtualLayer_Item.Create;
VI.Name:=Name;
if FDirectory[AStartSibling]._mse=integer(STGTY_STORAGE) then begin
//It is a "folder"
VI.IsFolder:=true;
end else begin
VI.Size:=FDirectory[AStartSibling]._ulSize;
VI.IsFolder:=false;
end;
LI.Add(VI);
end;
Result:=WINCOMPOUND_NOSID;
if FDirectory[AStartSibling]._sidLeftSib<>WINCOMPOUND_NOSID then begin
Result:=AddNamesWithSID(FDirectory[AStartSibling]._sidLeftSib);
end;
if FDirectory[AStartSibling]._sidRightSib<>WINCOMPOUND_NOSID then begin
Result:=AddNamesWithSID(FDirectory[AStartSibling]._sidRightSib);
end;
end;
begin
//Find the storage SID for the path...
SSID:=GetStorageFirstSID(APath);
if SSID=WINCOMPOUND_NOSID then begin
LI:=TVirtualLayer_FolderList.Create(APath);
Result:=LI; //Empty items list
Exit;
end;
Mask:=TMask.Create(AMask);
LI:=TVirtualLayer_FolderList.Create(APath);
AddNamesWithSID(SSID);
Mask.Free;
Result:=Li;
end;
function TVirtualLayer_OLE.intfOpenFile(const AFileName: UTF8String;
const AMode: cardinal): TvlHandle;
var
SSID,ParentSID: SID;
CurHandle: TWCBFOpenStream;
Index: integer;
Path,StreamName: UTF8String;
begin
SSID:=GetStreamSID(AFileName);
if SSID=WINCOMPOUND_NOSID then begin
//Stream not found
if AMode<>fmCreate then begin
//It should not be created
Result:=nil;
Exit;
end;
end;
if AMode=fmCreate then begin
FFATIndirect.DirtyMedia:=true;
if SSID<>WINCOMPOUND_NOSID then begin
//File already exists, so clear all the FAT links and adjust size to cero
DeleteSIDData(SSID);
with FDirectory[SSID] do begin
_sectStart:=SECT_ENDOFCHAIN;
_ulSize:=0;
end;
end else begin
//Create a new SID and link it to the tree...
SplitFileNamePath(AFileName,Path,StreamName);
SSID:=CreateNewSID(STGTY_STREAM);
FDirectory[SSID]._ab:=UTF8Decode(StreamName);
FDirectory[SSID]._cb:=(Length(UTF8Decode(StreamName))+1)*SizeOf(WChar);
ParentSID:=GetStreamSID(Path);
if FDirectory[ParentSID]._sidChild=WINCOMPOUND_NOSID then begin
//This one is the first entry in this storage.
FDirectory[ParentSID]._sidChild:=SSID;
end else begin
//There are already some entries in this storage, explore the tree
//and insert the new SID in the right position.
InsertInDirectoryTree(SSID,FDirectory[ParentSID]._sidChild);
end;
end;
end;
CurHandle.Handle:=SSID;
CurHandle.Context:=FFATIndirect.OpenStream(FDirectory[SSID]._sectStart,FDirectory[SSID]._ulSize,AMode);
Index:=FindFreeOpenFile();
if Index=integer(feInvalidHandle) then begin
Index:=Length(OpenedStreams);
SetLength(OpenedStreams,Index+1);
end;
OpenedStreams[Index]:=CurHandle;
Result:=IndexToHandle(Index);
end;
function TVirtualLayer_OLE.intfCloseFile(const Handle: TvlHandle
): Boolean;
var
Index: integer;
begin
if not HandleToIndex(Handle,Index) Then begin
Result:=false;
end else begin
if Index>High(OpenedStreams) then begin
Result:=false;
end else begin
FFATIndirect.CloseStream(OpenedStreams[Index].Context);
FDirectory[OpenedStreams[Index].Handle]._sectStart:=OpenedStreams[Index].Context.FATFirstIndex;
FDirectory[OpenedStreams[Index].Handle]._ulSize:=OpenedStreams[Index].Context.Size;
OpenedStreams[Index].Handle:=WINCOMPOUND_NOSID;
OpenedStreams[Index].Context.FATFirstIndex:=SECT_ENDOFCHAIN;
OpenedStreams[Index].Context.FATIndex:=SECT_ENDOFCHAIN;
OpenedStreams[Index].Context.Size:=0;
OpenedStreams[Index].Context.Position:=0;
Result:=true;
end;
end;
end;
function TVirtualLayer_OLE.intfSeek(const AHandle: TvlHandle;
const APosition: int64; const Origin: word): int64;
var
index: PtrInt;
begin
if not HandleToIndex(AHandle,Index) Then begin
Result:=-1;
Exit;
end;
Result:=FFATIndirect.StreamSeekPosition(OpenedStreams[Index].Context,APosition,TSeekOrigin(Origin));
end;
function TVirtualLayer_OLE.intfRead(const Handle: TvlHandle;
const Buffer: PBYTE; const Size: int64): int64;
var
index: integer;
begin
if not HandleToIndex(Handle,Index) then begin
Result:=0;
Exit;
end;
result:=FFATIndirect.ReadData(OpenedStreams[index].Context,Buffer,Size);
end;
function TVirtualLayer_OLE.intfWrite(const Handle: TvlHandle;
const Buffer: PBYTE; const Size: int64): int64;
var
index: integer;
begin
if not HandleToIndex(Handle,Index) then begin
Result:=0;
Exit;
end;
result:=FFATIndirect.WriteData(OpenedStreams[index].Context,Buffer,Size);
end;
function TVirtualLayer_OLE.intfGetFileSize(const AHandle: TvlHandle
): int64;
var
Index: integer;
begin
if not HandleToIndex(AHandle,Index) then begin
Result:=0;
Exit;
end;
Result:=FDirectory[OpenedStreams[index].Handle]._ulSize;
end;
function TVirtualLayer_OLE.intfSetFileSize(const AHandle: TvlHandle;
const ANewFileSize: int64): Boolean;
begin
UseParameter(AHandle);UseParameter(ANewFileSize);
NotImplemented();
Result:=false;
end;
function TVirtualLayer_OLE.intfDeleteFile(const AFileName: UTF8String
): boolean;
begin
UseParameter(AFileName);
NotImplemented();
Result:=false;
end;
function TVirtualLayer_OLE.intfMakeFolder(const AFolder: UTF8String
): Boolean;
begin
UseParameter(AFolder);
NotImplemented();
Result:=false;
end;
function TVirtualLayer_OLE.intfRemoveFolder(const AFolder: UTF8String
): Boolean;
begin
UseParameter(AFolder);
NotImplemented();
Result:=false;
end;
procedure TVirtualLayer_OLE.AfterConstruction;
begin
inherited AfterConstruction;
FFATIndirect:=TFATIndirect.Create(FVirtualLayerStream);
end;
procedure TVirtualLayer_OLE.Format();
begin
FFATIndirect.Initialize(true);
FFATIndirect.Free;
FFATIndirect:=TFATIndirect.Create(FVirtualLayerStream);
Self.Initialize();
end;
function TVirtualLayer_OLE.intfGetFreeSpace(const APath: UTF8String
): int64;
begin
//This is a quite large operation, all FAT sectors must be
//loaded and look for USED ones and discount them for the
//maximun theorical which is:
// Sectors=4294967280
// SectorsForFATs=Sectors div FATEntriesPerSect + 109
// SectorsInDIFs=SectorsForFATs div (FATEntriesPerSect-1)
// .......
// Too complex, so use the maximun theorical which is
// Sectors * SectorSize which taken default settings is
// 2,199,023,247,360 bytes or roughly around 2.2 TeraBytes.
// but due usual desing flaws version 3 files are limited
// to 2 GB and version 4 (4 Kb sectors) are limited to 512 GB.
UseParameter(APath);
Result:=0;
end;
function TVirtualLayer_OLE.intfIsWritableMedia(): Boolean;
begin
Result:=true;
end;
function TVirtualLayer_OLE.FindFreeOpenFile(): integer;
var
j: integer;
begin
for j := 0 to High(OpenedStreams) do begin
if OpenedStreams[j].Handle=WINCOMPOUND_NOSID Then begin
Result:=j;
Exit;
end;
end;
Result:=integer(feInvalidHandle);
end;
procedure TVirtualLayer_OLE.DeleteSIDData(const ASID: SID);
begin
If FFATIndirect.IsSizeInMiniFAT(FDirectory[ASID]._ulSize) then begin
FFATIndirect.ResetMiniFATLinkage(FDirectory[ASID]._sectStart,SECT_FREESECT);
end else begin
FFATIndirect.ResetFATLinkage(FDirectory[ASID]._sectStart,SECT_FREESECT);
end;
//TODO: Resync handles to this SID.
end;
function TVirtualLayer_OLE.CreateNewSID(const AType: etagSTGTY): SID;
var
j: SizeUint;
procedure SetDefaults(var D: TWCBFStructuredStorageDirectoryEntry);
begin
FillByte(D,Sizeof(D),0);
D._mse:=BYTE(AType);
D._sectStart:=SECT_ENDOFCHAIN;
D._bflags:=BYTE(DE_BLACK); //All are blacks in this implement.
D._cb:=2; //NULL string
D._sidChild:=WINCOMPOUND_NOSID;
D._sidLeftSib:=WINCOMPOUND_NOSID;
D._sidRightSib:=WINCOMPOUND_NOSID;
//Ths other fields are zero.
end;
begin
for j := 0 to High(FDirectory) do begin
if FDirectory[j]._mse=BYTE(STGTY_INVALID) then begin
//Reuse this entry and blank it
SetDefaults(FDirectory[j]);
Result:=j;
Exit;
end;
end;
j:=Length(FDirectory);
SetLength(FDirectory,j+1);
SetDefaults(FDirectory[j]);
Result:=j;
end;
procedure TVirtualLayer_OLE.InsertInDirectoryTree(const ASID,
AMasterSID: SID);
begin
if FDirectory[ASID]._ab > FDirectory[AMasterSID]._ab then begin
if FDirectory[AMasterSID]._sidLeftSib=WINCOMPOUND_NOSID then begin
FDirectory[AMasterSID]._sidLeftSib:=ASID;
end else begin
InsertInDirectoryTree(ASID,FDirectory[AMasterSID]._sidLeftSib);
end;
end else begin
if FDirectory[AMasterSID]._sidRightSib=WINCOMPOUND_NOSID then begin
FDirectory[AMasterSID]._sidLeftSib:=ASID;
end else begin
InsertInDirectoryTree(ASID,FDirectory[AMasterSID]._sidRightSib);
end;
end;
end;
function TVirtualLayer_OLE.Initialize(): boolean;
var
Dir: TWCBFStructuredStorageDirectoryEntry;
DirEntry: integer;
EffectiveRead: SizeInt;
begin
if not FFATIndirect.Initialize(false) then begin
//Unable to initialize component.
Result:=false;
exit;
end;
SetLength(OpenedStreams,1);
OpenedStreams[0].Handle:=0;
OpenedStreams[0].Context:=FFATIndirect.DirectoryContext;
while true do begin
EffectiveRead:=FFATIndirect.ReadData(FFATIndirect.DirectoryContext,@Dir,Sizeof(Dir));
SwapEndian_Record(Dir);
if EffectiveRead=Sizeof(Dir) Then begin
if Dir._cb>0 then begin
//Load all, as even "deleted" entries must be preserved as the
//SID (index in dir) is constant for all the file life (of course
//they can be renumbered, but better do it in the save process).
DirEntry:=Length(FDirectory);
SetLength(FDirectory,DirEntry+1);
FDirectory[DirEntry]:=Dir;
end else begin
//Empty name means end of dir.
Break;
end;
end else begin
break;
end;
end;
if Length(FDirectory)>0 then Result:=true else Result:=false;
end;
destructor TVirtualLayer_OLE.Destroy();
var
j: SizeUint;
EmptyDir: TWCBFStructuredStorageDirectoryEntry;
begin
if FFATIndirect.DirtyMedia Then begin
//Update Root entry values
FDirectory[0]._sectStart:=FFATIndirect.MiniFATDataContext.FATFirstIndex;
FDirectory[0]._ulSize:=FFATIndirect.MiniFATDataContext.Size;
FFATIndirect.StreamSeekPosition(FFATIndirect.DirectoryContext,0,soBeginning);
for j := 0 to High(FDirectory) do begin
FFATIndirect.WriteData(FFATIndirect.DirectoryContext,@FDirectory[j],sizeof(FDirectory[j]));
end;
EmptyDir._sidRightSib:=0; //Avoid uninitialize hint.
FillByte(EmptyDir,sizeof(EmptyDir),0);
FFATIndirect.WriteData(FFATIndirect.DirectoryContext,@EmptyDir,sizeof(EmptyDir));
end;
FreeAndNIL(FFATIndirect);
inherited Destroy();
end;
end.

1258
components/fpspreadsheet/uvirtuallayer_ole_helpers.pas Normal file
View File

File diff suppressed because it is too large Load Diff

102
components/fpspreadsheet/uvirtuallayer_ole_types.pas Normal file
View File

@@ -0,0 +1,102 @@
{
uvirtuallayer_ole_types.pas
Part of "uvirtuallayer_ole".
Presented as an unit to hide definitions when using OLE virtual
layer.
AUTHORS: José Mejuto Porral
}
unit uvirtuallayer_ole_types;
{$mode objfpc}{$H+}
interface
const
SECT_DIFSECT = $FFFFFFFC;
SECT_FATSECT = $FFFFFFFD;
SECT_ENDOFCHAIN = $FFFFFFFE;
SECT_FREESECT = $FFFFFFFF;
BYTES_PER_FAT_ENTRY=4;
OLE_SIGTATURE: array [0..7] of BYTE =($D0,$CF,$11,$E0,$A1,$B1,$1A,$E1);
WINCOMPOUND_NOSID=$FFFFFFFF;
type
tagFILETIME=packed record
dwLowDateTime: DWORD;
dwHighDateTime: DWORD;
end;
FILETIME=tagFILETIME;
TIME_T=tagFILETIME;
SID=DWORD;
SECT=DWORD;
PSECT=^SECT;
DFPROPTYPE=WORD;
FSINDEX=DWORD;
TWCBFStructuredStorageHeader=packed record
_abSig: array [0..7] of BYTE; // [000H,08] {0xd0, 0xcf, 0x11, 0xe0, 0xa1, 0xb1, 0x1a, 0xe1} for current version,
// which are also supported by the reference implementation
_clid: TGUID; // [008H,16] class id (set with WriteClassStg, retrieved with GetClassFile/ReadClassStg)
_uMinorVersion: WORD; // [018H,02] minor version of the format: 33 is written by reference implementation
_uDllVersion: WORD; // [01AH,02] major version of the dll/format: 3 is written by reference implementation
_uByteOrder: WORD; // [01CH,02] 0xFFFE: indicates Intel byte-ordering
_uSectorShift: WORD; // [01EH,02] size of sectors in power-of-two (typically 9, indicating 512-byte sectors)
_uMiniSectorShift: WORD; // [020H,02] size of mini-sectors in power-of-two (typically 6, indicating 64-byte mini-sectors)
_usReserved: WORD; // [022H,02] reserved, must be zero
_ulReserved1: DWORD; // [024H,04] reserved, must be zero
_ulReserved2: DWORD; // [028H,04] reserved, must be zero
_csectFat: DWORD; // [02CH,04] number of SECTs in the FAT chain
_sectDirStart: DWORD; // [030H,04] first SECT in the Directory chain
_signature: DWORD; // [034H,04] signature used for transactionin: must be zero. The reference implementation
// does not support transactioning
_ulMiniSectorCutoff: DWORD; // [038H,04] maximum size for mini-streams: typically 4096 bytes
_sectMiniFatStart: DWORD; // [03CH,04] first SECT in the mini-FAT chain
_csectMiniFat: DWORD; // [040H,04] number of SECTs in the mini-FAT chain
_sectDifStart: DWORD; // [044H,04] first SECT in the DIF chain
_csectDif: DWORD; // [048H,04] number of SECTs in the DIF chain
_sectFat: array [0..108] of DWORD;// [04CH,436] the SECTs of the first 109 FAT sectors
end;
PWCBFStructuredStorageHeader=^TWCBFStructuredStorageHeader;
type etagSTGTY=(
STGTY_INVALID = 0,
STGTY_STORAGE = 1,
STGTY_STREAM = 2,
STGTY_LOCKBYTES = 3,
STGTY_PROPERTY = 4,
STGTY_ROOT = 5
);
type etagDECOLOR=(
DE_RED = 0,
DE_BLACK = 1
);
TWCBFStructuredStorageDirectoryEntry=packed record// [offset from start in bytes, length in bytes]
_ab: array [0..31] of WChar; // [000H,64] 64 bytes. The Element name in Unicode, padded with zeros t
// fill this byte array
_cb: WORD; // [040H,02] Length of the Element name in characters, not bytes
_mse: BYTE; // [042H,01] Type of object: value taken from the STGTY enumeration
_bflags: BYTE; // [043H,01] Value taken from DECOLOR enumeration.
_sidLeftSib: SID; // [044H,04] SID of the left-sibling of this entry in the directory tree
_sidRightSib: SID; // [048H,04] SID of the right-sibling of this entry in the directory tree
_sidChild: SID; // [04CH,04] SID of the child acting as the root of all the children of this
// element (if _mse=STGTY_STORAGE)
_clsId: TGUID; // [050H,16] CLSID of this storage (if _mse=STGTY_STORAGE)
_dwUserFlags: DWORD; // [060H,04] User flags of this storage (if _mse=STGTY_STORAGE)
_time: array [0..1] of TIME_T; // [064H,16] Create/Modify time-stamps (if _mse=STGTY_STORAGE)
_sectStart: SECT; // [074H,04] starting SECT of the stream (if _mse=STGTY_STREAM)
_ulSize: DWORD; // [078H,04] size of stream in bytes (if _mse=STGTY_STREAM)
_dptPropType: DFPROPTYPE; // [07CH,02] Reserved for future use. Must be zero.
_Padding: array [0..1] of BYTE;
end;
implementation
end.

111
components/fpspreadsheet/uvirtuallayer_stream.pas Normal file
View File

@@ -0,0 +1,111 @@
unit uvirtuallayer_stream;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
uvirtuallayer_types;
type
{ TVirtualLayer_Stream }
TVirtualLayer_Stream=class(TStream)
private
FRootVirtualLayer: Pointer;
FHandle: TvlHandle;
protected
FFilename: UTF8String;
function GetPosition: Int64; override;
procedure SetPosition(const Pos: Int64); override;
{ function GetSize: Int64; virtual;
procedure SetSize64(const NewSize: Int64); virtual;
procedure SetSize(NewSize: Longint); virtual;overload;
procedure SetSize(const NewSize: Int64); virtual;overload;
}
public
property Filename: UTF8String Read FFilename;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override; overload;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; overload;
Constructor Create(const AVirtualLayer: Pointer; const AFileName: UTF8String;const AMode: cardinal);
Destructor Destroy(); override;
end;
implementation
uses uvirtuallayer;
function VL(L: Pointer): TVirtualLayer; inline;
begin
Result:=TVirtualLayer(L);
end;
{ TVirtualLayer_Stream }
function TVirtualLayer_Stream.GetPosition: Int64;
begin
Result:=VL(FRootVirtualLayer).Seek(FHandle,0,fsFromCurrent);
end;
procedure TVirtualLayer_Stream.SetPosition(const Pos: Int64);
var
NewPos: int64;
begin
NewPos:=VL(FRootVirtualLayer).Seek(FHandle,Pos,fsFromBeginning);
if NewPos<0 Then begin
//Raise exception ??? which one :-?
end;
end;
function TVirtualLayer_Stream.Read(var Buffer; Count: Longint): Longint;
begin
Result:=VL(FRootVirtualLayer).Read(FHandle,@Buffer,Count);
end;
function TVirtualLayer_Stream.Write(const Buffer; Count: Longint): Longint;
begin
Result:=VL(FRootVirtualLayer).Write(FHandle,@Buffer,Count);
end;
function TVirtualLayer_Stream.Seek(Offset: Longint; Origin: Word): Longint;
begin
Result:=VL(FRootVirtualLayer).Seek(FHandle,Offset,Origin);
end;
function TVirtualLayer_Stream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var
Org: Word;
begin
Case Origin of
soCurrent: Org:=fsFromCurrent;
soEnd: Org:=fsFromEnd;
soBeginning:Org:=fsFromBeginning;
end;
Result:=VL(FRootVirtualLayer).Seek(FHandle,Offset,Org);
end;
constructor TVirtualLayer_Stream.Create(const AVirtualLayer: Pointer;
const AFileName: UTF8String; const AMode: cardinal);
begin
FRootVirtualLayer:=AVirtualLayer;
FHandle:=VL(FRootVirtualLayer).OpenFile(AFileName,AMode);
if FHandle=nil Then begin
Raise EStreamError.Create('Unable to open '+AFileName);
end;
FFilename:=AFileName;
end;
destructor TVirtualLayer_Stream.Destroy();
begin
if FHandle<>nil Then begin
VL(FRootVirtualLayer).CloseFile(FHandle);
end;
inherited Destroy();
end;
end.

197
components/fpspreadsheet/uvirtuallayer_types.pas Normal file
View File

@@ -0,0 +1,197 @@
unit uvirtuallayer_types;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
const VL_ERROR_DISK_FULL=-1;
const VL_INVALID_HANDLE=nil;
type
TvlHandleRecord=record
VirtualLayer: Pointer;
Handle: Pointer;
end;
PvlHandleRecord=^TvlHandleRecord;
TvlHandle=Pointer;
TVirtualMountPoint=record
MountPath: UTF8String;
MountedVirtual: Pointer;
end;
{ TVirtualLayer_CustomAttributes }
TVirtualLayer_CustomAttributes=Class(TObject)
private
protected
function GetReadOnly: Boolean; virtual; abstract;
function GetHidden: Boolean; virtual; abstract;
function GetSystem: Boolean; virtual; abstract;
function GetLastModification: TDateTime; virtual; abstract;
// procedure SetReadOnly(const AValue: Boolean); virtual; abstract;
// procedure SetHidden(const AValue: Boolean); virtual; abstract;
// procedure SetSystem(const AValue: Boolean); virtual; abstract;
// procedure SetLastModification(const AValue: TDateTime); virtual; abstract;
public
property IsReadOnly: Boolean read GetReadOnly; //write SetReadOnly;
property IsHidden: Boolean read GetHidden; //write SetHidden;
property IsSystem: Boolean read GetSystem; //write SetSystem;
property LastModification: TDateTime read GetLastModification; //write SetLastModification;
end;
{ TVirtualLayer_Item }
TVirtualLayer_Item=class(TObject)
private
protected
function GetAttributesHumanReadable: UTF8String; virtual;
function GetAttributes: TVirtualLayer_CustomAttributes; virtual;
public
Name: UTF8String;
Size: int64;
IsFolder: Boolean;
IsMountPoint: Boolean;
property Attributes: TVirtualLayer_CustomAttributes read GetAttributes;
property AttributesHumanReadable: UTF8String read GetAttributesHumanReadable;
destructor Destroy; override;
end;
{ TVirtualLayer_FolderList }
TVirtualLayer_FolderList=class(TList)
private
FPath: UTF8String;
function GetAttributes: TVirtualLayer_CustomAttributes; virtual;
function GetItems(index: integer): TVirtualLayer_Item;
procedure SetItems(index: integer; const AValue: TVirtualLayer_Item);
protected
public
procedure AddInheritedPath(const APath: UTF8String);
function Extract(index: integer): TVirtualLayer_Item;
procedure Sort(const Ascending: Boolean=true;const FoldersFirst: Boolean=true);
procedure Delete(const Index: integer);
property Path: UTF8String read FPath;
property Items[index: integer]:TVirtualLayer_Item read GetItems write SetItems; default;
property Attributes: TVirtualLayer_CustomAttributes read GetAttributes;
Constructor Create(const APath: UTF8String);
Destructor Destroy(); override;
end;
implementation
function fSortAscendingFoldersFirst(item1,item2: Pointer): integer; forward;
{ TVirtualLayer_FolderList }
function TVirtualLayer_FolderList.GetItems(index: integer): TVirtualLayer_Item;
begin
Result:=TVirtualLayer_Item(inherited items[Index]);
end;
function TVirtualLayer_FolderList.GetAttributes: TVirtualLayer_CustomAttributes;
begin
Result:=nil;
end;
procedure TVirtualLayer_FolderList.SetItems(index: integer;
const AValue: TVirtualLayer_Item);
begin
inherited items[index]:=AValue;
end;
procedure TVirtualLayer_FolderList.AddInheritedPath(const APath: UTF8String);
begin
FPath:=APath+RightStr(FPath,Length(FPath)-1);
end;
function TVirtualLayer_FolderList.Extract(index: integer): TVirtualLayer_Item;
begin
Result:=Items[index];
inherited Delete(index);
end;
procedure TVirtualLayer_FolderList.Sort(const Ascending: Boolean;
const FoldersFirst: Boolean);
begin
inherited Sort(@fSortAscendingFoldersFirst);
end;
procedure TVirtualLayer_FolderList.Delete(const Index: integer);
begin
TObject(Get(Index)).Free;
inherited Delete(Index);
end;
constructor TVirtualLayer_FolderList.Create(const APath: UTF8String);
begin
inherited Create;
FPath:=APath;
end;
destructor TVirtualLayer_FolderList.Destroy();
var
j: integer;
begin
for j := 0 to Count-1 do begin
TObject(Items[j]).Free;
end;
inherited Destroy();
end;
{FORWARDS}
function fSortAscendingFoldersFirst(item1, item2: Pointer): integer;
var
l1,l2: TVirtualLayer_Item;
begin
l1:=TVirtualLayer_Item(item1);
l2:=TVirtualLayer_Item(item2);
if L1.IsFolder and L2.IsFolder then begin
Result:=CompareText(L1.Name,L2.Name);
end else begin
if L1.IsFolder then begin
Result:=-1;
end else if L2.IsFolder then begin
Result:=1;
end else begin
Result:=CompareText(L1.Name,L2.Name);
end;
end;
end;
{ TVirtualLayer_Item }
function TVirtualLayer_Item.GetAttributesHumanReadable: UTF8String;
var
T: UTF8String;
A: TVirtualLayer_CustomAttributes;
begin
A:=Attributes;
if A=nil then Exit;
Result:=Result+'Regular attributes: ';
if A.IsReadOnly then T:=T+'Read Only,';
if A.IsHidden then T:=T+'Hidden,';
if A.IsSystem then T:=T+'System file,';
T:=LeftStr(T,Length(T)-1);
Result:=Result+T+#13+#10;
Result:=Result+'Last modification: '+FormatDateTime(LongDateFormat+' '+LongTimeFormat,A.LastModification)+#13+#10;
end;
function TVirtualLayer_Item.GetAttributes: TVirtualLayer_CustomAttributes;
begin
Result:=nil;
end;
destructor TVirtualLayer_Item.Destroy;
begin
if Attributes<>nil Then Attributes.Free;
inherited Destroy;
end;
end.

2
components/fpspreadsheet/xlsbiff5.pas
View File

@@ -57,7 +57,7 @@ interface
uses
Classes, SysUtils, fpcanvas,
fpspreadsheet, fpolestorage, fpsutils;
fpspreadsheet, fpolebasic, fpsutils;
type

2
components/fpspreadsheet/xlsbiff8.pas
View File

@@ -50,7 +50,7 @@ interface
uses
Classes, SysUtils, fpcanvas,
fpspreadsheet, fpolestorage, fpsutils;
fpspreadsheet, fpolebasic, fpsutils;
type