abcompnd.inc

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

  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(FileName : string; VolLabel : string;
                                   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;
{-----------------------------------------------------------------------------}
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 : string; FileData : TStream;
                                  FileSize : Integer);
   function JustFilename(const PathName : String) : String;            {!!.01}
     {-Return just the filename and extension of a pathname.}          {!!.01}
   var                                                                 {!!.01}
     I : Cardinal;                                                     {!!.01}
   begin                                                               {!!.01}
     Result := '';                                                     {!!.01}
     if PathName = '' then Exit;                                       {!!.01}
     I := Succ(Word(Length(PathName)));                                {!!.01}
     repeat                                                            {!!.01}
       Dec(I);                                                         {!!.01}
     until (PathName[I] in ['\',':']) or (I = 0);                      {!!.01}
     Result := System.Copy(PathName, Succ(I), rdEntryNameSize);        {!!.01}
   end;                                                                {!!.01}

  {- Compresses, adds & persists the data (FileData)}
var
  DirEntry   : TAbDirectoryEntry;
  CompStream : TStream;
  CompHelper : TAbDeflateHelper;
  ChainArray : TFATChainArray;
begin
  FName := JustFileName(FName);                                        {!!.01}
  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, soFromBeginning);
      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;