* Updated to 2.1.0 mostly. Expands support for "mode" in tarheaders.

git-svn-id: trunk@17412 -

packages/fcl-base/src/libtar.pp

@@ -1,5 +1,5 @@
 (**
- Copyright (c) 2000-2006 by Stefan Heymann
+ Copyright (c) 2000-2010 by Stefan Heymann
 
  See the file COPYING.FPC, included in this distribution,
  for details about the copyright. 
@@ -75,6 +75,12 @@ Date        Author Changes
 2006-09-20  MvdV   2.0.7.1 Small fixes for FPC.
 2007-05-16  HeySt  2.0.8 Bugfix in TTarWriter.AddFile (Convertfilename in the ELSE branch)
                          Bug Reported by Chris Rorden
+2010-11-29  HeySt  2.1.0 WriteTarHeader: Mode values for ftNormal/ftLink/ftSymbolicLink/ftDirectory
+                         Thanks to Iouri Kharon for the fix.
+                         Still no support for filenames > 100 bytes. Sorry.
+                         Support for Unicode Delphi versions (2009, 2010, XE, etc.)
+                   MvdV 2.1.0 notes : not all of the Unicode changes have been made, decisions on this subject still pending on the FPC side.
+									Mostly rawbytestring and a couple of more hary typecasts.
 *)
 
 UNIT libtar;
@@ -130,19 +136,19 @@ TYPE
   // --- Record for a Directory Entry
   //     Adjust the ClearDirRec procedure when this record changes!
   TTarDirRec  = RECORD
-                  Name        : STRING;            // File path and name
+                  Name        : AnsiString;            // 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)
+                  LinkName    : AnsiString;            // Name of linked file (for ftLink, ftSymbolicLink)
                   UID         : INTEGER;           // User ID
                   GID         : INTEGER;           // Group ID
-                  UserName    : STRING;            // User name
-                  GroupName   : STRING;            // Group name
+                  UserName    : AnsiString;            // User name
+                  GroupName   : AnsiString;            // Group name
                   ChecksumOK  : BOOLEAN;           // Checksum was OK
                   Mode        : TTarModes;         // Mode
-                  Magic       : STRING;            // Contents of the "Magic" field
+                  Magic       : AnsiString;            // 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
@@ -164,7 +170,7 @@ TYPE
                   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;         // -;-
+                  FUNCTION  ReadFile : STRING;           OVERLOAD;         // -;-  RawByteString in D2009+. Not active due to FPC unicode architecture not being finalized
 
                   PROCEDURE GetFilePos (VAR Current, Size : INT64);        // Current File Position
                   PROCEDURE SetFilePos (NewPos : INT64);                   // Set new Current File Position
@@ -180,30 +186,30 @@ TYPE
                  FPermissions : TTarPermissions;   // Access permissions
                  FUID         : INTEGER;           // User ID
                  FGID         : INTEGER;           // Group ID
-                 FUserName    : STRING;            // User name
-                 FGroupName   : STRING;            // Group name
+                 FUserName    : AnsiString;            // User name
+                 FGroupName   : AnsiString;            // Group name
                  FMode        : TTarModes;         // Mode
