(* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 * * The contents of this file are subject to the Mozilla Public License Version * 1.1 (the "License"); you may not use this file except in compliance with * the License. You may obtain a copy of the License at * http://www.mozilla.org/MPL/ * * Software distributed under the License is distributed on an "AS IS" basis, * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License * for the specific language governing rights and limitations under the * License. * * The Original Code is TurboPower Abbrevia * * The Initial Developer of the Original Code is * TurboPower Software * * Portions created by the Initial Developer are Copyright (C) 1997-2002 * the Initial Developer. All Rights Reserved. * * Contributor(s): * * ***** END LICENSE BLOCK ***** *) {*********************************************************} {* ABBREVIA: AbCompnd.pas *} {*********************************************************} {* ABBREVIA: Compound File classes and component *} {* Use AbQCmpnd.pas for CLX *} {*********************************************************} {$IFNDEF UsingCLX} unit AbCompnd; {$ENDIF} {$I AbDefine.inc} interface uses Classes, SysUtils, {$IFDEF UsingClx} QComCtrls, {$ELSE} ComCtrls, {$ENDIF} AbBase, AbResString, AbDfDec, AbDfEnc, AbDfBase; const AbCompoundFileVersion = '3.1'; const {SystemBlock constants} sbSignatureSize = 40; {byte size of Signature field} sbVolumeLabelSize = 40; {byte size of Volume Label field} sbAllocationSizeSize = 4; {byte size of Allocation Size field} sbVersionSize = 4; {byte size of Version field} sbUpdateSize = 1; {byte size of Updating Flag field} {Total size of System Block} SizeOfSystemBlock = sbSignatureSize + sbVolumeLabelSize + sbAllocationSizeSize + sbVersionSize + sbUpdateSize; {RootDir constants} rdEntryNameSize = 28; {byte size of Name field} rdEntryIDSize = 4; {byte size of EntryID field} rdParentFolderSize = 4; {byte size of ParentFolder field} rdEntryTypeSize = 4; {byte size of EntryType field} rdAttributesSize = 4; {byte size of Attributes field} rdStartBlockSize = 4; {byte size of StartBlock field} rdLastModifiedSize = 8; {byte size of LastModified field} rdSizeSize = 4; {byte size of UncompressedSize field} rdCompressedSizeSize = 4; {byte size of CompressedSize field} {Total size of a single Root Directory Entry} rdSizeOfDirEntry = rdEntryNameSize + rdEntryIDSize + rdParentFolderSize + rdEntryTypeSize + rdAttributesSize + rdStartBlockSize + rdLastModifiedSize + rdSizeSize + rdCompressedSizeSize; rdUnUsed = -2; {Constant used to flag an RD entry as unused} {Total size of a Root Directory entry} SizeOfRootDirBlock = rdEntryNameSize + rdEntryIDSize + rdParentFolderSize + rdEntryTypeSize + rdAttributesSize + rdStartBlockSize + rdLastModifiedSize + rdSizeSize + rdCompressedSizeSize; {FAT table constants} ftEndOfBlock = -1; {End of Block} ftUnusedBlock = -2; {Unused Block} {General constants} cfAllocationSize = 512; {Default AllocationSize (bytes)} type ECompoundFileError = class(Exception); TrdEntryType = (etFolder, etFile); {dynamic array parameter for returning FAT chain sequences} type TFATChainArray = array of Integer; {forwards} {$M+} TAbCompoundFile = class; {$M-} TBeforeDirDeleteEvent = procedure(Sender : TAbCompoundFile; Dir : AnsiString; var AllowDelete : Boolean) of object; TBeforeDirModifiedEvent = procedure(Sender : TAbCompoundFile; Dir : AnsiString; var AllowModify : Boolean) of object; TBeforeFileDeleteEvent = procedure(Sender : TAbCompoundFile;FileName : AnsiString; var AllowDelete : Boolean) of object; TBeforeFileModifiedEvent = procedure(Sender : TAbCompoundFile; FileName : AnsiString; var AllowModify : Boolean) of object; TMultiNode = class(TObject) protected {private} FParent : Pointer; {pointer to the parent node} FKey : AnsiString; {node identifier} FChildren : TStringList; {list for child keys & nodes} FData : TObject; {contained object} function GetChildCount : Integer; public constructor Create(const Key : AnsiString); destructor Destroy; override; function AddChild(const Key : AnsiString) : TMultiNode; procedure DeleteChild(Index : Integer); function DeleteChildByName(const ChildKey : AnsiString) : Boolean; function DeleteChildren : Boolean; function GetChild(Index : integer) : TMultiNode; function GetChildByName(const Key : AnsiString) : TMultiNode; function HasParent : Boolean; function HasChildren : Boolean; function Contains(const Key : AnsiString) : Boolean; property Parent : Pointer read FParent write FParent; property ChildCount : Integer read GetChildCount; property Children[Index : Integer] : TMultiNode read GetChild; property Data : TObject read FData write FData; property Key : AnsiString read FKey write FKey; end; TMultiTree = class(TObject) protected {private} FRoot : TMultiNode; {reference to root node} FCount : Integer; {count of nodes in the tree} FCurrentNode : TMultiNode; {analogous to current directory} FSepChar : AnsiChar; {directory separator character} FIDCount : Integer; {counter incremented during preorder trav.} {(used to assign unique ID to each node)} procedure VisitSubNodesPost(Node : TMultiNode; ID : Integer); procedure VisitSubNodesPre(Node : TMultiNode; Strm : TStream); procedure VisitNode(Node : TMultiNode; Strm : TStream); procedure ParseDirStr(const Key : AnsiString; Lst : TStringList); procedure PopulateSubNodes(ParentNode : TMultiNode; TreeView : TTreeView; TreeNode : TTreeNode); procedure TraversePost(ID : Integer); procedure TraversePre(Strm : TStream); public constructor Create; destructor Destroy; override; function Insert(ParentNode : TMultiNode; const Key : AnsiString) : TMultiNode; function GetNode(const Key : AnsiString) : TMultiNode; function DeleteNode(const Key : AnsiString) : Boolean; procedure ChangeDir(const Key : AnsiString); function PopulateTreeView(TreeView : TTreeView) : Integer; property Root : TMultiNode read FRoot; property Count : Integer read FCount; property CurrentNode : TMultiNode read FCurrentNode; property SepChar : AnsiChar read FSepChar write FSepChar; end; TAbSystemBlock = class(TObject) protected {private} FSignature : AnsiString; {identifies the compound file structure} FVolumeLabel : AnsiString; {file identification in addition to filename} FAllocationSize : Integer; {size of allocation block} FVersion : AnsiString; {version string identifier} FUpdating : Boolean; {internal processing indicator} {protected methods} procedure BeginUpdate; procedure EndUpdate; procedure WriteToStream(Strm : TMemoryStream); {properties} property Signature : AnsiString read FSignature write FSignature; property VolumeLabel : AnsiString read FVolumeLabel write FVolumeLabel; property Updating : Boolean read FUpdating; property AllocationSize : Integer read FAllocationSize write FAllocationSize; property Version : AnsiString read FVersion; public constructor Create(const VolLabel : AnsiString; AllocationSz : Integer); end; TAbDirectoryEntry = class(TObject) protected {private} FName : AnsiString; {name of file or folder} FEntryID : Integer; {unique ID for this dir. entry} FParentFolder : LongInt; {unique ID of parent folder} FEntryType : TrdEntryType; {folder or file} FAttributes : LongInt; {file system attributes} FStartBlock : LongInt; {starting allocation block} FLastModified : TDateTime; {last modification date/time} FSize : LongInt; {uncompressed file size} FCompressedSize : LongInt; {compressed file size} procedure WriteToStream(Strm : TMemoryStream); function IsReadOnly : Boolean; function IsHidden : Boolean; function IsSysFile : Boolean; function IsVolumeID : Boolean; function IsDirectory : Boolean; function IsArchive : Boolean; function GetIsFree : Boolean; public constructor Create(AsFile : Boolean); property EntryName : AnsiString read FName write FName; property ParentFolder : LongInt read FParentFolder write FParentFolder; property Attributes : LongInt read FAttributes write FAttributes; property StartBlock : LongInt read FStartBlock write FStartBlock; property LastModified : TDateTime read FLastModified write FLastModified; property Size : LongInt read FSize write FSize; property CompressedSize : LongInt read FCompressedSize write FCompressedSize; property IsFree : Boolean read GetIsFree; property EntryType : TrdEntryType read FEntryType write FEntryType; end; TAbRootDir = class(TMultiTree) fAllocSize : Integer; protected {private} function AddFolder(FolderName : AnsiString) : TAbDirectoryEntry; function AddFile(FileName : AnsiString) : TAbDirectoryEntry; procedure DeleteFolder(FolderName : AnsiString); procedure DeleteFile(FileName : AnsiString); procedure WriteToStream(Strm : TMemoryStream); procedure GoToEntryID(ID : Integer); public constructor Create(VolLabel : AnsiString; AllocSize : Integer); destructor Destroy; override; end; TAbFATTable = class(TObject) protected {private} fFATArray : Array of Integer; {dynamic array for the FAT} fAllocSize : Integer; procedure WriteToStream(Strm : TMemoryStream); public constructor Create(AllocSize : Integer); destructor Destroy; override; function IsEndOfFile(Ndx : Integer) : Boolean; function IsUnUsed(Ndx : Integer) : Boolean; function GetNextUnusedBlock : Integer; procedure GetNewChain(NumBytes : Integer; var ChainArray : TFATChainArray); procedure GetExistingChain(StartNdx : Integer; var ChainArray : TFATChainArray); procedure ClearExistingChain(StartNdx : Integer); procedure GetRootDirChain(var ChainArray : TFATChainArray); procedure GetFATChain(var ChainArray : TFATChainArray); procedure GetNewRootDirChain(NumBytes : Integer; var ChainArray : TFATChainArray); procedure GetNewFATChain(NumBytes : Integer; var ChainArray : TFATChainArray); procedure ClearRootDirChain; procedure ClearFATChain; end; TAbCompoundFile = class(TObject) protected {private} FSystemBlock : TAbSystemBlock; {system block} FFATTable : TAbFATTable; {FAT table} FRootDir : TAbRootDir; {root directory} FDiskFile : string; {compound file name} FSizeOnDisk : Integer; {sum total of compressed sizes + uncompressed Sys, RootDir, & FAT blks} FStream : TFileStream; {Compound file stream (*.cf)} FOnAfterOpen : TNotifyEvent; FOnBeforeClose : TNotifyEvent; FOnBeforeDirDelete : TBeforeDirDeleteEvent; FOnBeforeDirModified : TBeforeDirModifiedEvent; FOnBeforeFileDelete : TBeforeFileDeleteEvent; FOnBeforeFileModified : TBeforeFileModifiedEvent; function GetVolumeLabel : AnsiString; procedure SetVolumeLabel(Val : AnsiString); function GetDirectoryEntries : Integer; function GetSizeOnDisk : Integer; procedure PersistFileData(FileData : TStream; var ChainArray : TFATChainArray); procedure PersistSystemBlock; procedure PersistRootDirBlock; procedure PersistFATBlock; procedure BuildSysBlock; procedure BuildFat; procedure BuildRootDir; procedure AddDirEntriesFromList(Lst : TStringList); procedure Defrag; {not implemented} public constructor Create(const FileName : string; const VolLabel : AnsiString; AllocSize : Integer); overload; constructor Create(const FileName : string; const VolLabel : AnsiString; AllocSize : Integer; const Signature: AnsiString); overload; destructor Destroy; override; procedure EnumerateFiles(Lst : TStringList); procedure EnumerateFolders(Lst : TStringList); procedure AddFile(FName : AnsiString; FileData : TStream; FileSize : Integer); function AddFolder(FName : AnsiString) : Boolean; procedure UpdateFile(FName : AnsiString; FData : TStream); procedure DeleteFile(FName : AnsiString); procedure DeleteFolder(FName : AnsiString); procedure Open(const FName : string); overload; procedure Open(const FName : string; const Signature: AnsiString); overload; function OpenFile(FileName : AnsiString; var Strm : TStream) : Integer; function PopulateTreeView(TreeView : TTreeView) : Integer; procedure PopulateSubNodes(ParentNode : TMultiNode; TreeView : TTreeView; TreeNode : TTreeNode); procedure RenameFile(OrigName, NewName : AnsiString); procedure RenameFolder(OrigName, NewName : AnsiString); procedure SetCurrentDirectory(val : AnsiString); function GetCurrentDirectory : AnsiString; function GetAllocationSize : Integer; property CurrentDirectory : AnsiString read GetCurrentDirectory write SetCurrentDirectory; property DirectoryEntries : Integer read GetDirectoryEntries; property SizeOnDisk : Integer read GetSizeOnDisk; property Stream : TFileStream read FStream write FStream; published property VolumeLabel : AnsiString read GetVolumeLabel write SetVolumeLabel; property FileName : string read FDiskFile; property AllocationSize : Integer read GetAllocationSize; property OnAfterOpen : TNotifyEvent read FOnAfterOpen write FOnAfterOpen; property OnBeforeClose : TNotifyEvent read FOnBeforeClose write FOnBeforeClose; property OnBeforeDirDelete : TBeforeDirDeleteEvent read FOnBeforeDirDelete write FOnBeforeDirDelete; property OnBeforeDirModified : TBeforeDirModifiedEvent read FOnBeforeDirModified write FOnBeforeDirModified; property OnBeforeFileDelete : TBeforeFileDeleteEvent read FOnBeforeFileDelete write FOnBeforeFileDelete; property OnBeforeFileModified : TBeforeFileModifiedEvent read FOnBeforeFileModified write FOnBeforeFileModified; end; implementation uses StrUtils, {$IFDEF HasAnsiStrings}AnsiStrings,{$ENDIF} ABUtils; {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} {TMultiNode} {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} constructor TMultiNode.Create(const Key : AnsiString); {- Creates and initializes a new node} begin inherited Create; FKey := Key; FChildren := TStringList.Create; FChildren.Sorted := True; FChildren.Duplicates := dupError; end; {-----------------------------------------------------------------------------} destructor TMultiNode.Destroy; {- Destroys the node and all of the children} var i : integer; begin {free children} for i := FChildren.Count - 1 downto 0 do FChildren.Objects[i].Free; FChildren.Free; if Assigned(FData) then TAbDirectoryEntry(FData).Free; inherited Destroy; end; {-----------------------------------------------------------------------------} function TMultiNode.AddChild(const Key : AnsiString) : TMultiNode; {- Creates and adds a new node - returns the newly added node} begin if Contains(Key) then Result := nil else begin Result := TMultiNode.Create(Key); Result.Parent := self; FChildren.AddObject(string(Key), Result); end; end; {-----------------------------------------------------------------------------} function TMultiNode.Contains(const Key : AnsiString) : Boolean; {- Returns true if the node contains a child of the name specified by 'Key'} begin Result := (FChildren.IndexOf(string(Key)) >= 0); end; {-----------------------------------------------------------------------------} procedure TMultiNode.DeleteChild(Index : Integer); {- Deletes the child node specified by 'Index'} begin if ((Index < 0) or (Index > FChildren.Count - 1)) then raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds); FChildren.Objects[Index].Free; FChildren.Delete(Index); end; {-----------------------------------------------------------------------------} function TMultiNode.DeleteChildByName(const ChildKey : AnsiString) : Boolean; {- If node found, node is deleted and true is returned, else returns false} begin Result := Contains(ChildKey); if Result then begin FChildren.Objects[FChildren.IndexOf(string(ChildKey))].Free; FChildren.Delete(FChildren.IndexOf(string(ChildKey))); end; end; {-----------------------------------------------------------------------------} function TMultiNode.DeleteChildren : Boolean; {- Deletes all child nodes} var i : Integer; begin Result := FChildren.Count > 0; for i := FChildren.Count - 1 downto 0 do begin FChildren.Objects[i].Free; FChildren.Delete(i); end; end; {-----------------------------------------------------------------------------} function TMultiNode.GetChild(Index : integer) : TMultiNode; {- Returns the node specified by Index} begin if ((Index < 0) or (Index > FChildren.Count - 1)) then raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds); Result := (FChildren.Objects[Index] as TMultiNode); end; {-----------------------------------------------------------------------------} function TMultiNode.GetChildByName(const Key : AnsiString) : TMultiNode; {- Returns the child node specified by 'Key'. If not found, result = nil} begin Result := nil; if Contains(Key) then Result := (FChildren.Objects[FChildren.IndexOf(string(Key))] as TMultiNode); end; {-----------------------------------------------------------------------------} function TMultiNode.GetChildCount : Integer; {- Returns the node's children count} begin Result := FChildren.Count; end; {-----------------------------------------------------------------------------} function TMultiNode.HasParent : Boolean; {- Returns true if parent is assigned, else returns false} begin Result := (FParent <> nil); end; {-----------------------------------------------------------------------------} function TMultiNode.HasChildren : Boolean; {- Returns true if the node contains 1 or more child nodes.} begin Result := (FChildren.Count > 0); end; {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} {TMultiTree} {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} constructor TMultiTree.Create; {- creates an empty tree} begin inherited Create; FSepChar := '\'; end; {-----------------------------------------------------------------------------} destructor TMultiTree.Destroy; {- destroys all nodes (post-order)} var Curr : TMultiNode; begin Curr := Root; while Curr <> nil do begin if Curr.HasChildren then Curr := Curr.Children[0] else begin if Curr = Root then begin Curr.Free; exit; end else begin Curr := Curr.Parent; Curr.DeleteChild(0); end; end; end; end; {-----------------------------------------------------------------------------} procedure TMultiTree.ChangeDir(const Key : AnsiString); {- Sets current directory of tree if path('Key') is valid} var Node : TMultiNode; Lst : TStringList; i, Ndx : integer; NotFound : Boolean; begin if Root = nil then exit; NotFound := False; Lst := TStringList.Create; try ParseDirStr(Key, Lst); Node := CurrentNode; for i := 0 to Lst.Count - 1 do begin if Lst.Strings[i] = '\' then begin Node := Root; Continue; end else if Lst.Strings[i] = '.' then Continue else if Lst.Strings[i] = '..' then begin if Node <> Root then Node := TMultiNode(Node.Parent); end else begin Ndx := Node.FChildren.IndexOf(Lst.Strings[i]); if Ndx >= 0 then Node := Node.GetChild(Ndx) else begin NotFound := True; Break; end; end; end; finally Lst.Free; end; if NotFound = false then FCurrentNode := Node; end; {-----------------------------------------------------------------------------} function TMultiTree.DeleteNode(const Key : AnsiString) : Boolean; {- If node found, deletes the node & returns true, else returns false} begin Result := False; if CurrentNode <> nil then if CurrentNode.Contains(Key) then begin Result := CurrentNode.DeleteChildByName(Key); Dec(FCount); end; end; {-----------------------------------------------------------------------------} function TMultiTree.GetNode(const Key : AnsiString) : TMultiNode; {- Returns the node if found, else returns nil} begin Result := nil; if CurrentNode <> nil then if CurrentNode.Contains(Key) then Result := CurrentNode.GetChildByName(Key); end; {-----------------------------------------------------------------------------} function TMultiTree.Insert(ParentNode : TMultiNode; const Key : AnsiString) : TMultiNode; {- Adds child node to specified ParentNode} var NewNode : TMultiNode; begin Result := nil; if CurrentNode = nil then begin {adding root node} NewNode := TMultiNode.Create(Key); FRoot := NewNode; FCurrentNode := NewNode; Result := NewNode; end else begin if not CurrentNode.Contains(Key) then begin Result := CurrentNode.AddChild(Key); Result.Parent := CurrentNode; end; end; Inc(FCount); end; {-----------------------------------------------------------------------------} procedure TMultiTree.ParseDirStr(const Key : AnsiString; Lst : TStringList); {- parses Key into individual dir commands adding each to Lst} var LocKey : AnsiString; Counter : integer; begin LocKey := Key; Lst.Clear; if LocKey = '' then LocKey := '\'; {- are we to start from the root folder} Counter := 0; while LocKey[Counter+1] = '\' do inc(Counter); if Counter = 1 then Lst.Add('\'); {- begin parsing} while Length(LocKey) > 0 do begin while LocKey[1] = '\' do begin Delete(LocKey, 1, 1); if Length(LocKey) = 0 then exit; end; if pos(SepChar,LocKey) > 0 then begin Lst.Add(string(copy(LocKey, 1, Pos(SepChar, LocKey) - 1))); Delete(LocKey, 1, Pos(SepChar, LocKey)); end else if Length(LocKey) > 0 then begin Lst.Add(string(LocKey)); LocKey := ''; end; end; end; {-----------------------------------------------------------------------------} procedure TMultiTree.PopulateSubNodes(ParentNode : TMultiNode; TreeView : TTreeView; TreeNode : TTreeNode); {- Visits sub-nodes recursively - pre order} var Curr : TMultiNode; i : Integer; Node : TTreeNode; begin Node := TreeView.Items.AddChild(TreeNode, string(ParentNode.Key)); Curr := ParentNode; if Curr <> nil then begin if Curr.HasChildren then begin for i := 0 to Curr.ChildCount -1 do PopulateSubNodes(Curr.Children[i], TreeView, Node); end; end; end; {-----------------------------------------------------------------------------} function TMultiTree.PopulateTreeView(TreeView : TTreeView) : Integer; {- Populates a user-supplied TTreeView with multiway tree nodes} var i : Integer; TreeNode : TTreeNode; begin TreeView.Items.Clear; if Root <> nil then begin TreeNode := TreeView.Items.Add(nil, string(Root.Key)); if Root.HasChildren then begin for i := 0 to Root.ChildCount - 1 do PopulateSubNodes(Root.Children[i], TreeView, TreeNode); end; end; Result := TreeView.Items.Count end; {-----------------------------------------------------------------------------} procedure TMultiTree.TraversePost(ID : Integer); {- Traverses tree post-order - CurrentNode after traversal will be the node whose EntryID = ID} var i : Integer; begin if Root <> nil then begin if Root.HasChildren then begin for i := 0 to Root.ChildCount - 1 do VisitSubNodesPost(Root.Children[i], ID); end; if (TAbDirectoryEntry(Root.FData).FEntryID = ID) then FCurrentNode := Root; end; end; {-----------------------------------------------------------------------------} procedure TMultiTree.TraversePre(Strm : TStream); {- Traverses tree pre-order} var i : Integer; begin if Root <> nil then begin FIDCount := 1; TAbDirectoryEntry(Root.Data).FEntryID := FIDCount; VisitNode(Root, Strm); if Root.HasChildren then begin for i := 0 to Root.ChildCount - 1 do VisitSubNodesPre(Root.Children[i], Strm); end; end; end; {-----------------------------------------------------------------------------} procedure TMultiTree.VisitNode(Node : TMultiNode; Strm : TStream); {- Called recursively from VisitSubNodesPre. Assigns unique entry ID's for each directory entry to maintain hierarchy} begin if Node.Parent = nil then TAbDirectoryEntry(Node.Data).ParentFolder := -1 else TAbDirectoryEntry(Node.Data).ParentFolder := TAbDirectoryEntry(TMultiNode(Node.Parent).Data).FEntryID; TAbDirectoryEntry(Node.Data).WriteToStream(TMemoryStream(Strm)); end; {-----------------------------------------------------------------------------} procedure TMultiTree.VisitSubNodesPost(Node : TMultiNode; ID : Integer); {- Visits sub-nodes recursively - post order} var Curr : TMultiNode; i : Integer; begin Curr := Node; if Curr <> nil then begin if Curr.HasChildren then begin for i := 0 to Curr.ChildCount -1 do VisitSubNodesPost(Curr.Children[i], ID); end; if (TAbDirectoryEntry(Curr.FData).FEntryID = ID) then FCurrentNode := Curr; end; end; {-----------------------------------------------------------------------------} procedure TMultiTree.VisitSubNodesPre(Node : TMultiNode; Strm : TStream); {- Visits sub-nodes recursively - pre order} var Curr : TMultiNode; i : Integer; begin Curr := Node; if Curr <> nil then begin Inc(FIDCount); TAbDirectoryEntry(Curr.Data).FEntryID := FIDCount; VisitNode(Curr, Strm); if Curr.HasChildren then begin for i := 0 to Curr.ChildCount -1 do VisitSubNodesPre(Curr.Children[i], Strm); end; end; end; {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} {TAbSystemBlock} {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} constructor TAbSystemBlock.Create(const VolLabel : AnsiString; AllocationSz : Integer); {- Creates the System block structure of the compound file} begin inherited Create; FSignature := 'AbCompoundFile'; FVolumeLabel := VolLabel; FAllocationSize := AllocationSz; FVersion := AbCompoundFileVersion; FUpdating := False; end; {-----------------------------------------------------------------------------} procedure TAbSystemBlock.BeginUpdate; {- Sets updating to true - temporarily blocking other actions} begin FUpdating := True; end; {-----------------------------------------------------------------------------} procedure TAbSystemBlock.EndUpdate; {- Clears updating flag & allows for other actions} begin FUpdating := False; end; {-----------------------------------------------------------------------------} procedure TAbSystemBlock.WriteToStream(Strm : TMemoryStream); {- writes the contents to the stream parameter} var Sig : Array[0..sbSignatureSize - 1] of AnsiChar; VolLabel : Array[0..sbVolumeLabelSize - 1] of AnsiChar; AllocSize : Integer; Version : Array[0..sbVersionSize - 1] of AnsiChar; Updt : Byte; begin FillChar(Sig, sbSignatureSize, #0); AbStrPCopy(Sig, FSignature); FillChar(VolLabel[0], sbVolumeLabelSize, #0); AbStrPCopy(VolLabel, FVolumeLabel); AllocSize := FAllocationSize; FillChar(Version[0], sbVersionSize, #0); AbStrPCopy(Version, FVersion); if FUpdating then Updt := $01 else Updt := $00; Strm.Write(Sig[0], sbSignatureSize); Strm.Write(VolLabel[0], sbVolumeLabelSize); Strm.Write(AllocSize, SizeOf(Integer)); Strm.Write(Version[0], sbVersionSize); Strm.Write(Updt, sbUpdateSize); end; {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} {TAbDirectoryEntry} {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} constructor TAbDirectoryEntry.Create(AsFile : Boolean); {- Creates & initializes a new TAbDirectoryEntry} begin inherited Create; FName := ''; FParentFolder := rdUnused; if AsFile then begin FEntryType := etFile; {$WARN SYMBOL_PLATFORM OFF} FAttributes := faArchive; {$WARN SYMBOL_PLATFORM ON} end else begin FEntryType := etFolder; FAttributes := faDirectory; end; FStartBlock := rdUnused; FLastModified := 0; FSize := rdUnused; FCompressedSize := rdUnused; end; {-----------------------------------------------------------------------------} function TAbDirectoryEntry.GetIsFree : Boolean; {- returns true if the entry has been marked for deletion} begin Result := (FName = ''); end; {-----------------------------------------------------------------------------} function TAbDirectoryEntry.IsArchive : Boolean; {- returns true if the entry is an archive} begin {$WARN SYMBOL_PLATFORM OFF} Result := ((FAttributes and faArchive) > 0); {$WARN SYMBOL_PLATFORM ON} end; {-----------------------------------------------------------------------------} function TAbDirectoryEntry.IsDirectory : Boolean; {- returns true if the entry is a directory} begin Result := ((FAttributes and faDirectory) > 0); end; {-----------------------------------------------------------------------------} function TAbDirectoryEntry.IsHidden : Boolean; {- returns true if the entry is hidden} begin {$WARN SYMBOL_PLATFORM OFF} Result := ((FAttributes and faHidden) > 0); {$WARN SYMBOL_PLATFORM ON} end; {-----------------------------------------------------------------------------} function TAbDirectoryEntry.IsReadOnly : Boolean; {- returns true if the entry is read-only} begin {$WARN SYMBOL_PLATFORM OFF} Result := ((FAttributes and faReadOnly) > 0); {$WARN SYMBOL_PLATFORM ON} end; {-----------------------------------------------------------------------------} function TAbDirectoryEntry.IsSysFile : Boolean; {- returns true if the entry is a system file} begin {$WARN SYMBOL_PLATFORM OFF} Result := ((FAttributes and faSysFile) > 0); {$WARN SYMBOL_PLATFORM ON} end; {-----------------------------------------------------------------------------} function TAbDirectoryEntry.IsVolumeID : Boolean; {- returns true if the entry is a volume ID} begin {$WARN SYMBOL_DEPRECATED OFF} {$WARN SYMBOL_PLATFORM OFF} Result := ((FAttributes and faVolumeID) > 0); {$WARN SYMBOL_PLATFORM ON} {$WARN SYMBOL_DEPRECATED ON} end; {-----------------------------------------------------------------------------} procedure TAbDirectoryEntry.WriteToStream(Strm : TMemoryStream); {- writes properties to stream} var EntryName : Array[0..rdEntryNameSize] of AnsiChar; FType : Integer; begin FillChar(EntryName, rdEntryNameSize - 1, #0); AbStrPCopy(EntryName, FName); Strm.Write(EntryName[0], rdEntryNameSize); Strm.Write(FEntryID, rdEntryIDSize); Strm.Write(FParentFolder, rdParentFolderSize); if EntryType = etFolder then FType := $00000000 else FType := $00000001; Strm.Write(FType, rdEntryTypeSize); Strm.Write(FAttributes, rdAttributesSize); Strm.Write(FStartBlock, rdStartBlockSize); Strm.Write(FLastModified, rdLastModifiedSize); Strm.Write(FSize, rdSizeSize); Strm.Write(FCompressedSize, rdCompressedSizeSize); end; {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} {TAbRootDir} {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} constructor TAbRootDir.Create(VolLabel : AnsiString; AllocSize : Integer); {- Creates a single-entry (vol-label) root directory structure} begin inherited Create; fAllocSize := AllocSize; if VolLabel <> '' then AddFolder(VolLabel); end; {-----------------------------------------------------------------------------} destructor TAbRootDir.Destroy; {- Destroys the root dir.} begin inherited Destroy; end; {-----------------------------------------------------------------------------} function TAbRootDir.AddFile(FileName : AnsiString) : TAbDirectoryEntry; {- Adds a file to the current directory of the compound file} var NewNode : TMultiNode; NewData : TAbDirectoryEntry; begin NewData := nil; NewNode := Insert(CurrentNode, FileName); if NewNode <> nil then begin NewData := TAbDirectoryEntry.Create(True); NewData.FName := FileName; NewData.ParentFolder := 1; {$WARN SYMBOL_PLATFORM OFF} NewData.Attributes := faArchive; {$WARN SYMBOL_PLATFORM ON} NewData.StartBlock := 3; NewData.LastModified := Now; NewData.Size := 4; NewData.CompressedSize := 5; NewData.EntryType := etFile; NewNode.Data := NewData; end; Result := NewData; end; {-----------------------------------------------------------------------------} function TAbRootDir.AddFolder(FolderName : AnsiString) : TAbDirectoryEntry; {- Adds a folder to the current directory of the compound file} var NewNode : TMultiNode; NewData : TAbDirectoryEntry; begin Result := nil; NewNode := Insert(CurrentNode, FolderName); if NewNode <> nil then begin NewData := TAbDirectoryEntry.Create(False); NewData.FName := FolderName; NewData.ParentFolder := 1; NewData.Attributes := faDirectory; NewData.StartBlock := rdUnUsed; NewData.LastModified := Now; NewData.Size := 0; NewData.CompressedSize := 0; NewData.EntryType := etFolder; NewNode.Data := NewData; Result :=NewData; end; end; {-----------------------------------------------------------------------------} procedure TAbRootDir.DeleteFile(FileName : AnsiString); {- Deletes the specified file if found} begin DeleteNode(FileName); end; {-----------------------------------------------------------------------------} procedure TAbRootDir.DeleteFolder(FolderName : AnsiString); {- Deletes the specifed folder if found & empty} begin if not CurrentNode.Contains(FolderName) then raise ECompoundFileError.Create(AbCmpndFileNotFound); if CurrentNode.ChildCount > 0 then raise ECompoundFileError.Create(AbCmpndFolderNotEmpty); DeleteFolder(FolderName); end; {-----------------------------------------------------------------------------} procedure TAbRootDir.WriteToStream(Strm : TMemoryStream); {- Streams and writes the root directory entries to the stream parameter} begin TraversePre(Strm); end; {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} {TAbFATTable} {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} constructor TAbFATTable.Create(AllocSize : Integer); {- Creates the FAT table structure} var i : Integer; begin {Sets FAT length equal to one allocation block} fAllocSize := AllocSize; SetLength(fFATArray, AllocSize div SizeOf(Integer)); for i := 0 to High(fFATArray) do fFATArray[i] := ftUnusedBlock; for i := 0 to 2 do fFATArray[i] := ftEndOfBlock; end; {-----------------------------------------------------------------------------} destructor TAbFATTable.Destroy; {- Destroys the FAT table} begin Finalize(fFATArray); end; {-----------------------------------------------------------------------------} procedure TAbFATTable.ClearExistingChain(StartNdx : Integer); {- Sets all of the FAT entries pertaining to the sequence starting at StartNds to ftUnUsedBlock} var ChainArray : TFATChainArray; i : Integer; begin SetLength(ChainArray, 0); GetExistingChain(StartNdx, ChainArray); for i := 0 to High(ChainArray) do fFATArray[ChainArray[i]] := ftUnUsedBlock; end; {-----------------------------------------------------------------------------} procedure TAbFATTable.ClearFATChain; {- Sets the FAT entries pertaining to the FAT table to unused} begin ClearExistingChain(2); end; {-----------------------------------------------------------------------------} procedure TAbFATTable.ClearRootDirChain; {- Sets the FAT entries pertaining the the RootDir to unused} begin ClearExistingChain(1); end; {-----------------------------------------------------------------------------} procedure TAbFATTable.GetExistingChain(StartNdx : Integer; var ChainArray : TFATChainArray); {- Walks the FAT table starting at the index specified, and populates the chain array parameter with the results} var BlkCount, i, ChainNdx : Integer; begin if fFATArray[StartNdx] = ftUnUsedBlock then begin SetLength(ChainArray, 0); exit; end; {determine count} if StartNdx < 1 then SetLength(ChainArray, 0) else begin BlkCount := 1; i := StartNdx; while fFATArray[i] <> ftEndOfBlock do begin i := fFATArray[i]; Inc(BlkCount); end; {set up array} SetLength(ChainArray, BlkCount); for i := 0 to High(ChainArray) do ChainArray[i] := ftUnusedBlock; {walk FAT & populate array} ChainNdx := 0; ChainArray[ChainNdx] := StartNdx; i := StartNdx; while fFATArray[i] <> ftEndOfBlock do begin Inc(ChainNdx); ChainArray[ChainNdx] := fFATArray[i]; i := fFATArray[i]; end; end; end; {-----------------------------------------------------------------------------} procedure TAbFATTable.GetFATChain(var ChainArray : TFATChainArray); {- Returns the sequence of FAT blocks used by the FAT table in the ChainArray parameter} begin GetExistingChain(2, ChainArray); end; {-----------------------------------------------------------------------------} procedure TAbFATTable.GetNewChain(NumBytes : Integer; var ChainArray : TFATChainArray); {- Finds sequence of free blocks required of a file of size NumBytes The new FAT chain is commited and passed back in the ChainArray parameter} var FirstBlock : Integer; TotalBlocksRequired : Integer; i, j, BlocksFound : Integer; begin if ((NumBytes mod fAllocSize) <> 0) then TotalBlocksRequired := (NumBytes div fAllocSize) + 1 else TotalBlocksRequired := (NumBytes div fAllocSize); if TotalBlocksRequired = 0 then exit; FirstBlock := GetNextUnusedBlock; {set up array} SetLength(ChainArray, TotalBlocksRequired); for i := 0 to High(ChainArray) do ChainArray[i] := ftUnusedBlock; ChainArray[0] := FirstBlock; BlocksFound := 1; i := FirstBlock + 1; while BlocksFound < TotalBlocksRequired do begin if ((fFATArray[i] = ftUnusedBlock) and (i > 2)) then begin ChainArray[BlocksFound] := i; inc(BlocksFound); end; Inc(i); if i > High(fFATArray) then begin {grow FAT (allocate another block)} SetLength(fFATArray, Length(fFATArray) + (fAllocSize div SizeOf(Integer))); for j := High(fFATArray) downto (Length(fFATArray) - (fAllocSize div SizeOf(Integer))) do fFATArray[j] := ftUnUsedBlock; end; end; {Update FAT} for i := 0 to High(ChainArray) do begin if i = High(ChainArray) then fFATArray[ChainArray[i]] := -1 else fFATArray[ChainArray[i]] := ChainArray[i+1]; end; end; {-----------------------------------------------------------------------------} procedure TAbFATTable.GetNewFATChain(NumBytes : Integer; var ChainArray : TFATChainArray); {- Finds and commits a new chain starting at the 3rd block. The new chain is returned in the ChainArray parameter} var FirstBlock : Integer; TotalBlocksRequired : Integer; i, j, BlocksFound : Integer; begin if ((NumBytes mod fAllocSize) <> 0) then TotalBlocksRequired := (NumBytes div fAllocSize) + 1 else TotalBlocksRequired := (NumBytes div fAllocSize); if TotalBlocksRequired = 0 then exit; FirstBlock := 2; {set up array} SetLength(ChainArray, TotalBlocksRequired); for i := 0 to High(ChainArray) do ChainArray[i] := ftUnusedBlock; ChainArray[0] := FirstBlock; BlocksFound := 1; i := FirstBlock + 1; while BlocksFound < TotalBlocksRequired do begin if ((fFATArray[i] = ftUnusedBlock) and (i > 2)) then begin ChainArray[BlocksFound] := i; inc(BlocksFound); end; Inc(i); if i > High(fFATArray) then begin {grow FAT (allocate another block)} SetLength(fFATArray, Length(fFATArray) + (fAllocSize div SizeOf(Integer))); for j := High(fFATArray) downto (Length(fFATArray) - (fAllocSize div SizeOf(Integer))) do fFATArray[j] := ftUnUsedBlock; end; end; {Update FAT} for i := 0 to High(ChainArray) do begin if i = High(ChainArray) then fFATArray[ChainArray[i]] := -1 else fFATArray[ChainArray[i]] := ChainArray[i+1]; end; end; {-----------------------------------------------------------------------------} procedure TAbFATTable.GetNewRootDirChain(NumBytes : Integer; var ChainArray : TFATChainArray); {- Finds and commits a new chain starting at the 2nd block. The new chain is returned in the ChainArray parameter} var FirstBlock : Integer; TotalBlocksRequired : Integer; i, j, BlocksFound : Integer; begin if ((NumBytes mod fAllocSize) <> 0) then TotalBlocksRequired := (NumBytes div fAllocSize) + 1 else TotalBlocksRequired := (NumBytes div fAllocSize); if TotalBlocksRequired = 0 then exit; FirstBlock := 1; {set up array} SetLength(ChainArray, TotalBlocksRequired); for i := 0 to High(ChainArray) do ChainArray[i] := ftUnusedBlock; ChainArray[0] := FirstBlock; BlocksFound := 1; i := FirstBlock + 1; while BlocksFound < TotalBlocksRequired do begin if ((fFATArray[i] = ftUnusedBlock) and (i > 2)) then begin ChainArray[BlocksFound] := i; inc(BlocksFound); end; Inc(i); if i > High(fFATArray) then begin {grow FAT (allocate another block)} SetLength(fFATArray, Length(fFATArray) + (fAllocSize div SizeOf(Integer))); for j := High(fFATArray) downto (Length(fFATArray) - (fAllocSize div SizeOf(Integer))) do fFATArray[j] := ftUnUsedBlock; end; end; {Update FAT} for i := 0 to High(ChainArray) do begin if i = High(ChainArray) then fFATArray[ChainArray[i]] := -1 else fFATArray[ChainArray[i]] := ChainArray[i+1]; end; end; {-----------------------------------------------------------------------------} function TAbFATTable.GetNextUnusedBlock : Integer; {- Returns the index into the FAT table of the next block marked as unused} var i, j : Integer; begin if Length(fFATArray) = 0 then Result := -1 else begin Result := -1; i := 3; while i <= High(fFATArray) do begin if fFATArray[i] = ftUnusedBlock then begin Result := i; exit; end; inc(i); if i > High(fFATArray) then begin {grow FAT (allocate another block)} SetLength(fFATArray, Length(fFATArray) + (fAllocSize div SizeOf(Integer))); for j := High(fFATArray) downto (Length(fFATArray) - (fAllocSize div SizeOf(Integer))) do fFATArray[j] := ftUnUsedBlock; end; end; end; end; {-----------------------------------------------------------------------------} procedure TAbFATTable.GetRootDirChain(var ChainArray : TFATChainArray); {- Returns the sequence of FAT blocks used by the RootDir in the ChainArray parameter} begin GetExistingChain(1, ChainArray); end; {-----------------------------------------------------------------------------} function TAbFATTable.IsEndOfFile(Ndx : Integer) : Boolean; {- Returns true if Ndx into FAT signifies end of file} begin if ((Ndx < 0) or (Ndx > High(fFATArray)) or (Length(fFATArray) = 0)) then raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds) else Result := (fFATArray[Ndx] = ftEndOfBlock); end; {-----------------------------------------------------------------------------} function TAbFATTable.IsUnUsed(Ndx : Integer) : Boolean; {- Returns true if Ndx into FAT signifies an unused block} begin if ((Ndx < 0) or (Ndx > High(fFATArray)) or (Length(fFATArray) = 0)) then raise ECompoundFileError.Create(AbCmpndIndexOutOfBounds) else Result := (fFATArray[Ndx] = ftUnUsedBlock); end; {-----------------------------------------------------------------------------} procedure TAbFATTable.WriteToStream(Strm : TMemoryStream); {- Streams and writes the FAT entries to the stream parameter} begin Strm.Write(fFATArray[0], Length(fFATArray) * SizeOf(Integer)); end; {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} {TAbCompoundFile} {-----------------------------------------------------------------------------} {-----------------------------------------------------------------------------} constructor TAbCompoundFile.Create(const FileName : string; const VolLabel : AnsiString; AllocSize : Integer); {- Creates a new instance} var Buff : Array of Byte; begin inherited Create; FSystemBlock := TAbSystemBlock.Create(VolLabel, AllocSize); FFATTable := TAbFATTable.Create(AllocSize); FRootDir := TAbRootDir.Create(VolLabel, AllocSize); {create file} if FileName <> '' then begin FDiskFile := FileName; FStream := TFileStream.Create(FileName, fmOpenReadWrite or fmCreate or fmShareDenyNone); {fill first 3 blocks of file} SetLength(Buff, 3 * AllocSize); FStream.Write(Buff, 3 * AllocSize); {write System, RootDir, and FAT blocks} PersistSystemBlock; PersistRootDirBlock; PersistFATBlock; if Assigned(FOnAfterOpen) then FOnAfterOpen(self); end; end; constructor TAbCompoundFile.Create(const FileName : string; const VolLabel : AnsiString; AllocSize : Integer; const Signature: AnsiString); {- Creates a new instance} var Buff : Array of Byte; begin inherited Create; FSystemBlock := TAbSystemBlock.Create(VolLabel, AllocSize); FSystemBlock.Signature := AbLeftStr(Signature, sbSignatureSize); FFATTable := TAbFATTable.Create(AllocSize); FRootDir := TAbRootDir.Create(VolLabel, AllocSize); {create file} if FileName <> '' then begin FDiskFile := FileName; FStream := TFileStream.Create(FileName, fmOpenReadWrite or fmCreate or fmShareDenyNone); {fill first 3 blocks of file} SetLength(Buff, 3 * AllocSize); FStream.Write(Buff, 3 * AllocSize); {write System, RootDir, and FAT blocks} PersistSystemBlock; PersistRootDirBlock; PersistFATBlock; if Assigned(FOnAfterOpen) then FOnAfterOpen(self); end; end; {-----------------------------------------------------------------------------} destructor TAbCompoundFile.Destroy; {- Persists and then destroys the instance of the compound file} begin PersistSystemBlock; PersistRootDirBlock; PersistFATBlock; if Assigned(FOnBeforeClose) then FOnBeforeClose(self); FSystemBlock.Free; FFATTable.Free; FRootDir.Free; FStream.Free; inherited; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.AddFile(FName : AnsiString; FileData : TStream; FileSize : Integer); function JustFilename(const PathName : AnsiString) : AnsiString; {-Return just the filename and extension of a pathname.} var I : Cardinal; begin Result := ''; if PathName = '' then Exit; I := Succ(Word(Length(PathName))); repeat Dec(I); until (PathName[I] in ['\',':']) or (I = 0); Result := System.Copy(PathName, Succ(I), rdEntryNameSize); end; {- Compresses, adds & persists the data (FileData)} var DirEntry : TAbDirectoryEntry; CompStream : TStream; CompHelper : TAbDeflateHelper; ChainArray : TFATChainArray; begin FName := JustFileName(FName); if ((FStream.Size + FileData.Size + (4 * FSystemBlock.AllocationSize)) >= MaxLongInt) then raise ECompoundFileError.Create(AbCmpndExceedsMaxFileSize); if FSystemBlock.Updating then raise ECompoundFileError.Create(AbCmpndBusyUpdating); FSystemBlock.BeginUpdate; CompStream := TMemoryStream.Create; CompHelper := TAbDeflateHelper.Create; try DirEntry := FRootDir.AddFile(FName); if DirEntry <> nil then begin DirEntry.FSize := FileSize; {compress & update dir entry's compressed size} FileData.Seek(0, soBeginning); Deflate(FileData, CompStream, CompHelper); DirEntry.FCompressedSize := CompStream.Size; {Get new FAT chain & persist the data} SetLength(ChainArray, 0); FFATTable.GetNewChain(CompStream.Size, ChainArray); DirEntry.FStartBlock := ChainArray[0]; PersistFileData(CompStream, ChainArray); PersistRootDirBlock; PersistFATBlock; end; finally CompStream.Free; CompHelper.Free; FSystemBlock.EndUpdate; end; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.AddDirEntriesFromList(Lst : TStringList); {- Add individual root directory entries to RootDir structure maintaining seq.} var i : Integer; LstEntry : TAbDirectoryEntry; Entry : TAbDirectoryEntry; begin for i := 0 to Lst.Count - 1 do begin LstEntry := (Lst.Objects[i] as TAbDirectoryEntry); {locate parent folder} FRootDir.GoToEntryID(LstEntry.FParentFolder); {Add file or folder} if LstEntry.EntryType = etFolder then Entry := FRootDir.AddFolder(LstEntry.FName) else Entry := FRootDir.AddFile(LstEntry.FName); {assign values} Entry.FName := LstEntry.FName; Entry.FEntryID := LstEntry.FEntryID; Entry.FParentFolder := LstEntry.FParentFolder; Entry.FEntryType := LstEntry.FEntryType; Entry.FAttributes := LstEntry.FAttributes; Entry.FStartBlock := LstEntry.FStartBlock; Entry.FLastModified := LstEntry.FLastModified; Entry.FSize := LstEntry.FSize; Entry.FCompressedSize := LstEntry.FCompressedSize; end; end; {-----------------------------------------------------------------------------} function TAbCompoundFile.AddFolder(FName : AnsiString) : Boolean; {- Adds a new folder (directory) to the compound file} var EntryCount : Integer; begin if ((FStream.Size + FSystemBlock.AllocationSize) >= MaxLongInt) then raise ECompoundFileError.Create(AbCmpndExceedsMaxFileSize); EntryCount := FRootDir.Count; FSystemBlock.BeginUpdate; try FRootDir.AddFolder(FName); PersistRootDirBlock; PersistFATBlock; finally FSystemBlock.EndUpdate; end; Result := ((FRootDir.Count - EntryCount) = 1); end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.BuildFat; {- Extracts FAT from this string, writes it to DestStrm(TMemoryStream) and ultimately updates/persists the FAT table} var Buff : Array of Integer; IntBuff : Array[0..0] of Integer; DestStrm : TMemoryStream; i, CurrPos : Integer; NextBlock : Integer; begin DestStrm := TMemoryStream.Create; try {Dim Buff to allocation block size} SetLength(Buff, FSystemBlock.AllocationSize div SizeOf(Integer)); {Clear Buff} for i := Low(Buff) to High(Buff) do Buff[i] := ftUnusedBlock; {read 1st FAT block into Buff -> Write Buff to DestStrm} FStream.Seek(2 * FSystemBlock.AllocationSize, soBeginning); FStream.Read(Buff[0], FSystemBlock.AllocationSize); DestStrm.Write(Buff[0], FSystemBlock.AllocationSize); {Determine next block of FAT chain} NextBlock := Buff[2]; {read remaining FAT blocks if they exist} While NextBlock <> ftEndOfBlock do begin FStream.Seek((NextBlock) * FSystemBlock.AllocationSize, soBeginning); {Clear buff} for i := Low(Buff) to High(Buff) do Buff[i] := ftUnusedBlock; FStream.Read(Buff[0], FSystemBlock.AllocationSize); DestStrm.Write(Buff[0], FSystemBlock.AllocationSize); {Determine the next FAT block - we'll return to this position in stream} CurrPos := DestStrm.Position; DestStrm.Seek((NextBlock - 1) * SizeOf(Integer), soBeginning); DestStrm.Read(IntBuff[0], SizeOf(Integer)); NextBlock := IntBuff[0]; DestStrm.Seek(CurrPos, soBeginning); end; {Set length of and populate the FFATTable.fFATArray in mem structure} DestStrm.Seek(0, soBeginning); SetLength(FFATTable.fFATArray, DestStrm.Size div SizeOf(Integer)); for i := 1 to DestStrm.Size div SizeOf(Integer) do begin DestStrm.Read(IntBuff[0], SizeOf(Integer)); FFATTable.fFATArray[i-1] := IntBuff[0]; end; finally DestStrm.Free; end; PersistFATBlock; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.BuildRootDir; {- Builds list of root directory entries & passes list to AddDirEntriesFromList} var ChainArray : TFATChainArray; DestStrm : TMemoryStream; Buff : Array of Byte; i : Integer; Entry : TAbDirectoryEntry; Lst : TStringList; {RootDirEntry buffers} EName : Array[0..rdEntryNameSize - 1] of AnsiChar; EID : Array[0..0] of Integer; EPF : Array[0..0] of Integer; EType : Array[0..0] of Integer; EAttrib : Array[0..0] of Integer; EStartBlk : Array[0..0] of Integer; EMod : Array[0..0] of TDateTime; ESz : Array[0..0] of Integer; ECompSz : Array[0..0] of Integer; begin {Get RootDir FAT chain} FFATTable.GetRootDirChain(ChainArray); SetLength(Buff, FSystemBlock.AllocationSize); DestStrm := TMemoryStream.Create; Lst := TStringList.Create; Lst.Duplicates := dupAccept; Lst.Sorted := False; try {Read entire RotDir block to DestStrm} for i := 0 to High(ChainArray) do begin FStream.Seek(FSystemBlock.AllocationSize * ChainArray[i], soBeginning); FStream.Read(Buff[0], FSystemBlock.AllocationSize); DestStrm.Write(Buff[0], FSystemBlock.AllocationSize); end; {Reset DestStrm} DestStrm.Seek(0, soBeginning); {For all directory entries, read entry, create object, & add to Lst} for i := 0 to (DestStrm.Size div rdSizeOfDirEntry) - 1 do begin {read a single directory entry} DestStrm.Read(EName[0], rdEntryNameSize); if EName = '' then continue; DestStrm.Read(EID[0], SizeOf(Integer)); DestStrm.Read(EPF[0], SizeOf(Integer)); DestStrm.Read(EType[0], SizeOf(Integer)); DestStrm.Read(EAttrib[0], SizeOf(Integer)); DestStrm.Read(EStartBlk[0], SizeOf(Integer)); DestStrm.Read(EMod[0], SizeOf(TDateTime)); DestStrm.Read(ESz[0], SizeOf(Integer)); DestStrm.Read(ECompSz[0], SizeOf(Integer)); if EType[0] = 0 then Entry := TAbDirectoryEntry.Create(False) else Entry := TAbDirectoryEntry.Create(True); Entry.FName := EName; Entry.FEntryID := EID[0]; Entry.FParentFolder := EPF[0]; if EType[0] = 0 then Entry.FEntryType := etFolder else Entry.FEntryType := etFile; Entry.FAttributes := EAttrib[0]; Entry.FStartBlock := EStartBlk[0]; Entry.FLastModified := EMod[0]; Entry.FSize := ESz[0]; Entry.FCompressedSize := ECompSz[0]; {Don't add an empty dir entry} if Entry.FName <> '' then Lst.AddObject(IntToStr(i), TObject(Entry)); end; {Add individual root directory entries to RootDir structure maintaining seq.} AddDirEntriesFromList(Lst); finally DestStrm.Free; for i := 0 to Lst.Count - 1 do if Lst.Objects[i] <> nil then TAbDirectoryEntry(Lst.Objects[i]).Free; Lst.Free; end; {Save updates} PersistRootDirBlock; PersistFATBlock; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.BuildSysBlock; {- Constructs System block from the contents of FStream (used when opening an existing compound file)} var Sig : Array[0..sbSignatureSize - 1] of AnsiChar; VolLabel : Array[0..sbVolumeLabelSize - 1] of AnsiChar; Version : Array[0..sbVersionSize - 1] of AnsiChar; AllocationSz : Array[0..0] of Integer; begin FStream.Seek(0, soBeginning); FStream.Read(Sig[0], sbSignatureSize); FStream.Read(VolLabel[0], sbVolumeLabelSize); FStream.Read(AllocationSz[0], sbAllocationSizeSize); FStream.Read(Version[0], sbVersionSize); FSystemBlock.Signature := Sig; FSystemBlock.VolumeLabel := VolLabel; FSystemBlock.AllocationSize := AllocationSz[0]; FSystemBlock.FVersion := Version; PersistSystemBlock; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.Defrag; {- Optimizes disk storage} begin { not implemeneted } end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.DeleteFile(FName : AnsiString); {- Deletes the file from the RootDirectory and FAT blocks (data remains)} var StartBlock : Integer; Allow : Boolean; AllowDirMod : Boolean; begin Allow := True; AllowDirMod := True; if not FRootDir.CurrentNode.Contains(FName) then raise ECompoundFileError.Create(AbCmpndFileNotFound); if Assigned(FOnBeforeFileDelete) then FOnBeforeFileDelete(self, FName, Allow); if Assigned(FOnBeforeDirModified) then FOnBeforeDirModified(self, TMultiNode(FRootDir.CurrentNode.Parent).Key, AllowDirMod); if (Allow and AllowDirMod) then begin StartBlock := TAbDirectoryEntry(FRootDir.GetNode(FName).FData).StartBlock; FFATTable.ClearExistingChain(StartBlock); FRootDir.DeleteFile(FName); PersistRootDirBlock; PersistFATBlock; end; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.DeleteFolder(FName : AnsiString); {- Deletes the folder from the RootDirectory block} var Allow : Boolean; AllowDirMod : Boolean; begin Allow := True; AllowDirMod := True; if not FRootDir.CurrentNode.Contains(FName) then raise ECompoundFileError.Create(AbCmpndFileNotFound); if Assigned(FOnBeforeDirDelete) then FOnBeforeDirDelete(self, FName, Allow); if Assigned(FOnBeforeDirModified) then FOnBeforeDirModified(self, TMultiNode(FRootDir.CurrentNode.Parent).Key, AllowDirMod); if (Allow and AllowDirMod) then begin FRootDir.DeleteFolder(FName); PersistRootDirBlock; PersistFATBlock; end; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.EnumerateFiles(Lst : TStringList); var i : Integer; begin Lst.Clear; for i := 0 to FRootDir.CurrentNode.ChildCount - 1 do begin if (FRootDir.CurrentNode.Children[i].Data as TAbDirectoryEntry).EntryType = etFile then Lst.Add(string((FRootDir.CurrentNode.Children[i].Data as TAbDirectoryEntry).EntryName)); end; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.EnumerateFolders(Lst : TStringList); var i : Integer; begin Lst.Clear; for i := 0 to FRootDir.CurrentNode.ChildCount - 1 do begin if (FRootDir.CurrentNode.Children[i].Data as TAbDirectoryEntry).EntryType = etFolder then Lst.Add(string((FRootDir.CurrentNode.Children[i].Data as TAbDirectoryEntry).EntryName)); end; end; {-----------------------------------------------------------------------------} function TAbCompoundFile.GetAllocationSize : Integer; {- Returns the block allocation size used by the compound file} begin result := FSystemBlock.AllocationSize; end; {-----------------------------------------------------------------------------} function TAbCompoundFile.GetCurrentDirectory : AnsiString; {- Returns the current directory} begin Result := FRootDir.CurrentNode.Key; end; {-----------------------------------------------------------------------------} function TAbCompoundFile.GetDirectoryEntries : Integer; {- Returns the total number of directory entries (files and folders)} begin Result := FRootDir.Count; end; {-----------------------------------------------------------------------------} function TAbCompoundFile.GetSizeOnDisk : Integer; {- Returns the compound file size (FStream.Size)} begin Result := FStream.Size; end; {-----------------------------------------------------------------------------} function TAbCompoundFile.GetVolumeLabel : AnsiString; {- Returns the volume label of the compound file} begin Result := FSystemBlock.VolumeLabel; end; {-----------------------------------------------------------------------------} procedure TAbRootDir.GoToEntryID(ID : Integer); {- Traverses tree and sets the current node to the node whose EntryID = ID} begin TraversePost(ID); end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.Open(const FName : string); {- Opens an existing compound file and builds Sys, Root Dir, and FAT blocks} var Sig : Array[0..sbSignatureSize - 1] of AnsiChar; begin if FStream <> nil then FStream.Free; FStream := TFileStream.Create(FName, fmOpenReadWrite or fmShareDenyNone); {Ensure valid signature} FStream.Read(Sig[0], sbSignatureSize); if Sig <> AbLeftStr(FSystemBlock.Signature, sbSignatureSize) then begin raise ECompoundFileError.Create(AbCmpndInvalidFile); exit; end; FDiskFile := FName; {populate Compound File structure} BuildSysBlock; BuildFat; BuildRootDir; if Assigned(FOnAfterOpen) then FOnAfterOpen(self); end; procedure TAbCompoundFile.Open(const FName : string; const Signature: AnsiString); {- Opens an existing compound file and builds Sys, Root Dir, and FAT blocks} var Sig : Array[0..sbSignatureSize - 1] of AnsiChar; begin if FStream <> nil then FStream.Free; FStream := TFileStream.Create(FName, fmOpenReadWrite or fmShareDenyNone); {Ensure valid signature} FStream.Read(Sig[0], sbSignatureSize); if Sig <> AbLeftStr(Signature, sbSignatureSize) then begin raise ECompoundFileError.Create(AbCmpndInvalidFile); exit; end; FDiskFile := FName; {populate Compound File structure} BuildSysBlock; BuildFat; BuildRootDir; if Assigned(FOnAfterOpen) then FOnAfterOpen(self); end; {-----------------------------------------------------------------------------} function TAbCompoundFile.OpenFile(FileName : AnsiString; var Strm : TStream) : Integer; {- Opens the file and writes the file contents to Strm} var ChainArray : TFatChainArray; i, j : Integer; Buff : Array of Byte; RemainingBytes : Integer; CompStream : TStream; CompHelper : TAbDeflateHelper; begin if not FRootDir.CurrentNode.Contains(FileName) then raise ECompoundFileError.Create(AbCmpndFileNotFound); CompStream := TMemoryStream.Create; CompHelper := TAbDeflateHelper.Create; try {Read the existing (compressed) file into CompStream} FFATTable.GetExistingChain((FRootDir.GetNode(FileName).FData as TAbDirectoryEntry).StartBlock, ChainArray); SetLength(Buff, FSystemBlock.AllocationSize); for i := 0 to high(ChainArray) do begin for j := 0 to Pred(FSystemBlock.AllocationSize) do Buff[j] := Byte(chr(0)); FStream.Seek((ChainArray[i]) * FSystemBlock.AllocationSize, soBeginning); if i <> High(ChainArray) then begin FStream.Read(buff[0], FSystemBlock.AllocationSize); CompStream.Write(Buff[0], FSystemBlock.AllocationSize); end else begin {read less than entire block} RemainingBytes := (FRootDir.GetNode(FileName).FData as TAbDirectoryEntry). CompressedSize mod FSystemBlock.AllocationSize; FStream.Read(Buff[0], RemainingBytes); CompStream.Write(Buff[0], RemainingBytes); end; end; {CompStream now contains the entire compressed file stream} CompStream.Seek(0, soBeginning); Inflate(CompStream, Strm, CompHelper); finally CompStream.Free; CompHelper.Free; end; Result := Strm.Size; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.PersistFATBlock; {- Saves the FAT table to disk} var FATStrm : TMemoryStream; Buff : Array of Byte; i : Integer; ChainArray : TFATChainArray; begin {Init Buffer} SetLength(Buff, FSystemBlock.AllocationSize); {Init & fill RootDir stream} FATStrm := TMemoryStream.Create; try FFATTable.WriteToStream(FATStrm); {prep FAT Table} fFATTable.ClearFATChain; fFATTable.GetNewFATChain(FATStrm.Size, ChainArray); FATStrm.Seek(0, soBeginning); for i := 0 to High(ChainArray) do begin {Clear block contents} FillChar(Buff[0], FSystemBlock.AllocationSize, #0); FStream.Seek(FSystemBlock.FAllocationSize * ChainArray[i], soBeginning); FStream.Write(Buff[0], FSystemBlock.AllocationSize); {write new contents} FATStrm.Read(Buff[0], FSystemBlock.AllocationSize); FStream.Seek(FSystemBlock.FAllocationSize * ChainArray[i], soBeginning); FStream.Write(Buff[0], FSystemBlock.AllocationSize); end; finally FATStrm.Free; end; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.PersistFileData(FileData : TStream; var ChainArray : TFATChainArray); {- Walks FAT chain and persists data (FileData) to the corresponding blocks} var Buff : Array of Byte; i : Integer; j : Integer; begin if FileData <> nil then begin FileData.Seek(0, soBeginning); SetLength(Buff, FSystemBlock.AllocationSize); for i := 0 to High(ChainArray) do begin for j := 0 to FSystemBlock.AllocationSize - 1 do Buff[j] := Byte(chr(0)); FileData.Read(Buff[0], FSystemBlock.AllocationSize); FStream.Seek(FSystemBlock.AllocationSize * ChainArray[i], soBeginning); FStream.Write(Buff[0],FSystemBlock.AllocationSize); end; end; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.PersistRootDirBlock; {- Saves the RootDirectory block to disk} var RdStrm : TMemoryStream; Buff : Array of Byte; i : Integer; ChainArray : TFATChainArray; begin {Init Buffer} SetLength(Buff, FSystemBlock.AllocationSize); {Init & fill RootDir stream} RdStrm := TMemoryStream.Create; try FRootDir.WriteToStream(RdStrm); {prep FAT Table} fFATTable.ClearRootDirChain; fFATTable.GetNewRootDirChain(RdStrm.Size, ChainArray); RdStrm.Seek(0, soBeginning); for i := 0 to High(ChainArray) do begin {Clear block contents} FillChar(Buff[0], FSystemBlock.AllocationSize, #0); FStream.Seek(FSystemBlock.FAllocationSize * ChainArray[i], soBeginning); FStream.Write(Buff[0], FSystemBlock.AllocationSize); {write new contents} RdStrm.Read(Buff[0], FSystemBlock.AllocationSize); FStream.Seek(FSystemBlock.FAllocationSize * ChainArray[i], soBeginning); FStream.Write(Buff[0], FSystemBlock.AllocationSize); end; finally RdStrm.Free; end; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.PersistSystemBlock; {- Saves the System block to disk} var Strm : TMemoryStream; Buff : Array of Byte; begin SetLength(Buff, FSystemBlock.AllocationSize); Strm := TMemoryStream.Create; try FSystemBlock.WriteToStream(Strm); Strm.Seek(0, soBeginning); Strm.Read(Buff[0], Strm.Size); FStream.Seek(0, soBeginning); FStream.Write(Buff[0], FSystemBlock.AllocationSize); finally Strm.Free; end; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.SetCurrentDirectory(val : AnsiString); {- Changes the current directory to the val parameter} begin FRootDir.ChangeDir(Val); end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.SetVolumeLabel(Val : AnsiString); {- Sets the volume label of the compound file} begin FSystemBlock.VolumeLabel := Val; PersistSystemBlock; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.UpdateFile(FName : AnsiString; FData : TStream); var StartBlk : Integer; ChainArray : TFATChainArray; DirEntry : TAbDirectoryEntry; CompStream : TStream; CompHelper : TAbDeflateHelper; Allow : Boolean; AllowDirMod : Boolean; begin Allow := True; AllowDirMod := True; if not FRootDir.CurrentNode.Contains(FName) then raise ECompoundFileError.Create(AbCmpndFileNotFound); if ((FStream.Size + FData.Size + (4 * FSystemBlock.AllocationSize)) >= MaxLongInt) then raise ECompoundFileError.Create(AbCmpndExceedsMaxFileSize); if Assigned(FOnBeforeFileModified) then FOnBeforeFileModified(self, FName, Allow); if Assigned(FOnBeforeDirModified) then FOnBeforeDirModified(self, TMultiNode(FRootDir.CurrentNode.Parent).Key, AllowDirMod); if (Allow and AllowDirMod) then begin {get dir entry & start block} DirEntry := TAbDirectoryEntry(FRootDir.CurrentNode.GetChildByName(FName).Data); StartBlk := DirEntry.StartBlock; CompStream := TMemoryStream.Create; CompHelper := TAbDeflateHelper.Create; try {clear existing FAT chain} FFATTable.ClearExistingChain(StartBlk); SetLength(ChainArray, 0); {Deflate data} FData.Seek(0, soBeginning); Deflate(FData, CompStream, CompHelper); {Commit new FAT chain} FFATTable.GetNewChain(CompStream.Size, ChainArray); {update start block, size, compressed size} DirEntry.FStartBlock := ChainArray[0]; DirEntry.Size := FData.Size; DirEntry.CompressedSize := CompStream.Size; {persist changes} PersistFileData(CompStream, ChainArray); PersistRootDirBlock; PersistFATBlock; finally CompStream.Free; CompHelper.Free; end; end; end; {-----------------------------------------------------------------------------} function TAbCompoundFile.PopulateTreeView(TreeView : TTreeView) : Integer; {- Populates the tree view parameter with all root directory entries} var i : Integer; TreeNode : TTreeNode; begin TreeView.Items.Clear; if FRootDir.Root <> nil then begin TreeNode := TreeView.Items.Add(nil, string(FRootDir.Root.Key)); TreeNode.ImageIndex := 0; TreeNode.SelectedIndex := 0; if FRootDir.Root.HasChildren then begin for i := 0 to FRootDir.Root.ChildCount - 1 do PopulateSubNodes(FRootDir.Root.Children[i], TreeView, TreeNode); end; end; Result := TreeView.Items.Count; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.PopulateSubNodes(ParentNode : TMultiNode; TreeView : TTreeView; TreeNode : TTreeNode); {- Visits sub-nodes recursively - pre order} var Curr : TMultiNode; i : Integer; Node : TTreeNode; begin Node := TreeView.Items.AddChild(TreeNode, string(ParentNode.Key)); if TAbDirectoryEntry(ParentNode.Data).EntryType = etFolder then begin Node.ImageIndex := 0; Node.SelectedIndex := 0; end else begin Node.ImageIndex := 1; Node.SelectedIndex := 1; end; Curr := ParentNode; if Curr <> nil then begin if Curr.HasChildren then begin for i := 0 to Curr.ChildCount -1 do PopulateSubNodes(Curr.Children[i], TreeView, Node); end; end; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.RenameFile(OrigName, NewName : AnsiString); {- Renames the file if file is found} var MultNode : TMultiNode; Allow : Boolean; AllowDirMod : Boolean; begin Allow := True; AllowDirMod := True; {confirm valid names} if ((OrigName = '') or (NewName = '')) then exit; {prevent duplicate names} if ((FRootDir.FCurrentNode.Contains(NewName)) or (FRootDir.FCurrentNode.Key = NewName)) then exit; if Assigned(FOnBeforeFileModified) then FOnBeforeFileModified(self, OrigName, Allow); if Assigned(FOnBeforeDirModified) then FOnBeforeDirModified(self, TMultiNode(FRootDir.CurrentNode.Parent).Key, AllowDirMod); if (Allow and AllowDirMod) then begin if FRootDir.FCurrentNode.Contains(OrigName) then begin MultNode := FRootDir.FCurrentNode.GetChildByName(OrigName); MultNode.Key := NewName; TAbDirectoryEntry(MultNode.Data).FName := NewName; PersistRootDirBlock; end else if FRootDir.FCurrentNode.Key = OrigName then begin MultNode := FRootDir.FCurrentNode; MultNode.Key := NewName; TAbDirectoryEntry(MultNode.Data).FName := NewName; PersistRootDirBlock; end else raise ECompoundFileError.Create(AbCmpndFileNotFound); end; end; {-----------------------------------------------------------------------------} procedure TAbCompoundFile.RenameFolder(OrigName, NewName : AnsiString); {- Renames the folder if the folder is found} var MultNode : TMultiNode; Allow : Boolean; AllowDirMod : Boolean; begin Allow := True; AllowDirMod := True; {confirm valid names} if ((OrigName = '') or (NewName = '')) then exit; {prevent duplicate names} if ((FRootDir.FCurrentNode.Contains(NewName)) or (FRootDir.FCurrentNode.Key = NewName)) then exit; if Assigned(FOnBeforeFileModified) then FOnBeforeFileModified(self, OrigName, Allow); if Assigned(FOnBeforeDirModified) then FOnBeforeDirModified(self, TMultiNode(FRootDir.CurrentNode.Parent).Key, AllowDirMod); if (Allow and AllowDirMod) then begin if FRootDir.FCurrentNode.Contains(OrigName) then begin MultNode := FRootDir.FCurrentNode.GetChildByName(OrigName); if (TAbDirectoryEntry(MultNode.Data).EntryType <> etFolder) then exit; MultNode.Key := NewName; TAbDirectoryEntry(MultNode.Data).FName := NewName; PersistRootDirBlock; end else if FRootDir.FCurrentNode.Key = OrigName then begin MultNode := FRootDir.FCurrentNode; if (TAbDirectoryEntry(MultNode.Data).EntryType <> etFolder) then exit; MultNode.Key := NewName; TAbDirectoryEntry(MultNode.Data).FName := NewName; PersistRootDirBlock; end else raise ECompoundFileError.Create(AbCmpndFileNotFound); end; end; {-----------------------------------------------------------------------------} end.