abtartyp.pas

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

(* ***** 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: AbTarTyp.pas 3.05                           *}
{*********************************************************}
{* ABBREVIA: TAbTarArchive, TAbTarItem classes           *}
{*********************************************************}
{* Misc. constants, types, and routines for working      *}
{* with Tar files                                        *}
{*********************************************************}

{$I AbDefine.inc}

unit AbTarTyp;

interface

uses
{$IFDEF MSWINDOWS }
  Windows,
{$ENDIF MSWINDOWS }
  SysUtils, Classes,
  AbUtils, AbVMStrm, AbSpanSt, AbExcept, AbArcTyp;

const
  AB_TAR_RECORDSIZE  = 512;
  AB_TAR_NAMESIZE    = 100;
  AB_TAR_TUSRNAMELEN = 32;
  AB_TAR_TGRPNAMELEN = 32;

{ The checksum field is filled with this while the checksum is computed. }
  AB_TAR_CHKBLANKS = '        ';        { 8 blanks, no null }

  AB_TAR_EMPTY_OCT = '00000000';

{ The magic field is filled with this if uname and gname are valid. }
  AB_TAR_TMAGIC        = 'ustar  '#0;   { 7 chars and a null }

{ The magic field is filled with this if this is a GNU format dump entry }
  AB_TAR_GNUMAGIC      = 'GNUtar '#0;   { 7 chars and a null }

{ The linkflag defines the type of file }
  AB_TAR_LF_OLDNORMAL = #0;   { Normal disk file, Unix compatible }
  AB_TAR_LF_NORMAL    = '0';  { Normal disk file }
  AB_TAR_LF_LINK      = '1';  { Link to previously dumped file }
  AB_TAR_LF_SYMLINK   = '2';  { Symbolic link }
  AB_TAR_LF_CHR       = '3';  { Character special file }
  AB_TAR_LF_BLK       = '4';  { Block special file }
  AB_TAR_LF_DIR       = '5';  { Directory }
  AB_TAR_LF_FIFO      = '6';  { FIFO special file }
  AB_TAR_LF_CONTIG    = '7';  { Contiguous file }

{ Further link types may be defined later. }

{ Bits used in the mode field - values in octal }
  AB_TAR_TSUID   = $0800;   { Set UID on execution }
  AB_TAR_TSGID   = $0400;   { Set GID on execution }
  AB_TAR_TSVTX   = $0200;   { Save text (sticky bit) }

{ File permissions }
  AB_TAR_TUREAD  = $0100;   { read by owner }
  AB_TAR_TUWRITE = $0080;   { write by owner }
  AB_TAR_TUEXEC  = $0040;   { execute/search by owner }
  AB_TAR_TGREAD  = $0020;   { read by group }
  AB_TAR_TGWRITE = $0010;   { write by group }
  AB_TAR_TGEXEC  = $0008;   { execute/search by group }
  AB_TAR_TOREAD  = $0004;   { read by other }
  AB_TAR_TOWRITE = $0002;   { write by other }
  AB_TAR_TOEXEC  = $0001;   { execute/search by other }