-                 FMagic       : STRING;            // Contents of the "Magic" field
+                 FMagic       : AnsiString;            // 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
-                 PROCEDURE AddFile   (Filename : STRING;  TarFilename : STRING = '');
-                 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 AddFile   (Filename : STRING;  TarFilename : AnsiString = '');
+                 PROCEDURE AddStream (Stream   : TStream; TarFilename : AnsiString; FileDateGmt : TDateTime);
+                 PROCEDURE AddString (Contents : Ansistring;  TarFilename : AnsiString; FileDateGmt : TDateTime);  // RawByteString
+                 PROCEDURE AddDir          (Dirname            : AnsiString; DateGmt : TDateTime; MaxDirSize : INT64 = 0);
+                 PROCEDURE AddSymbolicLink (Filename, Linkname : AnsiString; DateGmt : TDateTime);
+                 PROCEDURE AddLink         (Filename, Linkname : AnsiString; DateGmt : TDateTime);
+                 PROCEDURE AddVolumeHeader (VolumeId           : AnsiString; 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 UserName    : AnsiString          READ FUserName    WRITE FUserName;      // User name
+                 PROPERTY GroupName   : AnsiString          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
+                 PROPERTY Magic       : AnsiString          READ FMagic       WRITE FMagic;         // Contents of the "Magic" field
                END;
 
 // --- Some useful constants
@@ -347,34 +353,34 @@ CONST
 
 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;
+                 Name     : ARRAY [0..NAMSIZ-1] OF AnsiChar;
+                 Mode     : ARRAY [0..7] OF AnsiChar;
+                 UID      : ARRAY [0..7] OF AnsiChar;
+                 GID      : ARRAY [0..7] OF AnsiChar;
+                 Size     : ARRAY [0..11] OF AnsiChar;
+                 MTime    : ARRAY [0..11] OF AnsiChar;
+                 ChkSum   : ARRAY [0..7] OF AnsiChar;
+                 LinkFlag : AnsiChar;
+                 LinkName : ARRAY [0..NAMSIZ-1] OF AnsiChar;
+                 Magic    : ARRAY [0..7] OF AnsiChar;
+                 UName    : ARRAY [0..TUNMLEN-1] OF AnsiChar;
+                 GName    : ARRAY [0..TGNMLEN-1] OF AnsiChar;
+                 DevMajor : ARRAY [0..7] OF AnsiChar;
+                 DevMinor : ARRAY [0..7] OF AnsiChar;
                END;
 
-FUNCTION ExtractText (P : PChar) : STRING;
+FUNCTION ExtractText (P : PAnsiChar) : AnsiString;
 BEGIN
-  Result := STRING (P);
+  Result := AnsiString(P);
 END;
 
 
-FUNCTION ExtractNumber (P : PChar) : INTEGER; OVERLOAD;
+FUNCTION ExtractNumber (P : PAnsiChar) : INTEGER; OVERLOAD;
 VAR
-  Strg : STRING;
+  Strg : AnsiString;
 BEGIN
   Strg := Trim (StrPas (P));
-  P := PChar (Strg);
+  P := PAnsiChar (Strg);
   Result := 0;
   WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
     Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
@@ -382,12 +388,12 @@ BEGIN
     END;
 END;
 
-FUNCTION ExtractNumber64 (P : PChar) : INT64; OVERLOAD;
+FUNCTION ExtractNumber64 (P : PAnsiChar) : INT64; OVERLOAD;
 VAR
-  Strg : STRING;
+  Strg : AnsiString;
 BEGIN
   Strg := Trim (StrPas (P));
-  P := PChar (Strg);
+  P := PAnsiChar (Strg);
   Result := 0;
   WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
     Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
@@ -396,14 +402,14 @@ BEGIN
 END;
 
 
-FUNCTION ExtractNumber (P : PChar; MaxLen : INTEGER) : INTEGER; OVERLOAD;
+FUNCTION ExtractNumber (P : PAnsiChar; MaxLen : INTEGER) : INTEGER; OVERLOAD;
 VAR
-  S0   : ARRAY [0..255] OF CHAR;
-  Strg : STRING;
+  S0   : ARRAY [0..255] OF AnsiChar;
+  Strg : AnsiString;
 BEGIN
   StrLCopy (S0, P, MaxLen);
   Strg := Trim (StrPas (S0));
-  P := PChar (Strg);
+  P := PAnsiChar (Strg);
   Result := 0;
   WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
     Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
@@ -412,14 +418,14 @@ BEGIN
 END;
 
 
-FUNCTION ExtractNumber64 (P : PChar; MaxLen : INTEGER) : INT64; OVERLOAD;
+FUNCTION ExtractNumber64 (P : PAnsiChar; MaxLen : INTEGER) : INT64; OVERLOAD;
 VAR
-  S0   : ARRAY [0..255] OF CHAR;
-  Strg : STRING;
+  S0   : ARRAY [0..255] OF AnsiChar;
+  Strg : AnsiString;
 BEGIN
   StrLCopy (S0, P, MaxLen);
   Strg := Trim (StrPas (S0));
-  P := PChar (Strg);
+  P := PAnsiChar (Strg);
   Result := 0;
   WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
     Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
@@ -436,14 +442,14 @@ BEGIN
 END;
 
 
-PROCEDURE Octal (N : INTEGER; P : PChar; Len : INTEGER);
+PROCEDURE Octal (N : INTEGER; P : PAnsiChar; 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));
+    (P+I)^ := AnsiChar (ORD ('0') + ORD (N AND $07));
     N := N SHR 3;
     END;
   FOR I := 0 TO Len-3 DO
@@ -454,14 +460,14 @@ BEGIN
 END;
 
 
-PROCEDURE Octal64 (N : INT64; P : PChar; Len : INTEGER);
+PROCEDURE Octal64 (N : INT64; P : PAnsiChar; 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));
+    (P+I)^ := AnsiChar (ORD ('0') + ORD (N AND $07));
     N := N SHR 3;
     END;
   FOR I := 0 TO Len-3 DO
@@ -472,7 +478,7 @@ BEGIN
 END;
 
 
-PROCEDURE OctalN (N : INTEGER; P : PChar; Len : INTEGER);
+PROCEDURE OctalN (N : INTEGER; P : PAnsiChar; Len : INTEGER);
 BEGIN
   Octal (N, P, Len-1);
   (P+Len-1)^ := #0;
@@ -481,7 +487,7 @@ END;
 
 PROCEDURE WriteTarHeader (Dest : TStream; DirRec : TTarDirRec);
 VAR
-  Rec      : ARRAY [0..RECORDSIZE-1] OF CHAR;
+  Rec      : ARRAY [0..RECORDSIZE-1] OF AnsiChar;
   TH       : TTarHeader ABSOLUTE Rec;
   Mode     : INTEGER;
   NullDate : TDateTime;
