Advertisement
Guest User

LibTAR

a guest
Jun 2nd, 2013
96
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. (**
  2. ===============================================================================================
  3. Name    : LibTar
  4. ===============================================================================================
  5. Subject : Handling of "tar" files
  6. ===============================================================================================
  7. Author  : Stefan Heymann
  8.           Eschenweg 3
  9.           72076 Tьbingen
  10.           GERMANY
  11.  
  12. E-Mail:   stefan@destructor.de
  13. Web:      www.destructor.de
  14.  
  15. ===============================================================================================
  16. TTarArchive Usage
  17. -----------------
  18. - Choose a constructor
  19. - Make an instance of TTarArchive                  TA := TTarArchive.Create (Filename);
  20. - Scan through the archive                         TA.Reset;
  21.                                                    WHILE TA.FindNext (DirRec) DO BEGIN
  22. - Evaluate the DirRec for each file                  ListBox.Items.Add (DirRec.Name);
  23. - Read out the current file                          TA.ReadFile (DestFilename);
  24.   (You can ommit this if you want to
  25.   read in the directory only)                        END;      
  26. - You're done                                      TA.Free;
  27.  
  28.  
  29. TTarWriter Usage
  30. ----------------
  31. - Choose a constructor
  32. - Make an instance of TTarWriter                   TW := TTarWriter.Create ('my.tar');
  33. - Add a file to the tar archive                    TW.AddFile ('foobar.txt');
  34. - Add a string as a file                           TW.AddString (SL.Text, 'joe.txt', Now);
  35. - Destroy TarWriter instance                       TW.Free;
  36. - Now your tar file is ready.
  37.  
  38.  
  39. Source, Legals ("Licence")
  40. --------------------------
  41. The official site to get this code is http://www.destructor.de/
  42.  
  43. Usage and Distribution of this Source Code is ruled by the
  44. "Destructor.de Source code Licence" (DSL) which comes with this file or
  45. can be downloaded at http://www.destructor.de/
  46.  
  47. IN SHORT: Usage and distribution of this source code is free.
  48.           You use it completely on your own risk.
  49.  
  50. Donateware
  51. ----------
  52. If you like this code, you are free to donate
  53. http://www.destructor.de/donateware.htm
  54.  
  55. ===============================================================================================
  56. !!!  All parts of this code which are not finished or known to be buggy
  57.      are marked with three exclamation marks
  58. ===============================================================================================
  59. Date        Author Changes
  60. -----------------------------------------------------------------------------------------------
  61. 2001-04-26  HeySt  0.0.1 Start
  62. 2001-04-28  HeySt  1.0.0 First Release
  63. 2001-06-19  HeySt  2.0.0 Finished TTarWriter
  64. 2001-09-06  HeySt  2.0.1 Bugfix in TTarArchive.FindNext: FBytesToGo must sometimes be 0
  65. 2001-10-25  HeySt  2.0.2 Introduced the ClearDirRec procedure
  66. 2001-11-13  HeySt  2.0.3 Bugfix: Take out ClearDirRec call from WriteTarHeader
  67.                          Bug Reported by Tony BenBrahim
  68. 2001-12-25  HeySt  2.0.4 WriteTarHeader: Fill Rec with zero bytes before filling it
  69. 2002-05-18  HeySt  2.0.5 Kylix awareness: Thanks to Kerry L. Davison for the canges
  70. 2005-09-03  HeySt  2.0.6 TTarArchive.FindNext: Don't access SourceStream.Size
  71.                          (for compressed streams, which don't know their .Size)
  72. 2006-03-13  HeySt  2.0.7 Bugfix in ReadFile (Buffer : POINTER)
  73. 2007-05-16  HeySt  2.0.8 Bugfix in TTarWriter.AddFile (Convertfilename in the ELSE branch)
  74.                          Bug Reported by Chris Rorden
  75. 2010-11-29  HeySt  2.1.0 WriteTarHeader: Mode values for ftNormal/ftLink/ftSymbolicLink/ftDirectory
  76.                          Thanks to Iouri Kharon for the fix.
  77.                          Still no support for filenames > 100 bytes. Sorry.
  78.                          Support for Unicode Delphi versions (2009, 2010, XE, etc.)
  79. 2011-05-23  HeySt  2.1.1 New IFDEF WIN32 in the USES clause
  80. *)
  81.  
  82. UNIT LibTar;
  83.  
  84. INTERFACE
  85.  
  86. USES
  87. (*$IFDEF LINUX*)
  88.    Libc,
  89. (*$ENDIF *)
  90. {$IFDEF WIN32}
  91.   {$DEFINE MSWINDOWS} // predefined for D6+/BCB6+    // because in Delphi 5  MSWINDOWS is not defined
  92. {$ENDIF}
  93. (*$IFDEF MSWINDOWS *)
  94.    Windows,
  95. (*$ENDIF *)
  96.   SysUtils, Classes;
  97.  
  98. TYPE
  99.   (*$IFNDEF UNICODE *)
  100.   RawByteString = AnsiString;
  101.   (*$ENDIF *)
  102.  
  103.   // --- File Access Permissions
  104.   TTarPermission  = (tpReadByOwner, tpWriteByOwner, tpExecuteByOwner,
  105.                      tpReadByGroup, tpWriteByGroup, tpExecuteByGroup,
  106.                      tpReadByOther, tpWriteByOther, tpExecuteByOther);
  107.   TTarPermissions = SET OF TTarPermission;
  108.  
  109.   // --- Type of File
  110.   TFileType = (ftNormal,          // Regular file
  111.                ftLink,            // Link to another, previously archived, file (LinkName)
  112.                ftSymbolicLink,    // Symbolic link to another file              (LinkName)
  113.                ftCharacter,       // Character special files
  114.                ftBlock,           // Block special files
  115.                ftDirectory,       // Directory entry. Size is zero (unlimited) or max. number of bytes
  116.                ftFifo,            // FIFO special file. No data stored in the archive.
  117.                ftContiguous,      // Contiguous file, if supported by OS
  118.                ftDumpDir,         // List of files
  119.                ftMultiVolume,     // Multi-volume file part
  120.                ftVolumeHeader);   // Volume header. Can appear only as first record in the archive
  121.  
  122.   // --- Mode
  123.   TTarMode  = (tmSetUid, tmSetGid, tmSaveText);
  124.   TTarModes = SET OF TTarMode;
  125.  
  126.   // --- Record for a Directory Entry
  127.   //     Adjust the ClearDirRec procedure when this record changes!
  128.   TTarDirRec  = RECORD
  129.                   Name        : AnsiString;        // File path and name
  130.                   Size        : INT64;             // File size in Bytes
  131.                   DateTime    : TDateTime;         // Last modification date and time
  132.                   Permissions : TTarPermissions;   // Access permissions
  133.                   FileType    : TFileType;         // Type of file
  134.                   LinkName    : AnsiString;        // Name of linked file (for ftLink, ftSymbolicLink)
  135.                   UID         : INTEGER;           // User ID
  136.                   GID         : INTEGER;           // Group ID
  137.                   UserName    : AnsiString;        // User name
  138.                   GroupName   : AnsiString;        // Group name
  139.                   ChecksumOK  : BOOLEAN;           // Checksum was OK
  140.                   Mode        : TTarModes;         // Mode
  141.                   Magic       : AnsiString;        // Contents of the "Magic" field
  142.                   MajorDevNo  : INTEGER;           // Major Device No. for ftCharacter and ftBlock
  143.                   MinorDevNo  : INTEGER;           // Minor Device No. for ftCharacter and ftBlock
  144.                   FilePos     : INT64;             // Position in TAR file
  145.                 END;
  146.  
  147.   // --- The TAR Archive CLASS
  148.   TTarArchive = CLASS
  149.                 PROTECTED
  150.                   FStream     : TStream;   // Internal Stream
  151.                   FOwnsStream : BOOLEAN;   // True if FStream is owned by the TTarArchive instance
  152.                   FBytesToGo  : INT64;     // Bytes until the next Header Record
  153.                 PUBLIC
  154.                   CONSTRUCTOR Create (Stream   : TStream);                                OVERLOAD;
  155.                   CONSTRUCTOR Create (Filename : STRING;
  156.                                       FileMode : WORD = fmOpenRead OR fmShareDenyWrite);  OVERLOAD;
  157.                   DESTRUCTOR Destroy;                                       OVERRIDE;
  158.                   PROCEDURE Reset;                                         // Reset File Pointer
  159.                   FUNCTION  FindNext (VAR DirRec : TTarDirRec) : BOOLEAN;  // Reads next Directory Info Record. FALSE if EOF reached
  160.                   PROCEDURE ReadFile (Buffer   : POINTER); OVERLOAD;       // Reads file data for last Directory Record
  161.                   PROCEDURE ReadFile (Stream   : TStream); OVERLOAD;       // -;-
  162.                   PROCEDURE ReadFile (Filename : STRING);  OVERLOAD;       // -;-
  163.                   FUNCTION  ReadFile : RawByteString;      OVERLOAD;       // -;-
  164.  
  165.                   PROCEDURE GetFilePos (VAR Current, Size : INT64);        // Current File Position
  166.                   PROCEDURE SetFilePos (NewPos : INT64);                   // Set new Current File Position
  167.                 END;
  168.  
  169.   // --- The TAR Archive Writer CLASS
  170.   TTarWriter = CLASS
  171.                PROTECTED
  172.                  FStream      : TStream;
  173.                  FOwnsStream  : BOOLEAN;
  174.                  FFinalized   : BOOLEAN;
  175.                                                    // --- Used at the next "Add" method call: ---
  176.                  FPermissions : TTarPermissions;   // Access permissions
  177.                  FUID         : INTEGER;           // User ID
  178.                  FGID         : INTEGER;           // Group ID
  179.                  FUserName    : AnsiString;        // User name
  180.                  FGroupName   : AnsiString;        // Group name
  181.                  FMode        : TTarModes;         // Mode
  182.                  FMagic       : AnsiString;        // Contents of the "Magic" field
  183.                  CONSTRUCTOR CreateEmpty;
  184.                PUBLIC
  185.                  CONSTRUCTOR Create (TargetStream   : TStream);                            OVERLOAD;
  186.                  CONSTRUCTOR Create (TargetFilename : STRING; Mode : INTEGER = fmCreate);  OVERLOAD;
  187.                  DESTRUCTOR Destroy; OVERRIDE;                   // Writes End-Of-File Tag
  188.                  PROCEDURE AddFile   (Filename : STRING;        TarFilename : AnsiString = '');
  189.                  PROCEDURE AddStream (Stream   : TStream;       TarFilename : AnsiString; FileDateGmt : TDateTime);
  190.                  PROCEDURE AddString (Contents : RawByteString; TarFilename : AnsiString; FileDateGmt : TDateTime);
  191.                  PROCEDURE AddDir          (Dirname            : AnsiString; DateGmt : TDateTime; MaxDirSize : INT64 = 0);
  192.                  PROCEDURE AddSymbolicLink (Filename, Linkname : AnsiString; DateGmt : TDateTime);
  193.                  PROCEDURE AddLink         (Filename, Linkname : AnsiString; DateGmt : TDateTime);
  194.                  PROCEDURE AddVolumeHeader (VolumeId           : AnsiString; DateGmt : TDateTime);
  195.                  PROCEDURE Finalize;
  196.                  PROPERTY Permissions : TTarPermissions READ FPermissions WRITE FPermissions;   // Access permissions
  197.                  PROPERTY UID         : INTEGER         READ FUID         WRITE FUID;           // User ID
  198.                  PROPERTY GID         : INTEGER         READ FGID         WRITE FGID;           // Group ID
  199.                  PROPERTY UserName    : AnsiString      READ FUserName    WRITE FUserName;      // User name
  200.                  PROPERTY GroupName   : AnsiString      READ FGroupName   WRITE FGroupName;     // Group name
  201.                  PROPERTY Mode        : TTarModes       READ FMode        WRITE FMode;          // Mode
  202.                  PROPERTY Magic       : AnsiString      READ FMagic       WRITE FMagic;         // Contents of the "Magic" field
  203.                END;
  204.  
  205. // --- Some useful constants
  206. CONST
  207.   FILETYPE_NAME : ARRAY [TFileType] OF STRING =
  208.                   ('Regular', 'Link', 'Symbolic Link', 'Char File', 'Block File',
  209.                    'Directory', 'FIFO File', 'Contiguous', 'Dir Dump', 'Multivol', 'Volume Header');
  210.  
  211.   ALL_PERMISSIONS     = [tpReadByOwner, tpWriteByOwner, tpExecuteByOwner,
  212.                          tpReadByGroup, tpWriteByGroup, tpExecuteByGroup,
  213.                          tpReadByOther, tpWriteByOther, tpExecuteByOther];
  214.   READ_PERMISSIONS    = [tpReadByOwner, tpReadByGroup,  tpReadByOther];
  215.   WRITE_PERMISSIONS   = [tpWriteByOwner, tpWriteByGroup, tpWriteByOther];
  216.   EXECUTE_PERMISSIONS = [tpExecuteByOwner, tpExecuteByGroup, tpExecuteByOther];
  217.  
  218.  
  219. FUNCTION  PermissionString      (Permissions : TTarPermissions) : STRING;
  220. FUNCTION  ConvertFilename       (Filename    : STRING)          : STRING;
  221. FUNCTION  FileTimeGMT           (FileName    : STRING)          : TDateTime;  OVERLOAD;
  222. FUNCTION  FileTimeGMT           (SearchRec   : TSearchRec)      : TDateTime;  OVERLOAD;
  223. PROCEDURE ClearDirRec           (VAR DirRec  : TTarDirRec);
  224.  
  225.  
  226. (*
  227. ===============================================================================================
  228. IMPLEMENTATION
  229. ===============================================================================================
  230. *)
  231.  
  232. IMPLEMENTATION
  233.  
  234. FUNCTION PermissionString (Permissions : TTarPermissions) : STRING;
  235. BEGIN
  236.   Result := '';
  237.   IF tpReadByOwner    IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-';
  238.   IF tpWriteByOwner   IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-';
  239.   IF tpExecuteByOwner IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-';
  240.   IF tpReadByGroup    IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-';
  241.   IF tpWriteByGroup   IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-';
  242.   IF tpExecuteByGroup IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-';
  243.   IF tpReadByOther    IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-';
  244.   IF tpWriteByOther   IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-';
  245.   IF tpExecuteByOther IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-';
  246. END;
  247.  
  248.  
  249. FUNCTION ConvertFilename  (Filename : STRING) : STRING;
  250.          // Converts the filename to Unix conventions
  251. BEGIN
  252.   (*$IFDEF LINUX *)
  253.   Result := Filename;
  254.   (*$ELSE *)
  255.   Result := StringReplace (Filename, '\', '/', [rfReplaceAll]);
  256.   (*$ENDIF *)
  257. END;
  258.  
  259.  
  260. FUNCTION FileTimeGMT (FileName: STRING): TDateTime;
  261.          // Returns the Date and Time of the last modification of the given File
  262.          // The Result is zero if the file could not be found
  263.          // The Result is given in UTC (GMT) time zone
  264. VAR
  265.   SR : TSearchRec;
  266. BEGIN
  267.   Result := 0.0;
  268.   IF FindFirst (FileName, faAnyFile, SR) = 0 THEN
  269.     Result := FileTimeGMT (SR);
  270.   FindClose (SR);
  271. END;
  272.  
  273.  
  274. FUNCTION FileTimeGMT (SearchRec : TSearchRec) : TDateTime;
  275. (*$IFDEF MSWINDOWS *)
  276. VAR
  277.   SystemFileTime: TSystemTime;
  278. (*$ENDIF *)
  279. (*$IFDEF LINUX *)
  280. VAR
  281.   TimeVal  : TTimeVal;
  282.   TimeZone : TTimeZone;
  283. (*$ENDIF *)
  284. BEGIN
  285.   Result := 0.0;
  286.   (*$IFDEF MSWINDOWS *) (*$WARNINGS OFF *)
  287.     IF (SearchRec.FindData.dwFileAttributes AND faDirectory) = 0 THEN
  288.       IF FileTimeToSystemTime (SearchRec.FindData.ftLastWriteTime, SystemFileTime) THEN
  289.         Result := EncodeDate (SystemFileTime.wYear, SystemFileTime.wMonth, SystemFileTime.wDay)
  290.                 + EncodeTime (SystemFileTime.wHour, SystemFileTime.wMinute, SystemFileTime.wSecond, SystemFileTime.wMilliseconds);
  291.   (*$ENDIF *) (*$WARNINGS ON *)
  292.   (*$IFDEF LINUX *)
  293.      IF SearchRec.Attr AND faDirectory = 0 THEN BEGIN
  294.        Result := FileDateToDateTime (SearchRec.Time);
  295.        GetTimeOfDay (TimeVal, TimeZone);
  296.        Result := Result + TimeZone.tz_minuteswest / (60 * 24);
  297.        END;
  298.   (*$ENDIF *)
  299. end;
  300.  
  301.  
  302. PROCEDURE ClearDirRec (VAR DirRec : TTarDirRec);
  303.           // This is included because a FillChar (DirRec, SizeOf (DirRec), 0)
  304.           // will destroy the long string pointers, leading to strange bugs
  305. BEGIN
  306.   WITH DirRec DO BEGIN
  307.     Name        := '';
  308.     Size        := 0;
  309.     DateTime    := 0.0;
  310.     Permissions := [];
  311.     FileType    := TFileType (0);
  312.     LinkName    := '';
  313.     UID         := 0;
  314.     GID         := 0;
  315.     UserName    := '';
  316.     GroupName   := '';
  317.     ChecksumOK  := FALSE;
  318.     Mode        := [];
  319.     Magic       := '';
  320.     MajorDevNo  := 0;
  321.     MinorDevNo  := 0;
  322.     FilePos     := 0;
  323.     END;
  324. END;
  325.  
  326. (*
  327. ===============================================================================================
  328. TAR format
  329. ===============================================================================================
  330. *)
  331.  
  332. CONST
  333.   RECORDSIZE = 512;
  334.   NAMSIZ     = 100;
  335.   TUNMLEN    =  32;
  336.   TGNMLEN    =  32;
  337.   CHKBLANKS  = #32#32#32#32#32#32#32#32;
  338.  
  339. TYPE
  340.   TTarHeader = PACKED RECORD
  341.                  Name     : ARRAY [0..NAMSIZ-1] OF AnsiChar;
  342.                  Mode     : ARRAY [0..7]  OF AnsiChar;
  343.                  UID      : ARRAY [0..7]  OF AnsiChar;
  344.                  GID      : ARRAY [0..7]  OF AnsiChar;
  345.                  Size     : ARRAY [0..11] OF AnsiChar;
  346.                  MTime    : ARRAY [0..11] OF AnsiChar;
  347.                  ChkSum   : ARRAY [0..7]  OF AnsiChar;
  348.                  LinkFlag : AnsiChar;
  349.                  LinkName : ARRAY [0..NAMSIZ-1] OF AnsiChar;
  350.                  Magic    : ARRAY [0..7] OF AnsiChar;
  351.                  UName    : ARRAY [0..TUNMLEN-1] OF AnsiChar;
  352.                  GName    : ARRAY [0..TGNMLEN-1] OF AnsiChar;
  353.                  DevMajor : ARRAY [0..7] OF AnsiChar;
  354.                  DevMinor : ARRAY [0..7] OF AnsiChar;
  355.                END;
  356.  
  357. FUNCTION ExtractText (P : PAnsiChar) : AnsiString;
  358. BEGIN
  359.   Result := AnsiString (P);
  360. END;
  361.  
  362.  
  363. FUNCTION ExtractNumber (P : PAnsiChar) : INTEGER; OVERLOAD;
  364. VAR
  365.   Strg : AnsiString;
  366. BEGIN
  367.   Strg := AnsiString (Trim (string (P)));
  368.   P := PAnsiChar (Strg);
  369.   Result := 0;
  370.   WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
  371.     Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
  372.     INC (P);
  373.     END;
  374. END;
  375.  
  376.  
  377. FUNCTION ExtractNumber64 (P : PAnsiChar) : INT64; OVERLOAD;
  378. VAR
  379.   Strg : AnsiString;
  380. BEGIN
  381.   Strg := AnsiString (Trim (string (P)));
  382.   P := PAnsiChar (Strg);
  383.   Result := 0;
  384.   WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
  385.     Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
  386.     INC (P);
  387.     END;
  388. END;
  389.  
  390.  
  391.  
  392. FUNCTION ExtractNumber (P : PAnsiChar; MaxLen : INTEGER) : INTEGER; OVERLOAD;
  393. VAR
  394.   S0   : ARRAY [0..255] OF AnsiChar;
  395.   Strg : AnsiString;
  396. BEGIN
  397.   StrLCopy (S0, P, MaxLen);
  398.   Strg := AnsiString (Trim (string (S0)));
  399.   P := PAnsiChar (Strg);
  400.   Result := 0;
  401.   WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
  402.     Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
  403.     INC (P);
  404.     END;
  405. END;
  406.  
  407.  
  408. FUNCTION ExtractNumber64 (P : PAnsiChar; MaxLen : INTEGER) : INT64; OVERLOAD;
  409. VAR
  410.   S0   : ARRAY [0..255] OF AnsiChar;
  411.   Strg : AnsiString;
  412. BEGIN
  413.   StrLCopy (S0, P, MaxLen);
  414.   Strg := AnsiString (Trim (string (S0)));
  415.   P := PAnsiChar (Strg);
  416.   Result := 0;
  417.   WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
  418.     Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
  419.     INC (P);
  420.     END;
  421. END;
  422.  
  423.  
  424. FUNCTION Records (Bytes : INT64) : INT64;
  425. BEGIN
  426.   Result := Bytes DIV RECORDSIZE;
  427.   IF Bytes MOD RECORDSIZE > 0 THEN
  428.     INC (Result);
  429. END;
  430.  
  431.  
  432. PROCEDURE Octal (N : INTEGER; P : PAnsiChar; Len : INTEGER);
  433.          // Makes a string of octal digits
  434.          // The string will always be "Len" characters long
  435. VAR
  436.   I : INTEGER;
  437. BEGIN
  438.   FOR I := Len-2 DOWNTO 0 DO BEGIN
  439.     (P+I)^ := AnsiChar (ORD ('0') + ORD (N AND $07));
  440.     N := N SHR 3;
  441.     END;
  442.   FOR I := 0 TO Len-3 DO
  443.     IF (P+I)^ = '0'
  444.       THEN (P+I)^ := #32
  445.       ELSE BREAK;
  446.   (P+Len-1)^ := #32;
  447. END;
  448.  
  449.  
  450. PROCEDURE Octal64 (N : INT64; P : PAnsiChar; Len : INTEGER);
  451.          // Makes a string of octal digits
  452.          // The string will always be "Len" characters long
  453. VAR
  454.   I     : INTEGER;
  455. BEGIN
  456.   FOR I := Len-2 DOWNTO 0 DO BEGIN
  457.     (P+I)^ := AnsiChar (ORD ('0') + ORD (N AND $07));
  458.     N := N SHR 3;
  459.     END;
  460.   FOR I := 0 TO Len-3 DO
  461.     IF (P+I)^ = '0'
  462.       THEN (P+I)^ := #32
  463.       ELSE BREAK;
  464.   (P+Len-1)^ := #32;
  465. END;
  466.  
  467.  
  468. PROCEDURE OctalN (N : INTEGER; P : PAnsiChar; Len : INTEGER);
  469. BEGIN
  470.   Octal (N, P, Len-1);
  471.   (P+Len-1)^ := #0;
  472. END;
  473.  
  474.  
  475. PROCEDURE WriteTarHeader (Dest : TStream; DirRec : TTarDirRec);
  476. VAR
  477.   Rec      : ARRAY [0..RECORDSIZE-1] OF AnsiChar;
  478.   TH       : TTarHeader ABSOLUTE Rec;
  479.   Mode     : INTEGER;
  480.   NullDate : TDateTime;
  481.   Checksum : CARDINAL;
  482.   I        : INTEGER;
  483. BEGIN
  484.   FillChar (Rec, RECORDSIZE, 0);
  485.   StrLCopy (TH.Name, PAnsiChar (DirRec.Name), NAMSIZ);
  486.   CASE DirRec.FileType OF
  487.     ftNormal, ftLink  : Mode := $08000;
  488.     ftSymbolicLink    : Mode := $0A000;
  489.     ftDirectory       : Mode := $04000;
  490.     ELSE                Mode := 0;
  491.     END;
  492.   IF tmSaveText IN DirRec.Mode THEN Mode := Mode OR $0200;
  493.   IF tmSetGid   IN DirRec.Mode THEN Mode := Mode OR $0400;
  494.   IF tmSetUid   IN DirRec.Mode THEN Mode := Mode OR $0800;
  495.   IF tpReadByOwner    IN DirRec.Permissions THEN Mode := Mode OR $0100;
  496.   IF tpWriteByOwner   IN DirRec.Permissions THEN Mode := Mode OR $0080;
  497.   IF tpExecuteByOwner IN DirRec.Permissions THEN Mode := Mode OR $0040;
  498.   IF tpReadByGroup    IN DirRec.Permissions THEN Mode := Mode OR $0020;
  499.   IF tpWriteByGroup   IN DirRec.Permissions THEN Mode := Mode OR $0010;
  500.   IF tpExecuteByGroup IN DirRec.Permissions THEN Mode := Mode OR $0008;
  501.   IF tpReadByOther    IN DirRec.Permissions THEN Mode := Mode OR $0004;
  502.   IF tpWriteByOther   IN DirRec.Permissions THEN Mode := Mode OR $0002;
  503.   IF tpExecuteByOther IN DirRec.Permissions THEN Mode := Mode OR $0001;
  504.   OctalN (Mode, @TH.Mode, 8);
  505.   OctalN (DirRec.UID, @TH.UID, 8);
  506.   OctalN (DirRec.GID, @TH.GID, 8);
  507.   Octal64 (DirRec.Size, @TH.Size, 12);
  508.   NullDate := EncodeDate (1970, 1, 1);
  509.   IF DirRec.DateTime >= NullDate
  510.     THEN Octal (Trunc ((DirRec.DateTime - NullDate) * 86400.0), @TH.MTime, 12)
  511.     ELSE Octal (Trunc (                   NullDate  * 86400.0), @TH.MTime, 12);
  512.   CASE DirRec.FileType OF
  513.     ftNormal       : TH.LinkFlag := '0';
  514.     ftLink         : TH.LinkFlag := '1';
  515.     ftSymbolicLink : TH.LinkFlag := '2';
  516.     ftCharacter    : TH.LinkFlag := '3';
  517.     ftBlock        : TH.LinkFlag := '4';
  518.     ftDirectory    : TH.LinkFlag := '5';
  519.     ftFifo         : TH.LinkFlag := '6';
  520.     ftContiguous   : TH.LinkFlag := '7';
  521.     ftDumpDir      : TH.LinkFlag := 'D';
  522.     ftMultiVolume  : TH.LinkFlag := 'M';
  523.     ftVolumeHeader : TH.LinkFlag := 'V';
  524.     END;
  525.   StrLCopy (TH.LinkName, PAnsiChar (DirRec.LinkName), NAMSIZ);
  526.   StrLCopy (TH.Magic, PAnsiChar (DirRec.Magic + #32#32#32#32#32#32#32#32), 8);
  527.   StrLCopy (TH.UName, PAnsiChar (DirRec.UserName), TUNMLEN);
  528.   StrLCopy (TH.GName, PAnsiChar (DirRec.GroupName), TGNMLEN);
  529.   OctalN (DirRec.MajorDevNo, @TH.DevMajor, 8);
  530.   OctalN (DirRec.MinorDevNo, @TH.DevMinor, 8);
  531.   StrMove (TH.ChkSum, CHKBLANKS, 8);
  532.  
  533.   CheckSum := 0;
  534.   FOR I := 0 TO SizeOf (TTarHeader)-1 DO
  535.     INC (CheckSum, INTEGER (ORD (Rec [I])));
  536.   OctalN (CheckSum, @TH.ChkSum, 8);
  537.  
  538.   Dest.Write (TH, RECORDSIZE);
  539. END;
  540.  
  541.  
  542.  
  543. (*
  544. ===============================================================================================
  545. TTarArchive
  546. ===============================================================================================
  547. *)
  548.  
  549. CONSTRUCTOR TTarArchive.Create (Stream : TStream);
  550. BEGIN
  551.   INHERITED Create;
  552.   FStream     := Stream;
  553.   FOwnsStream := FALSE;
  554.   Reset;
  555. END;
  556.  
  557.  
  558. CONSTRUCTOR TTarArchive.Create (Filename : STRING; FileMode : WORD);
  559. BEGIN
  560.   INHERITED Create;
  561.   FStream     := TFileStream.Create (Filename, FileMode);
  562.   FOwnsStream := TRUE;
  563.   Reset;
  564. END;
  565.  
  566.  
  567. DESTRUCTOR TTarArchive.Destroy;
  568. BEGIN
  569.   IF FOwnsStream THEN
  570.     FStream.Free;
  571.   INHERITED Destroy;
  572. END;
  573.  
  574.  
  575. PROCEDURE TTarArchive.Reset;
  576.           // Reset File Pointer
  577. BEGIN
  578.   FStream.Position := 0;
  579.   FBytesToGo       := 0;
  580. END;
  581.  
  582.  
  583. FUNCTION  TTarArchive.FindNext (VAR DirRec : TTarDirRec) : BOOLEAN;
  584.           // Reads next Directory Info Record
  585.           // The Stream pointer must point to the first byte of the tar header
  586. VAR
  587.   Rec          : ARRAY [0..RECORDSIZE-1] OF CHAR;
  588.   CurFilePos   : INTEGER;
  589.   Header       : TTarHeader ABSOLUTE Rec;
  590.   I            : INTEGER;
  591.   HeaderChkSum : WORD;
  592.   Checksum     : CARDINAL;
  593. BEGIN
  594.   // --- Scan until next pointer
  595.   IF FBytesToGo > 0 THEN
  596.     FStream.Seek (Records (FBytesToGo) * RECORDSIZE, soFromCurrent);
  597.  
  598.   // --- EOF reached?
  599.   Result := FALSE;
  600.   CurFilePos := FStream.Position;
  601.   TRY
  602.     FStream.ReadBuffer (Rec, RECORDSIZE);
  603.     if Rec [0] = #0 THEN EXIT;   // EOF reached
  604.   EXCEPT
  605.     EXIT;   // EOF reached, too
  606.     END;
  607.   Result := TRUE;
  608.  
  609.   ClearDirRec (DirRec);
  610.  
  611.   DirRec.FilePos := CurFilePos;
  612.   DirRec.Name := ExtractText (Header.Name);
  613.   DirRec.Size := ExtractNumber64 (@Header.Size, 12);
  614.   DirRec.DateTime := EncodeDate (1970, 1, 1) + (ExtractNumber (@Header.MTime, 12) / 86400.0);
  615.   I := ExtractNumber (@Header.Mode);
  616.   IF I AND $0100 <> 0 THEN Include (DirRec.Permissions, tpReadByOwner);
  617.   IF I AND $0080 <> 0 THEN Include (DirRec.Permissions, tpWriteByOwner);
  618.   IF I AND $0040 <> 0 THEN Include (DirRec.Permissions, tpExecuteByOwner);
  619.   IF I AND $0020 <> 0 THEN Include (DirRec.Permissions, tpReadByGroup);
  620.   IF I AND $0010 <> 0 THEN Include (DirRec.Permissions, tpWriteByGroup);
  621.   IF I AND $0008 <> 0 THEN Include (DirRec.Permissions, tpExecuteByGroup);
  622.   IF I AND $0004 <> 0 THEN Include (DirRec.Permissions, tpReadByOther);
  623.   IF I AND $0002 <> 0 THEN Include (DirRec.Permissions, tpWriteByOther);
  624.   IF I AND $0001 <> 0 THEN Include (DirRec.Permissions, tpExecuteByOther);
  625.   IF I AND $0200 <> 0 THEN Include (DirRec.Mode, tmSaveText);
  626.   IF I AND $0400 <> 0 THEN Include (DirRec.Mode, tmSetGid);
  627.   IF I AND $0800 <> 0 THEN Include (DirRec.Mode, tmSetUid);
  628.   CASE Header.LinkFlag OF
  629.     #0, '0' : DirRec.FileType := ftNormal;
  630.     '1'     : DirRec.FileType := ftLink;
  631.     '2'     : DirRec.FileType := ftSymbolicLink;
  632.     '3'     : DirRec.FileType := ftCharacter;
  633.     '4'     : DirRec.FileType := ftBlock;
  634.     '5'     : DirRec.FileType := ftDirectory;
  635.     '6'     : DirRec.FileType := ftFifo;
  636.     '7'     : DirRec.FileType := ftContiguous;
  637.     'D'     : DirRec.FileType := ftDumpDir;
  638.     'M'     : DirRec.FileType := ftMultiVolume;
  639.     'V'     : DirRec.FileType := ftVolumeHeader;
  640.     END;
  641.   DirRec.LinkName   := ExtractText (Header.LinkName);
  642.   DirRec.UID        := ExtractNumber (@Header.UID);
  643.   DirRec.GID        := ExtractNumber (@Header.GID);
  644.   DirRec.UserName   := ExtractText (Header.UName);
  645.   DirRec.GroupName  := ExtractText (Header.GName);
  646.   DirRec.Magic      := AnsiString (Trim (string (Header.Magic)));
  647.   DirRec.MajorDevNo := ExtractNumber (@Header.DevMajor);
  648.   DirRec.MinorDevNo := ExtractNumber (@Header.DevMinor);
  649.  
  650.   HeaderChkSum := ExtractNumber (@Header.ChkSum);   // Calc Checksum
  651.   CheckSum := 0;
  652.   StrMove (Header.ChkSum, CHKBLANKS, 8);
  653.   FOR I := 0 TO SizeOf (TTarHeader)-1 DO
  654.     INC (CheckSum, INTEGER (ORD (Rec [I])));
  655.   DirRec.CheckSumOK := WORD (CheckSum) = WORD (HeaderChkSum);
  656.  
  657.   IF DirRec.FileType in [ftLink, ftSymbolicLink, ftDirectory, ftFifo, ftVolumeHeader]
  658.     THEN FBytesToGo := 0
  659.     ELSE FBytesToGo := DirRec.Size;
  660. END;
  661.  
  662.  
  663. PROCEDURE TTarArchive.ReadFile (Buffer : POINTER);
  664.           // Reads file data for the last Directory Record. The entire file is read into the buffer.
  665.           // The buffer must be large enough to take up the whole file.
  666. VAR
  667.   RestBytes : INTEGER;
  668. BEGIN
  669.   IF FBytesToGo = 0 THEN EXIT;
  670.   RestBytes := Records (FBytesToGo) * RECORDSIZE - FBytesToGo;
  671.   FStream.ReadBuffer (Buffer^, FBytesToGo);
  672.   FStream.Seek (RestBytes, soFromCurrent);
  673.   FBytesToGo := 0;
  674. END;
  675.  
  676.  
  677. PROCEDURE TTarArchive.ReadFile (Stream : TStream);
  678.           // Reads file data for the last Directory Record.
  679.           // The entire file is written out to the stream.
  680.           // The stream is left at its current position prior to writing
  681. VAR
  682.   RestBytes : INTEGER;
  683. BEGIN
  684.   IF FBytesToGo = 0 THEN EXIT;
  685.   RestBytes := Records (FBytesToGo) * RECORDSIZE - FBytesToGo;
  686.   Stream.CopyFrom (FStream, FBytesToGo);
  687.   FStream.Seek (RestBytes, soFromCurrent);
  688.   FBytesToGo := 0;
  689. END;
  690.  
  691.  
  692. PROCEDURE TTarArchive.ReadFile (Filename : STRING);
  693.           // Reads file data for the last Directory Record.
  694.           // The entire file is saved in the given Filename
  695. VAR
  696.   FS : TFileStream;
  697. BEGIN
  698.   FS := TFileStream.Create (Filename, fmCreate);
  699.   TRY
  700.     ReadFile (FS);
  701.   FINALLY
  702.     FS.Free;
  703.     END;
  704. END;
  705.  
  706.  
  707. FUNCTION  TTarArchive.ReadFile : RawByteString;
  708.           // Reads file data for the last Directory Record. The entire file is returned
  709.           // as a large ANSI string.
  710. VAR
  711.   RestBytes : INTEGER;
  712. BEGIN
  713.   IF FBytesToGo = 0 THEN EXIT;
  714.   RestBytes := Records (FBytesToGo) * RECORDSIZE - FBytesToGo;
  715.   SetLength (Result, FBytesToGo);
  716.   FStream.ReadBuffer (PAnsiChar (Result)^, FBytesToGo);
  717.   FStream.Seek (RestBytes, soFromCurrent);
  718.   FBytesToGo := 0;
  719. END;
  720.  
  721.  
  722. PROCEDURE TTarArchive.GetFilePos (VAR Current, Size : INT64);
  723.           // Returns the Current Position in the TAR stream
  724. BEGIN
  725.   Current := FStream.Position;
  726.   Size    := FStream.Size;
  727. END;
  728.  
  729.  
  730. PROCEDURE TTarArchive.SetFilePos (NewPos : INT64);                   // Set new Current File Position
  731. BEGIN
  732.   IF NewPos < FStream.Size THEN
  733.     FStream.Seek (NewPos, soFromBeginning);
  734. END;
  735.  
  736.  
  737. (*
  738. ===============================================================================================
  739. TTarWriter
  740. ===============================================================================================
  741. *)
  742.  
  743.  
  744. CONSTRUCTOR TTarWriter.CreateEmpty;
  745. VAR
  746.   TP : TTarPermission;
  747. BEGIN
  748.   INHERITED Create;
  749.   FOwnsStream  := FALSE;
  750.   FFinalized   := FALSE;
  751.   FPermissions := [];
  752.   FOR TP := Low (TP) TO High (TP) DO
  753.     Include (FPermissions, TP);
  754.   FUID       := 0;
  755.   FGID       := 0;
  756.   FUserName  := '';
  757.   FGroupName := '';
  758.   FMode      := [];
  759.   FMagic     := 'ustar';
  760. END;
  761.  
  762. CONSTRUCTOR TTarWriter.Create (TargetStream   : TStream);
  763. BEGIN
  764.   CreateEmpty;
  765.   FStream     := TargetStream;
  766.   FOwnsStream := FALSE;
  767. END;
  768.  
  769.  
  770. CONSTRUCTOR TTarWriter.Create (TargetFilename : STRING; Mode : INTEGER = fmCreate);
  771. BEGIN
  772.   CreateEmpty;
  773.   FStream     := TFileStream.Create (TargetFilename, Mode);
  774.   FOwnsStream := TRUE;
  775. END;
  776.  
  777.  
  778. DESTRUCTOR TTarWriter.Destroy;
  779. BEGIN
  780.   IF NOT FFinalized THEN BEGIN
  781.     Finalize;
  782.     FFinalized := TRUE;
  783.     END;
  784.   IF FOwnsStream THEN
  785.     FStream.Free;
  786.   INHERITED Destroy;
  787. END;
  788.  
  789.  
  790. PROCEDURE TTarWriter.AddFile   (Filename : STRING;  TarFilename : AnsiString = '');
  791. VAR
  792.   S    : TFileStream;
  793.   Date : TDateTime;
  794. BEGIN
  795.   Date := FileTimeGMT (Filename);
  796.   IF TarFilename = ''
  797.     THEN TarFilename := AnsiString (ConvertFilename (Filename))
  798.     ELSE TarFilename := AnsiString (ConvertFilename (string (TarFilename)));
  799.   S := TFileStream.Create (Filename, fmOpenRead OR fmShareDenyWrite);
  800.   TRY
  801.     AddStream (S, TarFilename, Date);
  802.   FINALLY
  803.     S.Free
  804.     END;
  805. END;
  806.  
  807.  
  808. PROCEDURE TTarWriter.AddStream (Stream : TStream; TarFilename : AnsiString; FileDateGmt : TDateTime);
  809. VAR
  810.   DirRec      : TTarDirRec;
  811.   Rec         : ARRAY [0..RECORDSIZE-1] OF CHAR;
  812.   BytesToRead : INT64;      // Bytes to read from the Source Stream
  813.   BlockSize   : INT64;      // Bytes to write out for the current record
  814. BEGIN
  815.   ClearDirRec (DirRec);
  816.   DirRec.Name        := TarFilename;
  817.   DirRec.Size        := Stream.Size - Stream.Position;
  818.   DirRec.DateTime    := FileDateGmt;
  819.   DirRec.Permissions := FPermissions;
  820.   DirRec.FileType    := ftNormal;
  821.   DirRec.LinkName    := '';
  822.   DirRec.UID         := FUID;
  823.   DirRec.GID         := FGID;
  824.   DirRec.UserName    := FUserName;
  825.   DirRec.GroupName   := FGroupName;
  826.   DirRec.ChecksumOK  := TRUE;
  827.   DirRec.Mode        := FMode;
  828.   DirRec.Magic       := FMagic;
  829.   DirRec.MajorDevNo  := 0;
  830.   DirRec.MinorDevNo  := 0;
  831.  
  832.   WriteTarHeader (FStream, DirRec);
  833.   BytesToRead := DirRec.Size;
  834.   WHILE BytesToRead > 0 DO BEGIN
  835.     BlockSize := BytesToRead;
  836.     IF BlockSize > RECORDSIZE THEN BlockSize := RECORDSIZE;
  837.     FillChar (Rec, RECORDSIZE, 0);
  838.     Stream.Read (Rec, BlockSize);
  839.     FStream.Write (Rec, RECORDSIZE);
  840.     DEC (BytesToRead, BlockSize);
  841.     END;
  842. END;
  843.  
  844.  
  845. PROCEDURE TTarWriter.AddString (Contents : RawByteString; TarFilename : AnsiString; FileDateGmt : TDateTime);
  846. VAR
  847.   S : TStringStream;
  848. BEGIN
  849.   S := TStringStream.Create (Contents);
  850.   TRY
  851.     AddStream (S, TarFilename, FileDateGmt);
  852.   FINALLY
  853.     S.Free
  854.     END
  855. END;
  856.  
  857.  
  858. PROCEDURE TTarWriter.AddDir (Dirname : AnsiString; DateGmt : TDateTime; MaxDirSize : INT64 = 0);
  859. VAR
  860.   DirRec      : TTarDirRec;
  861. BEGIN
  862.   ClearDirRec (DirRec);
  863.   DirRec.Name        := Dirname;
  864.   DirRec.Size        := MaxDirSize;
  865.   DirRec.DateTime    := DateGmt;
  866.   DirRec.Permissions := FPermissions;
  867.   DirRec.FileType    := ftDirectory;
  868.   DirRec.LinkName    := '';
  869.   DirRec.UID         := FUID;
  870.   DirRec.GID         := FGID;
  871.   DirRec.UserName    := FUserName;
  872.   DirRec.GroupName   := FGroupName;
  873.   DirRec.ChecksumOK  := TRUE;
  874.   DirRec.Mode        := FMode;
  875.   DirRec.Magic       := FMagic;
  876.   DirRec.MajorDevNo  := 0;
  877.   DirRec.MinorDevNo  := 0;
  878.  
  879.   WriteTarHeader (FStream, DirRec);
  880. END;
  881.  
  882.  
  883. PROCEDURE TTarWriter.AddSymbolicLink (Filename, Linkname : AnsiString; DateGmt : TDateTime);
  884. VAR
  885.   DirRec : TTarDirRec;
  886. BEGIN
  887.   ClearDirRec (DirRec);
  888.   DirRec.Name        := Filename;
  889.   DirRec.Size        := 0;
  890.   DirRec.DateTime    := DateGmt;
  891.   DirRec.Permissions := FPermissions;
  892.   DirRec.FileType    := ftSymbolicLink;
  893.   DirRec.LinkName    := Linkname;
  894.   DirRec.UID         := FUID;
  895.   DirRec.GID         := FGID;
  896.   DirRec.UserName    := FUserName;
  897.   DirRec.GroupName   := FGroupName;
  898.   DirRec.ChecksumOK  := TRUE;
  899.   DirRec.Mode        := FMode;
  900.   DirRec.Magic       := FMagic;
  901.   DirRec.MajorDevNo  := 0;
  902.   DirRec.MinorDevNo  := 0;
  903.  
  904.   WriteTarHeader (FStream, DirRec);
  905. END;
  906.  
  907.  
  908. PROCEDURE TTarWriter.AddLink (Filename, Linkname : AnsiString; DateGmt : TDateTime);
  909. VAR
  910.   DirRec : TTarDirRec;
  911. BEGIN
  912.   ClearDirRec (DirRec);
  913.   DirRec.Name        := Filename;
  914.   DirRec.Size        := 0;
  915.   DirRec.DateTime    := DateGmt;
  916.   DirRec.Permissions := FPermissions;
  917.   DirRec.FileType    := ftLink;
  918.   DirRec.LinkName    := Linkname;
  919.   DirRec.UID         := FUID;
  920.   DirRec.GID         := FGID;
  921.   DirRec.UserName    := FUserName;
  922.   DirRec.GroupName   := FGroupName;
  923.   DirRec.ChecksumOK  := TRUE;
  924.   DirRec.Mode        := FMode;
  925.   DirRec.Magic       := FMagic;
  926.   DirRec.MajorDevNo  := 0;
  927.   DirRec.MinorDevNo  := 0;
  928.  
  929.   WriteTarHeader (FStream, DirRec);
  930. END;
  931.  
  932.  
  933. PROCEDURE TTarWriter.AddVolumeHeader (VolumeId : AnsiString; DateGmt : TDateTime);
  934. VAR
  935.   DirRec : TTarDirRec;
  936. BEGIN
  937.   ClearDirRec (DirRec);
  938.   DirRec.Name        := VolumeId;
  939.   DirRec.Size        := 0;
  940.   DirRec.DateTime    := DateGmt;
  941.   DirRec.Permissions := FPermissions;
  942.   DirRec.FileType    := ftVolumeHeader;
  943.   DirRec.LinkName    := '';
  944.   DirRec.UID         := FUID;
  945.   DirRec.GID         := FGID;
  946.   DirRec.UserName    := FUserName;
  947.   DirRec.GroupName   := FGroupName;
  948.   DirRec.ChecksumOK  := TRUE;
  949.   DirRec.Mode        := FMode;
  950.   DirRec.Magic       := FMagic;
  951.   DirRec.MajorDevNo  := 0;
  952.   DirRec.MinorDevNo  := 0;
  953.  
  954.   WriteTarHeader (FStream, DirRec);
  955. END;
  956.  
  957.  
  958. PROCEDURE TTarWriter.Finalize;
  959.           // Writes the End-Of-File Tag
  960.           // Data after this tag will be ignored
  961.           // The destructor calls this automatically if you didn't do it before
  962. VAR
  963.   Rec : ARRAY [0..RECORDSIZE-1] OF CHAR;
  964. BEGIN
  965.   FillChar (Rec, SizeOf (Rec), 0);
  966.   FStream.Write (Rec, RECORDSIZE);
  967.   FFinalized := TRUE;
  968. END;
  969.  
  970.  
  971. END.
Advertisement
RAW Paste Data Copied
Advertisement