type
  Arr8  = array [0..7] of AnsiChar;
  Arr12 = array [0..11] of AnsiChar;
  ArrName = array [0..AB_TAR_NAMESIZE-1] of AnsiChar;

  TAbTarHeaderRec = packed record
    Name     : ArrName;   { filename, null terminated ASCII string }
    Mode     : Arr8;      { file mode (UNIX style, ASCII coded Octal) }
    uid      : Arr8;      { usrid # (UNIX style, ASCII coded Octal) }
    gid      : Arr8;      { grpid # (UNIX style, ASCII coded Octal) }
    Size     : Arr12;     { size of TARred file (ASCII coded Octal) }
    ModTime  : Arr12;     { last file modification (UNIX Date in ASCII coded Octal) }
    ChkSum   : Arr8;      { checksum of header (ASCII coded Octal) }
    LinkFlag : AnsiChar;  { type of item, one of the Link Flag constants from above }
    LinkName : ArrName;   { name of link, null terminated ASCII string }
    Magic    : Arr8;      { identifier, usuall 'ustar' }
    UsrName  : array [0..AB_TAR_TUSRNAMELEN-1] of AnsiChar;
                          { username, null terminated ASCII string }
    GrpName  : array [0..AB_TAR_TGRPNAMELEN-1] of AnsiChar;
                          { groupname, null terminated ASCII string }
    DevMajor : Arr8;      { major device ID (UNIX style, ASCII coded Octal) }
    DevMinor : Arr8;      { minor device ID (UNIX style, ASCII coded Octal) }
  end;


type
  TAbTarItem = class(TAbArchiveItem)
  private
    function GetMagic: string;
  protected {private}
    FTarHeader: TAbTarHeaderRec;
  protected
    function GetDevMajor: Integer;
    function GetDevMinor: Integer;
    function GetGroupID: Integer;
    function GetGroupName: string;
    function GetLinkName: string;
    function GetUserID: Integer;
    function GetUserName: string;

    procedure SetDevMajor(const Value: Integer);
    procedure SetDevMinor(const Value: Integer);
    procedure SetGroupID(const Value: Integer);
    procedure SetGroupName(const Value: string);
    procedure SetLinkName(const Value: string);
    procedure SetUserID(const Value: Integer);
    procedure SetUserName(const Value: string);

    function GetCompressedSize : LongInt; override;
    function GetExternalFileAttributes : LongInt; override;
    function GetFileName : string; override;
    function GetIsEncrypted : Boolean; override;
    function GetLastModFileDate : Word; override;
    function GetLastModFileTime : Word; override;
    function GetUncompressedSize : LongInt; override;

    procedure SetCompressedSize(const Value : LongInt); override;
    procedure SetExternalFileAttributes( Value : LongInt ); override;
    procedure SetFileName(Value : string); override;
    procedure SetIsEncrypted(Value : Boolean); override;
    procedure SetLastModFileDate(const Value : Word); override;
    procedure SetLastModFileTime(const Value : Word); override;
    procedure SetUncompressedSize(const Value : LongInt); override;

    procedure SaveTarHeaderToStream(AStream : TStream);
    procedure LoadTarHeaderFromStream(AStream :TStream);

    property Magic : string
      read GetMagic;
  public
    property DevMajor : Integer
      read GetDevMajor write SetDevMajor;
    property DevMinor : Integer
      read GetDevMinor write SetDevMinor;
    property GroupID : Integer
      read GetGroupID write SetGroupID;
    property GroupName : string
      read GetGroupName write SetGroupName;
    property LinkFlag : AnsiChar
      read FTarHeader.LinkFlag write FTarHeader.LinkFlag;
    property LinkName : string
      read GetLinkName write SetLinkName;
    property Mode : LongInt
      read GetExternalFileAttributes write SetExternalFileAttributes;
    property UserID : Integer
      read GetUserID write SetUserID;
    property UserName : string
      read GetUserName write SetUserName;
    property ExternalFileAttributes;
    constructor Create;
  end;


  TAbTarStreamHelper = class(TAbArchiveStreamHelper)
  private
    function SeekItemData(Index: Integer): Boolean;
  protected
    FTarHeader : TAbTarHeaderRec;
  public
    destructor Destroy; override;
    procedure ExtractItemData(AStream : TStream); override;
    function FindFirstItem : Boolean; override;
    function FindNextItem : Boolean; override;
    procedure ReadHeader; override;
    procedure ReadTail; override;
    function SeekItem(Index : Integer): Boolean; override;
    procedure WriteArchiveHeader; override;
    procedure WriteArchiveItem(AStream : TStream); override;
    procedure WriteArchiveTail; override;
    function GetItemCount : Integer; override;
  end;


  TAbTarArchive = class(TAbArchive)
  protected
    function CreateItem(const FileSpec : string): TAbArchiveItem;
      override;
    procedure ExtractItemAt(Index : Integer; const NewName : string);
      override;
    procedure ExtractItemToStreamAt(Index : Integer; aStream : TStream);
      override;
    procedure LoadArchive;
      override;
    procedure SaveArchive;
      override;
    procedure TestItemAt(Index : Integer);
      override;
    function FixName(Value: string): string;
      override;

    function GetItem(Index: Integer): TAbTarItem;                   {!!.03}
    procedure PutItem(Index: Integer; const Value: TAbTarItem);     {!!.03}
  public {methods}
    constructor Create(FileName : string; Mode : Word);
      override;
    destructor  Destroy;
      override;

    property Items[Index : Integer] : TAbTarItem                    {!!.03}
      read GetItem                                                  {!!.03}
      write PutItem; default;                                       {!!.03}


 end;

function VerifyTar(Strm : TStream) : TAbArchiveType;

implementation

function OctalToInt(const Oct : PAnsiChar; aLen : integer): Integer;
var
  i : integer;
begin
  Result := 0;

  i := 0;
  while (i < aLen) and (Oct[i] = ' ') do
    inc(i);

  if (i = aLen) then
    Exit;

  while (i < aLen) and (Oct[i] in ['0'..'7']) do begin
    Result := (Result * 8) + (Ord(Oct[i]) - Ord('0'));
    inc(i);
  end;

end;

function IntToOctal(Value : Integer): string;
const
  OctDigits  : array[0..7] of AnsiChar = '01234567';
begin
  if Value = 0 then
    Result := '0'
  else begin
    Result := '';
    while Value > 0 do begin
      Result := OctDigits[Value and 7] + Result;
      Value := Value shr 3;
    end;
  end;
end;

function CalcTarHeaderChkSum(TarH : TAbTarHeaderRec): LongInt;
var
  HdrBuffer : PAnsiChar;
  HdrChkSum : LongInt;
  j : Integer;
begin
  { prepare for the checksum calculation }
  HdrBuffer := PAnsiChar(@TarH);                                         {!!.02}
  HdrChkSum := 0;

  {calculate the checksum, a simple sum of the bytes in the header}
  for j := 0 to Pred(SizeOf(TAbTarHeaderRec)) do
    HdrChkSum := HdrChkSum + Ord(HdrBuffer[j]);

  Result := HdrChkSum;
end;

function VerifyHeader(TarH : TAbTarHeaderRec): Boolean;
{ check "Magic" field in Tar Header}
begin
  Result := (TarH.Magic = StrPas(AB_TAR_TMAGIC)) or
     (TarH.Magic = StrPas(AB_TAR_GNUMAGIC));
end;

function VerifyTar(Strm : TStream) : TAbArchiveType;
{ assumes Tar positioned correctly for test of item }
var
  TarHlp : TAbTarStreamHelper;
  TarItem : TAbTarItem;
  TarChkSum : LongInt;
  TarHead : TAbTarHeaderRec;
begin
  { really only verifies that the data read from current stream position
    appears to be tarred data }
  TarHlp := TAbTarStreamHelper.Create(Strm);
  TarItem := TAbTarItem.Create;

  try
    { get current Tar Header }
    TarItem.LoadTarHeaderFromStream(Strm);
    TarHead := TarItem.FTarHeader;

    { verify check sum }
    TarChkSum := OctalToInt(TarItem.FTarHeader.ChkSum, sizeof(TarItem.FTarHeader.ChkSum));
    TarHead.ChkSum := AB_TAR_CHKBLANKS;
    if (CalcTarHeaderChkSum(TarHead) = TarChkSum) or
       VerifyHeader(TarItem.FTarHeader)
    then
      Result := atTar
    else
      result := atUnknown;
  finally
    TarItem.Free;
    TarHlp.Free;
  end;
end;

function PadString(const S : string; Places : Integer) : string;
{
Pads a string (S) with one right space and as many left spaces as
needed to fill Places

If length S greater than Places, just returns S

Some TAR utilities evidently expect Octal numeric fields to be in
this format
}
begin
  if Length(S) >= LongInt(Places) then
    Result := S
  else begin
    Result := S + ' ';
    Result := StringOfChar(' ', Places - Length(Result)) + Result;
  end;
end;


function RoundToTarBlock(Size: Integer): Integer;
begin
  Result := (Size + (AB_TAR_RECORDSIZE - 1)) and
             not (AB_TAR_RECORDSIZE - 1);
end;


function FindFirstTarItem(TarF: TStream; var Item : TAbTarHeaderRec): Integer;
begin
  { reset Tar }
  TarF.Seek(0, soFromBeginning);
  Result := TarF.Read(Item, SizeOf(TAbTarHeaderRec));
end;

function FindNextTarItem(TarF: TStream; var Item : TAbTarHeaderRec): Integer;
var
  Len: Integer;
begin
  { find length of item }
  Len := RoundToTarBlock(OctalToInt(Item.Size, 12));
  { seek past file to next header }
  TarF.Seek((AB_TAR_RECORDSIZE-SizeOf(TAbTarHeaderRec)) + Len, soFromCurrent);
  Result := TarF.Read(Item, SizeOf(TAbTarHeaderRec));
end;


procedure ListTarContents(TarF: TStream; List: TStrings);
{
Get listing of files in Tar
}
var
  TarH : TAbTarHeaderRec;
  FN: string;
begin
  { reset Tar }
  FindFirstTarItem(TarF, TarH);

  { while more data in Tar }
  while TarF.Position < TarF.Size do begin
    { if it's a file }
      if TarH.LinkFlag in [AB_TAR_LF_OLDNORMAL, AB_TAR_LF_NORMAL] then begin
      { add filename to List }
        FN := StrPas(TarH.Name);
        if FN <> '' then
          List.Add(FN);
    end; {if}

    FindNextTarItem(TarF, TarH);
  end; {while}
end;



{ TAbTarItem }

constructor TAbTarItem.Create;
begin
  inherited Create;
  FillChar(FTarHeader, SizeOf(TAbTarHeaderRec), #0);
  { set defaults }
  FTarHeader.Magic := AB_TAR_TMAGIC;
  FileName := '';
  Mode := AB_FPERMISSION_GENERIC;
  UserID := 0;
  GroupID := 0;
  LinkFlag := AB_TAR_LF_NORMAL;
  UserName := '';
  GroupName := '';
  DevMajor := 0;