@@ -489,8 +495,13 @@ VAR
   I        : INTEGER;
 BEGIN
   FillChar (Rec, RECORDSIZE, 0);
-  StrLCopy (TH.Name, PChar (DirRec.Name), NAMSIZ);
-  Mode := 0;
+  StrLCopy (TH.Name, PAnsiChar (DirRec.Name), NAMSIZ);
+  CASE DirRec.FileType OF
+    ftNormal, ftLink  : Mode := $08000;
+    ftSymbolicLink    : Mode := $0A000;
+    ftDirectory         : Mode := $04000;
+    ELSE                  Mode := 0;
+    END;
   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;
@@ -524,10 +535,10 @@ BEGIN
     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);
+  StrLCopy (TH.LinkName, PAnsiChar (DirRec.LinkName), NAMSIZ);
+  StrLCopy (TH.Magic, PAnsiChar (DirRec.Magic + #32#32#32#32#32#32#32#32), 8);
+  StrLCopy (TH.UName, PAnsiChar (DirRec.UserName), TUNMLEN);
+  StrLCopy (TH.GName, PAnsiChar (DirRec.GroupName), TGNMLEN);
   OctalN (DirRec.MajorDevNo, @TH.DevMajor, 8);
   OctalN (DirRec.MinorDevNo, @TH.DevMinor, 8);
   StrMove (TH.ChkSum, CHKBLANKS, 8);
@@ -715,7 +726,7 @@ BEGIN
   IF FBytesToGo = 0 THEN EXIT;
   RestBytes := Records (FBytesToGo) * RECORDSIZE - FBytesToGo;
   SetLength (Result, FBytesToGo);
-  FStream.ReadBuffer (PChar (Result)^, FBytesToGo);
+  FStream.ReadBuffer (PAnsiChar (Result)^, FBytesToGo);
   FStream.Seek (RestBytes, soFromCurrent);
   FBytesToGo := 0;
 END;
@@ -789,7 +800,7 @@ BEGIN
 END;
 
 
-PROCEDURE TTarWriter.AddFile   (Filename : STRING;  TarFilename : STRING = '');
+PROCEDURE TTarWriter.AddFile   (Filename : STRING;  TarFilename : AnsiString = '');
 VAR
   S    : TFileStream;
   Date : TDateTime;
@@ -807,7 +818,7 @@ BEGIN
 END;
 
 
-PROCEDURE TTarWriter.AddStream (Stream : TStream; TarFilename : STRING; FileDateGmt : TDateTime);
+PROCEDURE TTarWriter.AddStream (Stream : TStream; TarFilename : AnsiString; FileDateGmt : TDateTime);
 VAR
   DirRec      : TTarDirRec;
   Rec         : ARRAY [0..RECORDSIZE-1] OF CHAR;
@@ -844,7 +855,7 @@ BEGIN
 END;
 
 
-PROCEDURE TTarWriter.AddString (Contents : STRING; TarFilename : STRING; FileDateGmt : TDateTime);
+PROCEDURE TTarWriter.AddString (Contents : AnsiString; TarFilename : AnsiString; FileDateGmt : TDateTime); // rawbytestring
 VAR
   S : TStringStream;
 BEGIN
@@ -857,7 +868,7 @@ BEGIN
 END;
 
 
-PROCEDURE TTarWriter.AddDir (Dirname : STRING; DateGmt : TDateTime; MaxDirSize : INT64 = 0);
+PROCEDURE TTarWriter.AddDir (Dirname : AnsiString; DateGmt : TDateTime; MaxDirSize : INT64 = 0);
 VAR
   DirRec      : TTarDirRec;
 BEGIN
@@ -882,7 +893,7 @@ BEGIN
 END;
 
 
-PROCEDURE TTarWriter.AddSymbolicLink (Filename, Linkname : STRING; DateGmt : TDateTime);
+PROCEDURE TTarWriter.AddSymbolicLink (Filename, Linkname : AnsiString; DateGmt : TDateTime);
 VAR
   DirRec : TTarDirRec;
 BEGIN
@@ -907,7 +918,7 @@ BEGIN
 END;
 
 
-PROCEDURE TTarWriter.AddLink (Filename, Linkname : STRING; DateGmt : TDateTime);
+PROCEDURE TTarWriter.AddLink (Filename, Linkname : AnsiString; DateGmt : TDateTime);
 VAR
   DirRec : TTarDirRec;
 BEGIN
@@ -932,7 +943,7 @@ BEGIN
 END;
 
 
-PROCEDURE TTarWriter.AddVolumeHeader (VolumeId           : STRING; DateGmt : TDateTime);
+PROCEDURE TTarWriter.AddVolumeHeader (VolumeId           : AnsiString; DateGmt : TDateTime);
 VAR
   DirRec : TTarDirRec;
 BEGIN