paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-12 13:49:30 +02:00
Code Issues Packages Projects Releases Wiki Activity
25999ad8ff
fpc/tests/utils/libtar.pas
pierre 788c6a6f83 Do not call Free if constructor failed 
git-svn-id: trunk@29298 -
2014-12-14 22:14:00 +00:00

984 lines
33 KiB
ObjectPascal
Raw Blame History

(**
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.
Reference in New Issue View Git Blame Copy Permalink