abcompnd.inc

Lazarus is a free and open source development tool for the FreePascal Compiler. The purpose of the p

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(VolLabel : string; AllocationSz : Integer);
{- Creates the System block structure of the compound file}
begin
  inherited Create;
  FSignature      := 'AbCompoundFile';
  FVolumeLabel    := VolLabel;
  FAllocationSize := AllocationSz;
  FVersion        := AbCompoundFileVersion;                            {!!.03}
  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 char;
  VolLabel  : Array[0..sbVolumeLabelSize - 1] of char;
  AllocSize : Integer;
  Version   : Array[0..sbVersionSize - 1] of char;
  Updt      : Byte;
begin
  FillChar(Sig, sbSignatureSize, #0);
  strpcopy(Sig, FSignature);

  FillChar(VolLabel[0], sbVolumeLabelSize, #0);
  StrPCopy(VolLabel, FVolumeLabel);

  AllocSize := FAllocationSize;

  FillChar(Version[0], sbVersionSize, #0);
  StrPCopy(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;
{$IFNDEF Linux}
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
    FAttributes     := faArchive;
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
{$ELSE}
{$WARN SYMBOL_PLATFORM OFF}
    FAttributes     := faArchive;
{$WARN SYMBOL_PLATFORM ON}
{$ENDIF LINUX}
  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
{$IFNDEF Linux}
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
  Result := ((FAttributes and faArchive) > 0);
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
{$ELSE}
{$WARN SYMBOL_PLATFORM OFF}
  Result := ((FAttributes and faArchive) > 0);
{$WARN SYMBOL_PLATFORM ON}
{$ENDIF LINUX}
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
{$IFNDEF Linux}
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
  Result := ((FAttributes and faHidden) > 0);
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
{$ELSE}
{$WARN SYMBOL_PLATFORM OFF}
  Result := ((FAttributes and faHidden) > 0);
{$WARN SYMBOL_PLATFORM ON}
{$ENDIF LINUX}
end;
{-----------------------------------------------------------------------------}
function TAbDirectoryEntry.IsReadOnly : Boolean;
  {- returns true if the entry is read-only}
begin
{$IFNDEF Linux}
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
  Result := ((FAttributes and faReadOnly) > 0);
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
{$ELSE}
{$WARN SYMBOL_PLATFORM OFF}
  Result := ((FAttributes and faReadOnly) > 0);
{$WARN SYMBOL_PLATFORM ON}
{$ENDIF LINUX}
end;
{-----------------------------------------------------------------------------}
function TAbDirectoryEntry.IsSysFile : Boolean;
  {- returns true if the entry is a system file}
begin
{$IFNDEF Linux}
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
  Result := ((FAttributes and faSysFile) > 0);
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
{$ELSE}
{$WARN SYMBOL_PLATFORM OFF}
  Result := ((FAttributes and faSysFile) > 0);
{$WARN SYMBOL_PLATFORM ON}
{$ENDIF LINUX}
end;
{-----------------------------------------------------------------------------}
function TAbDirectoryEntry.IsVolumeID : Boolean;
  {- returns true if the entry is a volume ID}
begin
{$IFNDEF Linux}
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
  Result := ((FAttributes and faVolumeID) > 0);
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
{$ELSE}
{$WARN SYMBOL_PLATFORM OFF}
  Result := ((FAttributes and faVolumeID) > 0);
{$WARN SYMBOL_PLATFORM ON}
{$ENDIF LINUX}
end;
{-----------------------------------------------------------------------------}
procedure TAbDirectoryEntry.WriteToStream(Strm : TMemoryStream);
  {- writes properties to stream}
var
  EntryName : Array[0..rdEntryNameSize] of char;
  FType     : Integer;
begin
  FillChar(EntryName, rdEntryNameSize - 1, #0);
  StrPCopy(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 : string; 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 : string) : 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;
{$IFNDEF Linux}
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
    NewData.Attributes := faArchive;
{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
{$ELSE}
{$WARN SYMBOL_PLATFORM OFF}
    NewData.Attributes := faArchive;
{$WARN SYMBOL_PLATFORM ON}
{$ENDIF LINUX}
    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 : string) : 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 : string);
  {- Deletes the specified file if found}
begin
  DeleteNode(FileName);
end;
{-----------------------------------------------------------------------------}
procedure TAbRootDir.DeleteFolder(FolderName : string);
  {- 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}