(** Copyright (c) 2000-2006 by Stefan Heymann See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. =============================================================================================== Name : LibTar =============================================================================================== Subject : Handling of "tar" files =============================================================================================== Author : Stefan Heymann Eschenweg 3 72076 Tübingen GERMANY E-Mail: stefan@destructor.de Web: www.destructor.de =============================================================================================== TTarArchive Usage ----------------- - Choose a constructor - Make an instance of TTarArchive TA := TTarArchive.Create (Filename); - Scan through the archive TA.Reset; WHILE TA.FindNext (DirRec) DO BEGIN - Evaluate the DirRec for each file ListBox.Items.Add (DirRec.Name); - Read out the current file TA.ReadFile (DestFilename); (You can ommit this if you want to read in the directory only) END; - You're done TA.Free; TTarWriter Usage ---------------- - Choose a constructor - Make an instance of TTarWriter TW := TTarWriter.Create ('my.tar'); - Add a file to the tar archive TW.AddFile ('foobar.txt'); - Add a string as a file TW.AddString (SL.Text, 'joe.txt', Now); - Destroy TarWriter instance TW.Free; - Now your tar file is ready. Source -------------------------- The official site to get this code is http://www.destructor.de/ Donateware ---------- If you like this code, you are free to donate http://www.destructor.de/donateware.htm =============================================================================================== !!! All parts of this code which are not finished or known to be buggy are marked with three exclamation marks =============================================================================================== Date Author Changes ----------------------------------------------------------------------------------------------- 2001-04-26 HeySt 0.0.1 Start 2001-04-28 HeySt 1.0.0 First Release 2001-06-19 HeySt 2.0.0 Finished TTarWriter 2001-09-06 HeySt 2.0.1 Bugfix in TTarArchive.FindNext: FBytesToGo must sometimes be 0 2001-10-25 HeySt 2.0.2 Introduced the ClearDirRec procedure 2001-11-13 HeySt 2.0.3 Bugfix: Take out ClearDirRec call from WriteTarHeader Bug Reported by Tony BenBrahim 2001-12-25 HeySt 2.0.4 WriteTarHeader: Fill Rec with zero bytes before filling it 2002-05-18 HeySt 2.0.5 Kylix awareness: Thanks to Kerry L. Davison for the canges 2005-09-03 HeySt 2.0.6 TTarArchive.FindNext: Don't access SourceStream.Size (for compressed streams, which don't know their .Size) 2006-03-13 HeySt 2.0.7 Bugfix in ReadFile (Buffer : POINTER) 2006-09-20 MvdV 2.0.7.1 Small fixes for FPC. *) UNIT LibTar; INTERFACE {$IFDEF FPC} {$MODE Delphi} {$ELSE} {$IFDEF LINUX} {$DEFINE Kylix} {$DEFINE LIBCUNIT} {$ENDIF} {$ENDIF} USES {$IFDEF LIBCUNIT} Libc, // MvdV: Nothing is used from this??? {$ENDIF} {$ifdef Unix} BaseUnix, Unix, {$endif} (*$IFDEF MSWINDOWS *) Windows, (*$ENDIF *) SysUtils, Classes; TYPE // --- File Access Permissions TTarPermission = (tpReadByOwner, tpWriteByOwner, tpExecuteByOwner, tpReadByGroup, tpWriteByGroup, tpExecuteByGroup, tpReadByOther, tpWriteByOther, tpExecuteByOther); TTarPermissions = SET OF TTarPermission; // --- Type of File TFileType = (ftNormal, // Regular file ftLink, // Link to another, previously archived, file (LinkName) ftSymbolicLink, // Symbolic link to another file (LinkName) ftCharacter, // Character special files ftBlock, // Block special files ftDirectory, // Directory entry. Size is zero (unlimited) or max. number of bytes ftFifo, // FIFO special file. No data stored in the archive. ftContiguous, // Contiguous file, if supported by OS ftDumpDir, // List of files ftMultiVolume, // Multi-volume file part ftVolumeHeader); // Volume header. Can appear only as first record in the archive // --- Mode TTarMode = (tmSetUid, tmSetGid, tmSaveText); TTarModes = SET OF TTarMode; // --- Record for a Directory Entry // Adjust the ClearDirRec procedure when this record changes! TTarDirRec = RECORD Name : STRING; // File path and name Size : INT64; // File size in Bytes DateTime : TDateTime; // Last modification date and time Permissions : TTarPermissions; // Access permissions FileType : TFileType; // Type of file LinkName : STRING; // Name of linked file (for ftLink, ftSymbolicLink) UID : INTEGER; // User ID GID : INTEGER; // Group ID UserName : STRING; // User name GroupName : STRING; // Group name ChecksumOK : BOOLEAN; // Checksum was OK Mode : TTarModes; // Mode Magic : STRING; // Contents of the "Magic" field MajorDevNo : INTEGER; // Major Device No. for ftCharacter and ftBlock MinorDevNo : INTEGER; // Minor Device No. for ftCharacter and ftBlock FilePos : INT64; // Position in TAR file END; // --- The TAR Archive CLASS TTarArchive = CLASS PROTECTED FStream : TStream; // Internal Stream FOwnsStream : BOOLEAN; // True if FStream is owned by the TTarArchive instance FBytesToGo : INT64; // Bytes until the next Header Record PUBLIC CONSTRUCTOR Create (Stream : TStream); OVERLOAD; CONSTRUCTOR Create (Filename : STRING; FileMode : WORD = fmOpenRead OR fmShareDenyWrite); OVERLOAD; DESTRUCTOR Destroy; OVERRIDE; PROCEDURE Reset; // Reset File Pointer FUNCTION FindNext (VAR DirRec : TTarDirRec) : BOOLEAN; // Reads next Directory Info Record. FALSE if EOF reached PROCEDURE ReadFile (Buffer : POINTER); OVERLOAD; // Reads file data for last Directory Record PROCEDURE ReadFile (Stream : TStream); OVERLOAD; // -;- PROCEDURE ReadFile (Filename : STRING); OVERLOAD; // -;- FUNCTION ReadFile : STRING; OVERLOAD; // -;- PROCEDURE GetFilePos (VAR Current, Size : INT64); // Current File Position PROCEDURE SetFilePos (NewPos : INT64); // Set new Current File Position END; // --- The TAR Archive Writer CLASS TTarWriter = CLASS PROTECTED FStream : TStream; FOwnsStream : BOOLEAN; FFinalized : BOOLEAN; // --- Used at the next "Add" method call: --- FPermissions : TTarPermissions; // Access permissions FUID : INTEGER; // User ID FGID : INTEGER; // Group ID FUserName : STRING; // User name FGroupName : STRING; // Group name FMode : TTarModes; // Mode FMagic : STRING; // Contents of the "Magic" field CONSTRUCTOR CreateEmpty; PUBLIC CONSTRUCTOR Create (TargetStream : TStream); OVERLOAD; CONSTRUCTOR Create (TargetFilename : STRING; Mode : INTEGER = fmCreate); OVERLOAD; DESTRUCTOR Destroy; OVERRIDE; // Writes End-Of-File Tag FUNCTION AddFile (Filename : STRING; TarFilename : STRING = '') : BOOLEAN; PROCEDURE AddStream (Stream : TStream; TarFilename : STRING; FileDateGmt : TDateTime); PROCEDURE AddString (Contents : STRING; TarFilename : STRING; FileDateGmt : TDateTime); PROCEDURE AddDir (Dirname : STRING; DateGmt : TDateTime; MaxDirSize : INT64 = 0); PROCEDURE AddSymbolicLink (Filename, Linkname : STRING; DateGmt : TDateTime); PROCEDURE AddLink (Filename, Linkname : STRING; DateGmt : TDateTime); PROCEDURE AddVolumeHeader (VolumeId : STRING; DateGmt : TDateTime); PROCEDURE Finalize; PROPERTY Permissions : TTarPermissions READ FPermissions WRITE FPermissions; // Access permissions PROPERTY UID : INTEGER READ FUID WRITE FUID; // User ID PROPERTY GID : INTEGER READ FGID WRITE FGID; // Group ID PROPERTY UserName : STRING READ FUserName WRITE FUserName; // User name PROPERTY GroupName : STRING READ FGroupName WRITE FGroupName; // Group name PROPERTY Mode : TTarModes READ FMode WRITE FMode; // Mode PROPERTY Magic : STRING READ FMagic WRITE FMagic; // Contents of the "Magic" field END; // --- Some useful constants CONST FILETYPE_NAME : ARRAY [TFileType] OF STRING = ('Regular', 'Link', 'Symbolic Link', 'Char File', 'Block File', 'Directory', 'FIFO File', 'Contiguous', 'Dir Dump', 'Multivol', 'Volume Header'); ALL_PERMISSIONS = [tpReadByOwner, tpWriteByOwner, tpExecuteByOwner, tpReadByGroup, tpWriteByGroup, tpExecuteByGroup, tpReadByOther, tpWriteByOther, tpExecuteByOther]; READ_PERMISSIONS = [tpReadByOwner, tpReadByGroup, tpReadByOther]; WRITE_PERMISSIONS = [tpWriteByOwner, tpWriteByGroup, tpWriteByOther]; EXECUTE_PERMISSIONS = [tpExecuteByOwner, tpExecuteByGroup, tpExecuteByOther]; FUNCTION PermissionString (Permissions : TTarPermissions) : STRING; FUNCTION ConvertFilename (Filename : STRING) : STRING; FUNCTION FileTimeGMT (FileName : STRING) : TDateTime; OVERLOAD; FUNCTION FileTimeGMT (SearchRec : TSearchRec) : TDateTime; OVERLOAD; PROCEDURE ClearDirRec (VAR DirRec : TTarDirRec); (* =============================================================================================== IMPLEMENTATION =============================================================================================== *) IMPLEMENTATION FUNCTION PermissionString (Permissions : TTarPermissions) : STRING; BEGIN Result := ''; IF tpReadByOwner IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-'; IF tpWriteByOwner IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-'; IF tpExecuteByOwner IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-'; IF tpReadByGroup IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-'; IF tpWriteByGroup IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-'; IF tpExecuteByGroup IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-'; IF tpReadByOther IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-'; IF tpWriteByOther IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-'; IF tpExecuteByOther IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-'; END; FUNCTION ConvertFilename (Filename : STRING) : STRING; // Converts the filename to Unix conventions // could be empty and inlined away for FPC. FPC I/O should be // forward/backward slash safe. BEGIN (*$IFDEF Unix *) Result := Filename; (*$ELSE *) Result := StringReplace (Filename, '\', '/', [rfReplaceAll]); (*$ENDIF *) END; FUNCTION FileTimeGMT (FileName: STRING): TDateTime; // Returns the Date and Time of the last modification of the given File // The Result is zero if the file could not be found // The Result is given in UTC (GMT) time zone VAR SR : TSearchRec; BEGIN Result := 0.0; IF FindFirst (FileName, faAnyFile, SR) = 0 THEN Result := FileTimeGMT (SR); FindClose (SR); END; FUNCTION FileTimeGMT (SearchRec : TSearchRec) : TDateTime; (*$IFDEF MSWINDOWS *) VAR SystemFileTime: TSystemTime; (*$ENDIF *) (*$IFDEF Unix *) VAR TimeVal : TTimeVal; TimeZone : TTimeZone; (*$ENDIF *) BEGIN Result := 0.0; (*$IFDEF MSWINDOWS *) (*$WARNINGS OFF *) IF (SearchRec.FindData.dwFileAttributes AND faDirectory) = 0 THEN IF FileTimeToSystemTime (SearchRec.FindData.ftLastWriteTime, SystemFileTime) THEN Result := EncodeDate (SystemFileTime.wYear, SystemFileTime.wMonth, SystemFileTime.wDay) + EncodeTime (SystemFileTime.wHour, SystemFileTime.wMinute, SystemFileTime.wSecond, SystemFileTime.wMilliseconds); (*$ENDIF *) (*$WARNINGS ON *) (*$IFDEF Unix *) IF SearchRec.Attr AND faDirectory = 0 THEN BEGIN Result := FileDateToDateTime (SearchRec.Time); {$IFDEF Kylix} GetTimeOfDay (TimeVal, TimeZone); {$ELSE} fpGetTimeOfDay (@TimeVal, @TimeZone); {$ENDIF} Result := Result + TimeZone.tz_minuteswest / (60 * 24); END; (*$ENDIF *) end; PROCEDURE ClearDirRec (VAR DirRec : TTarDirRec); // This is included because a FillChar (DirRec, SizeOf (DirRec), 0) // will destroy the long string pointers, leading to strange bugs BEGIN WITH DirRec DO BEGIN Name := ''; Size := 0; DateTime := 0.0; Permissions := []; FileType := TFileType (0); LinkName := ''; UID := 0; GID := 0; UserName := ''; GroupName := ''; ChecksumOK := FALSE; Mode := []; Magic := ''; MajorDevNo := 0; MinorDevNo := 0; FilePos := 0; END; END; (* =============================================================================================== TAR format =============================================================================================== *) CONST RECORDSIZE = 512; NAMSIZ = 100; TUNMLEN = 32; TGNMLEN = 32; CHKBLANKS = #32#32#32#32#32#32#32#32; TYPE TTarHeader = PACKED RECORD Name : ARRAY [0..NAMSIZ-1] OF CHAR; Mode : ARRAY [0..7] OF CHAR; UID : ARRAY [0..7] OF CHAR; GID : ARRAY [0..7] OF CHAR; Size : ARRAY [0..11] OF CHAR; MTime : ARRAY [0..11] OF CHAR; ChkSum : ARRAY [0..7] OF CHAR; LinkFlag : CHAR; LinkName : ARRAY [0..NAMSIZ-1] OF CHAR; Magic : ARRAY [0..7] OF CHAR; UName : ARRAY [0..TUNMLEN-1] OF CHAR; GName : ARRAY [0..TGNMLEN-1] OF CHAR; DevMajor : ARRAY [0..7] OF CHAR; DevMinor : ARRAY [0..7] OF CHAR; END; FUNCTION ExtractText (P : PChar) : STRING; BEGIN Result := STRING (P); END; FUNCTION ExtractNumber (P : PChar) : INTEGER; OVERLOAD; VAR Strg : STRING; BEGIN Strg := Trim (StrPas (P)); P := PChar (Strg); Result := 0; WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3); INC (P); END; END; FUNCTION ExtractNumber64 (P : PChar) : INT64; OVERLOAD; VAR Strg : STRING; BEGIN Strg := Trim (StrPas (P)); P := PChar (Strg); Result := 0; WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3); INC (P); END; END; FUNCTION ExtractNumber (P : PChar; MaxLen : INTEGER) : INTEGER; OVERLOAD; VAR S0 : ARRAY [0..255] OF CHAR; Strg : STRING; BEGIN StrLCopy (S0, P, MaxLen); Strg := Trim (StrPas (S0)); P := PChar (Strg); Result := 0; WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3); INC (P); END; END; FUNCTION ExtractNumber64 (P : PChar; MaxLen : INTEGER) : INT64; OVERLOAD; VAR S0 : ARRAY [0..255] OF CHAR; Strg : STRING; BEGIN StrLCopy (S0, P, MaxLen); Strg := Trim (StrPas (S0)); P := PChar (Strg); Result := 0; WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3); INC (P); END; END; FUNCTION Records (Bytes : INT64) : INT64; BEGIN Result := Bytes DIV RECORDSIZE; IF Bytes MOD RECORDSIZE > 0 THEN INC (Result); END; PROCEDURE Octal (N : INTEGER; P : PChar; Len : INTEGER); // Makes a string of octal digits // The string will always be "Len" characters long VAR I : INTEGER; BEGIN FOR I := Len-2 DOWNTO 0 DO BEGIN (P+I)^ := CHR (ORD ('0') + ORD (N AND $07)); N := N SHR 3; END; FOR I := 0 TO Len-3 DO IF (P+I)^ = '0' THEN (P+I)^ := #32 ELSE BREAK; (P+Len-1)^ := #32; END; PROCEDURE Octal64 (N : INT64; P : PChar; Len : INTEGER); // Makes a string of octal digits // The string will always be "Len" characters long VAR I : INTEGER; BEGIN FOR I := Len-2 DOWNTO 0 DO BEGIN (P+I)^ := CHR (ORD ('0') + ORD (N AND $07)); N := N SHR 3; END; FOR I := 0 TO Len-3 DO IF (P+I)^ = '0' THEN (P+I)^ := #32 ELSE BREAK; (P+Len-1)^ := #32; END; PROCEDURE OctalN (N : INTEGER; P : PChar; Len : INTEGER); BEGIN Octal (N, P, Len-1); (P+Len-1)^ := #0; END; PROCEDURE WriteTarHeader (Dest : TStream; DirRec : TTarDirRec); VAR Rec : ARRAY [0..RECORDSIZE-1] OF CHAR; TH : TTarHeader ABSOLUTE Rec; Mode : INTEGER; NullDate : TDateTime; Checksum : CARDINAL; I : INTEGER; BEGIN FillChar (Rec, RECORDSIZE, 0); StrLCopy (TH.Name, PChar (DirRec.Name), NAMSIZ); Mode := 0; IF tmSaveText IN DirRec.Mode THEN Mode := Mode OR $0200; IF tmSetGid IN DirRec.Mode THEN Mode := Mode OR $0400; IF tmSetUid IN DirRec.Mode THEN Mode := Mode OR $0800; IF tpReadByOwner IN DirRec.Permissions THEN Mode := Mode OR $0100; IF tpWriteByOwner IN DirRec.Permissions THEN Mode := Mode OR $0080; IF tpExecuteByOwner IN DirRec.Permissions THEN Mode := Mode OR $0040; IF tpReadByGroup IN DirRec.Permissions THEN Mode := Mode OR $0020; IF tpWriteByGroup IN DirRec.Permissions THEN Mode := Mode OR $0010; IF tpExecuteByGroup IN DirRec.Permissions THEN Mode := Mode OR $0008; IF tpReadByOther IN DirRec.Permissions THEN Mode := Mode OR $0004; IF tpWriteByOther IN DirRec.Permissions THEN Mode := Mode OR $0002; IF tpExecuteByOther IN DirRec.Permissions THEN Mode := Mode OR $0001; OctalN (Mode, @TH.Mode, 8); OctalN (DirRec.UID, @TH.UID, 8); OctalN (DirRec.GID, @TH.GID, 8); Octal64 (DirRec.Size, @TH.Size, 12); NullDate := EncodeDate (1970, 1, 1); IF DirRec.DateTime >= NullDate THEN Octal (Trunc ((DirRec.DateTime - NullDate) * 86400.0), @TH.MTime, 12) ELSE Octal (Trunc ( NullDate * 86400.0), @TH.MTime, 12); CASE DirRec.FileType OF ftNormal : TH.LinkFlag := '0'; ftLink : TH.LinkFlag := '1'; ftSymbolicLink : TH.LinkFlag := '2'; ftCharacter : TH.LinkFlag := '3'; ftBlock : TH.LinkFlag := '4'; ftDirectory : TH.LinkFlag := '5'; ftFifo : TH.LinkFlag := '6'; ftContiguous : TH.LinkFlag := '7'; ftDumpDir : TH.LinkFlag := 'D'; ftMultiVolume : TH.LinkFlag := 'M'; ftVolumeHeader : TH.LinkFlag := 'V'; END; StrLCopy (TH.LinkName, PChar (DirRec.LinkName), NAMSIZ); StrLCopy (TH.Magic, PChar (DirRec.Magic + #32#32#32#32#32#32#32#32), 8); StrLCopy (TH.UName, PChar (DirRec.UserName), TUNMLEN); StrLCopy (TH.GName, PChar (DirRec.GroupName), TGNMLEN); OctalN (DirRec.MajorDevNo, @TH.DevMajor, 8); OctalN (DirRec.MinorDevNo, @TH.DevMinor, 8); StrMove (TH.ChkSum, CHKBLANKS, 8); CheckSum := 0; FOR I := 0 TO SizeOf (TTarHeader)-1 DO INC (CheckSum, INTEGER (ORD (Rec [I]))); OctalN (CheckSum, @TH.ChkSum, 8); Dest.Write (TH, RECORDSIZE); END; (* =============================================================================================== TTarArchive =============================================================================================== *) CONSTRUCTOR TTarArchive.Create (Stream : TStream); BEGIN INHERITED Create; FStream := Stream; FOwnsStream := FALSE; Reset; END; CONSTRUCTOR TTarArchive.Create (Filename : STRING; FileMode : WORD); BEGIN INHERITED Create; FStream := TFileStream.Create (Filename, FileMode); FOwnsStream := TRUE; Reset; END; DESTRUCTOR TTarArchive.Destroy; BEGIN IF FOwnsStream THEN FStream.Free; INHERITED Destroy; END; PROCEDURE TTarArchive.Reset; // Reset File Pointer BEGIN FStream.Position := 0; FBytesToGo := 0; END; FUNCTION TTarArchive.FindNext (VAR DirRec : TTarDirRec) : BOOLEAN; // Reads next Directory Info Record // The Stream pointer must point to the first byte of the tar header VAR Rec : ARRAY [0..RECORDSIZE-1] OF CHAR; CurFilePos : INTEGER; Header : TTarHeader ABSOLUTE Rec; I : INTEGER; HeaderChkSum : WORD; Checksum : CARDINAL; BEGIN // --- Scan until next pointer IF FBytesToGo > 0 THEN FStream.Seek (Records (FBytesToGo) * RECORDSIZE, soFromCurrent); // --- EOF reached? Result := FALSE; CurFilePos := FStream.Position; TRY FStream.ReadBuffer (Rec, RECORDSIZE); if Rec [0] = #0 THEN EXIT; // EOF reached EXCEPT EXIT; // EOF reached, too END; Result := TRUE; ClearDirRec (DirRec); DirRec.FilePos := CurFilePos; DirRec.Name := ExtractText (Header.Name); DirRec.Size := ExtractNumber64 (@Header.Size, 12); DirRec.DateTime := EncodeDate (1970, 1, 1) + (ExtractNumber (@Header.MTime, 12) / 86400.0); I := ExtractNumber (@Header.Mode); IF I AND $0100 <> 0 THEN Include (DirRec.Permissions, tpReadByOwner); IF I AND $0080 <> 0 THEN Include (DirRec.Permissions, tpWriteByOwner); IF I AND $0040 <> 0 THEN Include (DirRec.Permissions, tpExecuteByOwner); IF I AND $0020 <> 0 THEN Include (DirRec.Permissions, tpReadByGroup); IF I AND $0010 <> 0 THEN Include (DirRec.Permissions, tpWriteByGroup); IF I AND $0008 <> 0 THEN Include (DirRec.Permissions, tpExecuteByGroup); IF I AND $0004 <> 0 THEN Include (DirRec.Permissions, tpReadByOther); IF I AND $0002 <> 0 THEN Include (DirRec.Permissions, tpWriteByOther); IF I AND $0001 <> 0 THEN Include (DirRec.Permissions, tpExecuteByOther); IF I AND $0200 <> 0 THEN Include (DirRec.Mode, tmSaveText); IF I AND $0400 <> 0 THEN Include (DirRec.Mode, tmSetGid); IF I AND $0800 <> 0 THEN Include (DirRec.Mode, tmSetUid); CASE Header.LinkFlag OF #0, '0' : DirRec.FileType := ftNormal; '1' : DirRec.FileType := ftLink; '2' : DirRec.FileType := ftSymbolicLink; '3' : DirRec.FileType := ftCharacter; '4' : DirRec.FileType := ftBlock; '5' : DirRec.FileType := ftDirectory; '6' : DirRec.FileType := ftFifo; '7' : DirRec.FileType := ftContiguous; 'D' : DirRec.FileType := ftDumpDir; 'M' : DirRec.FileType := ftMultiVolume; 'V' : DirRec.FileType := ftVolumeHeader; END; DirRec.LinkName := ExtractText (Header.LinkName); DirRec.UID := ExtractNumber (@Header.UID); DirRec.GID := ExtractNumber (@Header.GID); DirRec.UserName := ExtractText (Header.UName); DirRec.GroupName := ExtractText (Header.GName); DirRec.Magic := Trim (ExtractText (Header.Magic)); DirRec.MajorDevNo := ExtractNumber (@Header.DevMajor); DirRec.MinorDevNo := ExtractNumber (@Header.DevMinor); HeaderChkSum := ExtractNumber (@Header.ChkSum); // Calc Checksum CheckSum := 0; StrMove (Header.ChkSum, CHKBLANKS, 8); FOR I := 0 TO SizeOf (TTarHeader)-1 DO INC (CheckSum, INTEGER (ORD (Rec [I]))); DirRec.CheckSumOK := WORD (CheckSum) = WORD (HeaderChkSum); IF DirRec.FileType in [ftLink, ftSymbolicLink, ftDirectory, ftFifo, ftVolumeHeader] THEN FBytesToGo := 0 ELSE FBytesToGo := DirRec.Size; END; PROCEDURE TTarArchive.ReadFile (Buffer : POINTER); // Reads file data for the last Directory Record. The entire file is read into the buffer. // The buffer must be large enough to take up the whole file. VAR RestBytes : INTEGER; BEGIN IF FBytesToGo = 0 THEN EXIT; RestBytes := Records (FBytesToGo) * RECORDSIZE - FBytesToGo; FStream.ReadBuffer (Buffer^, FBytesToGo); FStream.Seek (RestBytes, soFromCurrent); FBytesToGo := 0; END; PROCEDURE TTarArchive.ReadFile (Stream : TStream); // Reads file data for the last Directory Record. // The entire file is written out to the stream. // The stream is left at its current position prior to writing VAR RestBytes : INTEGER; BEGIN IF FBytesToGo = 0 THEN EXIT; RestBytes := Records (FBytesToGo) * RECORDSIZE - FBytesToGo; Stream.CopyFrom (FStream, FBytesToGo); FStream.Seek (RestBytes, soFromCurrent); FBytesToGo := 0; END; PROCEDURE TTarArchive.ReadFile (Filename : STRING); // Reads file data for the last Directory Record. // The entire file is saved in the given Filename VAR FS : TFileStream; BEGIN FS := TFileStream.Create (Filename, fmCreate); TRY ReadFile (FS); FINALLY FS.Free; END; END; FUNCTION TTarArchive.ReadFile : STRING; // Reads file data for the last Directory Record. The entire file is returned // as a large ANSI string. VAR RestBytes : INTEGER; BEGIN IF FBytesToGo = 0 THEN EXIT; RestBytes := Records (FBytesToGo) * RECORDSIZE - FBytesToGo; SetLength (Result, FBytesToGo); FStream.ReadBuffer (PChar (Result)^, FBytesToGo); FStream.Seek (RestBytes, soFromCurrent); FBytesToGo := 0; END; PROCEDURE TTarArchive.GetFilePos (VAR Current, Size : INT64); // Returns the Current Position in the TAR stream BEGIN Current := FStream.Position; Size := FStream.Size; END; PROCEDURE TTarArchive.SetFilePos (NewPos : INT64); // Set new Current File Position BEGIN IF NewPos < FStream.Size THEN FStream.Seek (NewPos, soFromBeginning); END; (* =============================================================================================== TTarWriter =============================================================================================== *) CONSTRUCTOR TTarWriter.CreateEmpty; VAR TP : TTarPermission; BEGIN INHERITED Create; FOwnsStream := FALSE; FFinalized := FALSE; FPermissions := []; FOR TP := Low (TP) TO High (TP) DO Include (FPermissions, TP); FUID := 0; FGID := 0; FUserName := ''; FGroupName := ''; FMode := []; FMagic := 'ustar'; END; CONSTRUCTOR TTarWriter.Create (TargetStream : TStream); BEGIN CreateEmpty; FStream := TargetStream; FOwnsStream := FALSE; END; CONSTRUCTOR TTarWriter.Create (TargetFilename : STRING; Mode : INTEGER = fmCreate); BEGIN CreateEmpty; FStream := TFileStream.Create (TargetFilename, Mode); FOwnsStream := TRUE; END; DESTRUCTOR TTarWriter.Destroy; BEGIN IF NOT FFinalized THEN BEGIN Finalize; FFinalized := TRUE; END; IF FOwnsStream THEN FStream.Free; INHERITED Destroy; END; FUNCTION TTarWriter.AddFile (Filename : STRING; TarFilename : STRING = '') : BOOLEAN; VAR S : TFileStream; Date : TDateTime; BEGIN AddFile:=false; Date := FileTimeGMT (Filename); IF TarFilename = '' THEN TarFilename := ConvertFilename (Filename); TRY S := TFileStream.Create (Filename, fmOpenRead OR fmShareDenyWrite); EXCEPT ON EFOpenError DO BEGIN Writeln(stderr,'LibTar error: unable to open file "',Filename,'" for reading.'); exit; END; END; TRY AddStream (S, TarFilename, Date); // No error, AddFile succeeded AddFile:=true; FINALLY S.Free END; END; PROCEDURE TTarWriter.AddStream (Stream : TStream; TarFilename : STRING; FileDateGmt : TDateTime); VAR DirRec : TTarDirRec; Rec : ARRAY [0..RECORDSIZE-1] OF CHAR; BytesToRead : INT64; // Bytes to read from the Source Stream BlockSize : INT64; // Bytes to write out for the current record BEGIN ClearDirRec (DirRec); DirRec.Name := TarFilename; DirRec.Size := Stream.Size - Stream.Position; DirRec.DateTime := FileDateGmt; DirRec.Permissions := FPermissions; DirRec.FileType := ftNormal; DirRec.LinkName := ''; DirRec.UID := FUID; DirRec.GID := FGID; DirRec.UserName := FUserName; DirRec.GroupName := FGroupName; DirRec.ChecksumOK := TRUE; DirRec.Mode := FMode; DirRec.Magic := FMagic; DirRec.MajorDevNo := 0; DirRec.MinorDevNo := 0; WriteTarHeader (FStream, DirRec); BytesToRead := DirRec.Size; WHILE BytesToRead > 0 DO BEGIN BlockSize := BytesToRead; IF BlockSize > RECORDSIZE THEN BlockSize := RECORDSIZE; FillChar (Rec, RECORDSIZE, 0); Stream.Read (Rec, BlockSize); FStream.Write (Rec, RECORDSIZE); DEC (BytesToRead, BlockSize); END; END; PROCEDURE TTarWriter.AddString (Contents : STRING; TarFilename : STRING; FileDateGmt : TDateTime); VAR S : TStringStream; BEGIN S := TStringStream.Create (Contents); TRY AddStream (S, TarFilename, FileDateGmt); FINALLY S.Free END END; PROCEDURE TTarWriter.AddDir (Dirname : STRING; DateGmt : TDateTime; MaxDirSize : INT64 = 0); VAR DirRec : TTarDirRec; BEGIN ClearDirRec (DirRec); DirRec.Name := Dirname; DirRec.Size := MaxDirSize; DirRec.DateTime := DateGmt; DirRec.Permissions := FPermissions; DirRec.FileType := ftDirectory; DirRec.LinkName := ''; DirRec.UID := FUID; DirRec.GID := FGID; DirRec.UserName := FUserName; DirRec.GroupName := FGroupName; DirRec.ChecksumOK := TRUE; DirRec.Mode := FMode; DirRec.Magic := FMagic; DirRec.MajorDevNo := 0; DirRec.MinorDevNo := 0; WriteTarHeader (FStream, DirRec); END; PROCEDURE TTarWriter.AddSymbolicLink (Filename, Linkname : STRING; DateGmt : TDateTime); VAR DirRec : TTarDirRec; BEGIN ClearDirRec (DirRec); DirRec.Name := Filename; DirRec.Size := 0; DirRec.DateTime := DateGmt; DirRec.Permissions := FPermissions; DirRec.FileType := ftSymbolicLink; DirRec.LinkName := Linkname; DirRec.UID := FUID; DirRec.GID := FGID; DirRec.UserName := FUserName; DirRec.GroupName := FGroupName; DirRec.ChecksumOK := TRUE; DirRec.Mode := FMode; DirRec.Magic := FMagic; DirRec.MajorDevNo := 0; DirRec.MinorDevNo := 0; WriteTarHeader (FStream, DirRec); END; PROCEDURE TTarWriter.AddLink (Filename, Linkname : STRING; DateGmt : TDateTime); VAR DirRec : TTarDirRec; BEGIN ClearDirRec (DirRec); DirRec.Name := Filename; DirRec.Size := 0; DirRec.DateTime := DateGmt; DirRec.Permissions := FPermissions; DirRec.FileType := ftLink; DirRec.LinkName := Linkname; DirRec.UID := FUID; DirRec.GID := FGID; DirRec.UserName := FUserName; DirRec.GroupName := FGroupName; DirRec.ChecksumOK := TRUE; DirRec.Mode := FMode; DirRec.Magic := FMagic; DirRec.MajorDevNo := 0; DirRec.MinorDevNo := 0; WriteTarHeader (FStream, DirRec); END; PROCEDURE TTarWriter.AddVolumeHeader (VolumeId : STRING; DateGmt : TDateTime); VAR DirRec : TTarDirRec; BEGIN ClearDirRec (DirRec); DirRec.Name := VolumeId; DirRec.Size := 0; DirRec.DateTime := DateGmt; DirRec.Permissions := FPermissions; DirRec.FileType := ftVolumeHeader; DirRec.LinkName := ''; DirRec.UID := FUID; DirRec.GID := FGID; DirRec.UserName := FUserName; DirRec.GroupName := FGroupName; DirRec.ChecksumOK := TRUE; DirRec.Mode := FMode; DirRec.Magic := FMagic; DirRec.MajorDevNo := 0; DirRec.MinorDevNo := 0; WriteTarHeader (FStream, DirRec); END; PROCEDURE TTarWriter.Finalize; // Writes the End-Of-File Tag // Data after this tag will be ignored // The destructor calls this automatically if you didn't do it before VAR Rec : ARRAY [0..RECORDSIZE-1] OF CHAR; BEGIN FillChar (Rec, SizeOf (Rec), 0); FStream.Write (Rec, RECORDSIZE); FFinalized := TRUE; END; END.