1 (**
2 Copyright (c) 2000-2006 by Stefan Heymann
3
4 See the file COPYING.FPC, included in this distribution,
5 for details about the copyright.
6
7 This program is distributed in the hope that it will be useful,
8 but WITHOUT ANY WARRANTY; without even the implied warranty of
9 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
10
11 ===============================================================================================
12 Name : LibTar
13 ===============================================================================================
14 Subject : Handling of "tar" files
15 ===============================================================================================
16 Author : Stefan Heymann
17 Eschenweg 3
18 72076 T�bingen
19 GERMANY
20
21 E-Mail: stefan@destructor.de
22 Web: www.destructor.de
23
24 ===============================================================================================
25 TTarArchive Usage
26 -----------------
27 - Choose a constructor
28 - Make an instance of TTarArchive TA := TTarArchive.Create (Filename);
29 - Scan through the archive TA.Reset;
30 WHILE TA.FindNext (DirRec) DO BEGIN
31 - Evaluate the DirRec for each file ListBox.Items.Add (DirRec.Name);
32 - Read out the current file TA.ReadFile (DestFilename);
33 (You can ommit this if you want to
34 read in the directory only) END;
35 - You're done TA.Free;
36
37
38 TTarWriter Usage
39 ----------------
40 - Choose a constructor
41 - Make an instance of TTarWriter TW := TTarWriter.Create ('my.tar');
42 - Add a file to the tar archive TW.AddFile ('foobar.txt');
43 - Add a string as a file TW.AddString (SL.Text, 'joe.txt', Now);
44 - Destroy TarWriter instance TW.Free;
45 - Now your tar file is ready.
46
47
48 Source
49 --------------------------
50 The official site to get this code is http://www.destructor.de/
51
52 Donateware
53 ----------
54 If you like this code, you are free to donate
55 http://www.destructor.de/donateware.htm
56
57 ===============================================================================================
58 !!! All parts of this code which are not finished or known to be buggy
59 are marked with three exclamation marks
60 ===============================================================================================
61 Date Author Changes
62 -----------------------------------------------------------------------------------------------
63 2001-04-26 HeySt 0.0.1 Start
64 2001-04-28 HeySt 1.0.0 First Release
65 2001-06-19 HeySt 2.0.0 Finished TTarWriter
66 2001-09-06 HeySt 2.0.1 Bugfix in TTarArchive.FindNext: FBytesToGo must sometimes be 0
67 2001-10-25 HeySt 2.0.2 Introduced the ClearDirRec procedure
68 2001-11-13 HeySt 2.0.3 Bugfix: Take out ClearDirRec call from WriteTarHeader
69 Bug Reported by Tony BenBrahim
70 2001-12-25 HeySt 2.0.4 WriteTarHeader: Fill Rec with zero bytes before filling it
71 2002-05-18 HeySt 2.0.5 Kylix awareness: Thanks to Kerry L. Davison for the canges
72 2005-09-03 HeySt 2.0.6 TTarArchive.FindNext: Don't access SourceStream.Size
73 (for compressed streams, which don't know their .Size)
74 2006-03-13 HeySt 2.0.7 Bugfix in ReadFile (Buffer : POINTER)
75 2006-09-20 MvdV 2.0.7.1 Small fixes for FPC.
76 *)
77
78 UNIT LibTar;
79
80 INTERFACE
81
82 {$IFDEF FPC}
83 {$MODE Delphi}
84 {$ELSE}
85 {$IFDEF LINUX}
86 {$DEFINE Kylix}
87 {$DEFINE LIBCUNIT}
88 {$ENDIF}
89 {$ENDIF}
90
91 USES
92 {$IFDEF LIBCUNIT}
93 Libc, // MvdV: Nothing is used from this???
94 {$ENDIF}
95 {$ifdef Unix}
96 BaseUnix, Unix,
97 {$endif}
98 (*$IFDEF MSWINDOWS *)
99 Windows,
100 (*$ENDIF *)
101 SysUtils, Classes;
102
103
104 TYPE
105 // --- File Access Permissions
106 TTarPermission = (tpReadByOwner, tpWriteByOwner, tpExecuteByOwner,
107 tpReadByGroup, tpWriteByGroup, tpExecuteByGroup,
108 tpReadByOther, tpWriteByOther, tpExecuteByOther);
109 TTarPermissions = SET OF TTarPermission;
110
111 // --- Type of File
112 TFileType = (ftNormal, // Regular file
113 ftLink, // Link to another, previously archived, file (LinkName)
114 ftSymbolicLink, // Symbolic link to another file (LinkName)
115 ftCharacter, // Character special files
116 ftBlock, // Block special files
117 ftDirectory, // Directory entry. Size is zero (unlimited) or max. number of bytes
118 ftFifo, // FIFO special file. No data stored in the archive.
119 ftContiguous, // Contiguous file, if supported by OS
120 ftDumpDir, // List of files
121 ftMultiVolume, // Multi-volume file part
122 ftVolumeHeader); // Volume header. Can appear only as first record in the archive
123
124 // --- Mode
125 TTarMode = (tmSetUid, tmSetGid, tmSaveText);
126 TTarModes = SET OF TTarMode;
127
128 // --- Record for a Directory Entry
129 // Adjust the ClearDirRec procedure when this record changes!
130 TTarDirRec = RECORD
131 Name : STRING; // File path and name
132 Size : INT64; // File size in Bytes
133 DateTime : TDateTime; // Last modification date and time
134 Permissions : TTarPermissions; // Access permissions
135 FileType : TFileType; // Type of file
136 LinkName : STRING; // Name of linked file (for ftLink, ftSymbolicLink)
137 UID : INTEGER; // User ID
138 GID : INTEGER; // Group ID
139 UserName : STRING; // User name
140 GroupName : STRING; // Group name
141 ChecksumOK : BOOLEAN; // Checksum was OK
142 Mode : TTarModes; // Mode
143 Magic : STRING; // Contents of the "Magic" field
144 MajorDevNo : INTEGER; // Major Device No. for ftCharacter and ftBlock
145 MinorDevNo : INTEGER; // Minor Device No. for ftCharacter and ftBlock
146 FilePos : INT64; // Position in TAR file
147 END;
148
149 // --- The TAR Archive CLASS
150 TTarArchive = CLASS
151 PROTECTED
152 FStream : TStream; // Internal Stream
153 FOwnsStream : BOOLEAN; // True if FStream is owned by the TTarArchive instance
154 FBytesToGo : INT64; // Bytes until the next Header Record
155 PUBLIC
156 CONSTRUCTOR Create (Stream : TStream); OVERLOAD;
157 CONSTRUCTOR Create (Filename : STRING;
158 FileMode : WORD = fmOpenRead OR fmShareDenyWrite); OVERLOAD;
159 DESTRUCTOR Destroy; OVERRIDE;
160 PROCEDURE Reset; // Reset File Pointer
FindNextnull161 FUNCTION FindNext (VAR DirRec : TTarDirRec) : BOOLEAN; // Reads next Directory Info Record. FALSE if EOF reached
162 PROCEDURE ReadFile (Buffer : POINTER); OVERLOAD; // Reads file data for last Directory Record
163 PROCEDURE ReadFile (Stream : TStream); OVERLOAD; // -;-
164 PROCEDURE ReadFile (Filename : STRING); OVERLOAD; // -;-
ReadFilenull165 FUNCTION ReadFile : STRING; OVERLOAD; // -;-
166
167 PROCEDURE GetFilePos (VAR Current, Size : INT64); // Current File Position
168 PROCEDURE SetFilePos (NewPos : INT64); // Set new Current File Position
169 END;
170
171 // --- The TAR Archive Writer CLASS
172 TTarWriter = CLASS
173 PROTECTED
174 FStream : TStream;
175 FOwnsStream : BOOLEAN;
176 FFinalized : BOOLEAN;
177 // --- Used at the next "Add" method call: ---
178 FPermissions : TTarPermissions; // Access permissions
179 FUID : INTEGER; // User ID
180 FGID : INTEGER; // Group ID
181 FUserName : STRING; // User name
182 FGroupName : STRING; // Group name
183 FMode : TTarModes; // Mode
184 FMagic : STRING; // Contents of the "Magic" field
185 CONSTRUCTOR CreateEmpty;
186 PUBLIC
187 CONSTRUCTOR Create (TargetStream : TStream); OVERLOAD;
188 CONSTRUCTOR Create (TargetFilename : STRING; Mode : INTEGER = fmCreate); OVERLOAD;
189 DESTRUCTOR Destroy; OVERRIDE; // Writes End-Of-File Tag
AddFilenull190 FUNCTION AddFile (Filename : STRING; TarFilename : STRING = '') : BOOLEAN;
191 PROCEDURE AddStream (Stream : TStream; TarFilename : STRING; FileDateGmt : TDateTime);
192 PROCEDURE AddString (Contents : STRING; TarFilename : STRING; FileDateGmt : TDateTime);
193 PROCEDURE AddDir (Dirname : STRING; DateGmt : TDateTime; MaxDirSize : INT64 = 0);
194 PROCEDURE AddSymbolicLink (Filename, Linkname : STRING; DateGmt : TDateTime);
195 PROCEDURE AddLink (Filename, Linkname : STRING; DateGmt : TDateTime);
196 PROCEDURE AddVolumeHeader (VolumeId : STRING; DateGmt : TDateTime);
197 PROCEDURE Finalize;
198 PROPERTY Permissions : TTarPermissions READ FPermissions WRITE FPermissions; // Access permissions
199 PROPERTY UID : INTEGER READ FUID WRITE FUID; // User ID
200 PROPERTY GID : INTEGER READ FGID WRITE FGID; // Group ID
201 PROPERTY UserName : STRING READ FUserName WRITE FUserName; // User name
202 PROPERTY GroupName : STRING READ FGroupName WRITE FGroupName; // Group name
203 PROPERTY Mode : TTarModes READ FMode WRITE FMode; // Mode
204 PROPERTY Magic : STRING READ FMagic WRITE FMagic; // Contents of the "Magic" field
205 END;
206
207 // --- Some useful constants
208 CONST
209 FILETYPE_NAME : ARRAY [TFileType] OF STRING =
210 ('Regular', 'Link', 'Symbolic Link', 'Char File', 'Block File',
211 'Directory', 'FIFO File', 'Contiguous', 'Dir Dump', 'Multivol', 'Volume Header');
212
213 ALL_PERMISSIONS = [tpReadByOwner, tpWriteByOwner, tpExecuteByOwner,
214 tpReadByGroup, tpWriteByGroup, tpExecuteByGroup,
215 tpReadByOther, tpWriteByOther, tpExecuteByOther];
216 READ_PERMISSIONS = [tpReadByOwner, tpReadByGroup, tpReadByOther];
217 WRITE_PERMISSIONS = [tpWriteByOwner, tpWriteByGroup, tpWriteByOther];
218 EXECUTE_PERMISSIONS = [tpExecuteByOwner, tpExecuteByGroup, tpExecuteByOther];
219
220
PermissionStringnull221 FUNCTION PermissionString (Permissions : TTarPermissions) : STRING;
ConvertFilenamenull222 FUNCTION ConvertFilename (Filename : STRING) : STRING;
FileTimeGMTnull223 FUNCTION FileTimeGMT (FileName : STRING) : TDateTime; OVERLOAD;
FileTimeGMTnull224 FUNCTION FileTimeGMT (SearchRec : TSearchRec) : TDateTime; OVERLOAD;
225 PROCEDURE ClearDirRec (VAR DirRec : TTarDirRec);
226
227
228 (*
229 ===============================================================================================
230 IMPLEMENTATION
231 ===============================================================================================
232 *)
233
234 IMPLEMENTATION
235
PermissionStringnull236 FUNCTION PermissionString (Permissions : TTarPermissions) : STRING;
237 BEGIN
238 Result := '';
239 IF tpReadByOwner IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-';
240 IF tpWriteByOwner IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-';
241 IF tpExecuteByOwner IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-';
242 IF tpReadByGroup IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-';
243 IF tpWriteByGroup IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-';
244 IF tpExecuteByGroup IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-';
245 IF tpReadByOther IN Permissions THEN Result := Result + 'r' ELSE Result := Result + '-';
246 IF tpWriteByOther IN Permissions THEN Result := Result + 'w' ELSE Result := Result + '-';
247 IF tpExecuteByOther IN Permissions THEN Result := Result + 'x' ELSE Result := Result + '-';
248 END;
249
250
ConvertFilenamenull251 FUNCTION ConvertFilename (Filename : STRING) : STRING;
252 // Converts the filename to Unix conventions
253 // could be empty and inlined away for FPC. FPC I/O should be
254 // forward/backward slash safe.
255 BEGIN
256 (*$IFDEF Unix *)
257 Result := Filename;
258 (*$ELSE *)
259 Result := StringReplace (Filename, '\', '/', [rfReplaceAll]);
260 (*$ENDIF *)
261 END;
262
FileTimeGMTnull263 FUNCTION FileTimeGMT (FileName: STRING): TDateTime;
264 // Returns the Date and Time of the last modification of the given File
265 // The Result is zero if the file could not be found
266 // The Result is given in UTC (GMT) time zone
267 VAR
268 SR : TSearchRec;
269 BEGIN
270 Result := 0.0;
271 IF FindFirst (FileName, faAnyFile, SR) = 0 THEN
272 Result := FileTimeGMT (SR);
273 FindClose (SR);
274 END;
275
276
FileTimeGMTnull277 FUNCTION FileTimeGMT (SearchRec : TSearchRec) : TDateTime;
278 (*$IFDEF MSWINDOWS *)
279 VAR
280 SystemFileTime: TSystemTime;
281 (*$ENDIF *)
282 (*$IFDEF Unix *)
283 VAR
284 TimeVal : TTimeVal;
285 TimeZone : TTimeZone;
286 (*$ENDIF *)
287 BEGIN
288 Result := 0.0;
289 (*$IFDEF MSWINDOWS *) (*$WARNINGS OFF *)
290 IF (SearchRec.FindData.dwFileAttributes AND faDirectory) = 0 THEN
291 IF FileTimeToSystemTime (SearchRec.FindData.ftLastWriteTime, SystemFileTime) THEN
292 Result := EncodeDate (SystemFileTime.wYear, SystemFileTime.wMonth, SystemFileTime.wDay)
293 + EncodeTime (SystemFileTime.wHour, SystemFileTime.wMinute, SystemFileTime.wSecond, SystemFileTime.wMilliseconds);
294 (*$ENDIF *) (*$WARNINGS ON *)
295 (*$IFDEF Unix *)
296 IF SearchRec.Attr AND faDirectory = 0 THEN BEGIN
297 Result := FileDateToDateTime (SearchRec.Time);
298 {$IFDEF Kylix}
299 GetTimeOfDay (TimeVal, TimeZone);
300 {$ELSE}
301 fpGetTimeOfDay (@TimeVal, @TimeZone);
302 {$ENDIF}
303 Result := Result + TimeZone.tz_minuteswest / (60 * 24);
304 END;
305 (*$ENDIF *)
306 end;
307
308
309 PROCEDURE ClearDirRec (VAR DirRec : TTarDirRec);
310 // This is included because a FillChar (DirRec, SizeOf (DirRec), 0)
311 // will destroy the long string pointers, leading to strange bugs
312 BEGIN
313 WITH DirRec DO BEGIN
314 Name := '';
315 Size := 0;
316 DateTime := 0.0;
317 Permissions := [];
318 FileType := TFileType (0);
319 LinkName := '';
320 UID := 0;
321 GID := 0;
322 UserName := '';
323 GroupName := '';
324 ChecksumOK := FALSE;
325 Mode := [];
326 Magic := '';
327 MajorDevNo := 0;
328 MinorDevNo := 0;
329 FilePos := 0;
330 END;
331 END;
332
333 (*
334 ===============================================================================================
335 TAR format
336 ===============================================================================================
337 *)
338
339 CONST
340 RECORDSIZE = 512;
341 NAMSIZ = 100;
342 TUNMLEN = 32;
343 TGNMLEN = 32;
344 CHKBLANKS = #32#32#32#32#32#32#32#32;
345
346 TYPE
347 TTarHeader = PACKED RECORD
348 Name : ARRAY [0..NAMSIZ-1] OF CHAR;
349 Mode : ARRAY [0..7] OF CHAR;
350 UID : ARRAY [0..7] OF CHAR;
351 GID : ARRAY [0..7] OF CHAR;
352 Size : ARRAY [0..11] OF CHAR;
353 MTime : ARRAY [0..11] OF CHAR;
354 ChkSum : ARRAY [0..7] OF CHAR;
355 LinkFlag : CHAR;
356 LinkName : ARRAY [0..NAMSIZ-1] OF CHAR;
357 Magic : ARRAY [0..7] OF CHAR;
358 UName : ARRAY [0..TUNMLEN-1] OF CHAR;
359 GName : ARRAY [0..TGNMLEN-1] OF CHAR;
360 DevMajor : ARRAY [0..7] OF CHAR;
361 DevMinor : ARRAY [0..7] OF CHAR;
362 END;
363
ExtractTextnull364 FUNCTION ExtractText (P : PChar) : STRING;
365 BEGIN
366 Result := STRING (P);
367 END;
368
369
ExtractNumbernull370 FUNCTION ExtractNumber (P : PChar) : INTEGER; OVERLOAD;
371 VAR
372 Strg : STRING;
373 BEGIN
374 Strg := Trim (StrPas (P));
375 P := PChar (Strg);
376 Result := 0;
377 WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
378 Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
379 INC (P);
380 END;
381 END;
382
ExtractNumber64null383 FUNCTION ExtractNumber64 (P : PChar) : INT64; OVERLOAD;
384 VAR
385 Strg : STRING;
386 BEGIN
387 Strg := Trim (StrPas (P));
388 P := PChar (Strg);
389 Result := 0;
390 WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
391 Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
392 INC (P);
393 END;
394 END;
395
396
ExtractNumbernull397 FUNCTION ExtractNumber (P : PChar; MaxLen : INTEGER) : INTEGER; OVERLOAD;
398 VAR
399 S0 : ARRAY [0..255] OF CHAR;
400 Strg : STRING;
401 BEGIN
402 StrLCopy (S0, P, MaxLen);
403 Strg := Trim (StrPas (S0));
404 P := PChar (Strg);
405 Result := 0;
406 WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
407 Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
408 INC (P);
409 END;
410 END;
411
412
ExtractNumber64null413 FUNCTION ExtractNumber64 (P : PChar; MaxLen : INTEGER) : INT64; OVERLOAD;
414 VAR
415 S0 : ARRAY [0..255] OF CHAR;
416 Strg : STRING;
417 BEGIN
418 StrLCopy (S0, P, MaxLen);
419 Strg := Trim (StrPas (S0));
420 P := PChar (Strg);
421 Result := 0;
422 WHILE (P^ <> #32) AND (P^ <> #0) DO BEGIN
423 Result := (ORD (P^) - ORD ('0')) OR (Result SHL 3);
424 INC (P);
425 END;
426 END;
427
428
Recordsnull429 FUNCTION Records (Bytes : INT64) : INT64;
430 BEGIN
431 Result := Bytes DIV RECORDSIZE;
432 IF Bytes MOD RECORDSIZE > 0 THEN
433 INC (Result);
434 END;
435
436
437 PROCEDURE Octal (N : INTEGER; P : PChar; Len : INTEGER);
438 // Makes a string of octal digits
439 // The string will always be "Len" characters long
440 VAR
441 I : INTEGER;
442 BEGIN
443 FOR I := Len-2 DOWNTO 0 DO BEGIN
444 (P+I)^ := CHR (ORD ('0') + ORD (N AND $07));
445 N := N SHR 3;
446 END;
447 FOR I := 0 TO Len-3 DO
448 IF (P+I)^ = '0'
449 THEN (P+I)^ := #32
450 ELSE BREAK;
451 (P+Len-1)^ := #32;
452 END;
453
454
455 PROCEDURE Octal64 (N : INT64; P : PChar; Len : INTEGER);
456 // Makes a string of octal digits
457 // The string will always be "Len" characters long
458 VAR
459 I : INTEGER;
460 BEGIN
461 FOR I := Len-2 DOWNTO 0 DO BEGIN
462 (P+I)^ := CHR (ORD ('0') + ORD (N AND $07));
463 N := N SHR 3;
464 END;
465 FOR I := 0 TO Len-3 DO
466 IF (P+I)^ = '0'
467 THEN (P+I)^ := #32
468 ELSE BREAK;
469 (P+Len-1)^ := #32;
470 END;
471
472
473 PROCEDURE OctalN (N : INTEGER; P : PChar; Len : INTEGER);
474 BEGIN
475 Octal (N, P, Len-1);
476 (P+Len-1)^ := #0;
477 END;
478
479
480 PROCEDURE WriteTarHeader (Dest : TStream; DirRec : TTarDirRec);
481 VAR
482 Rec : ARRAY [0..RECORDSIZE-1] OF CHAR;
483 TH : TTarHeader ABSOLUTE Rec;
484 Mode : INTEGER;
485 NullDate : TDateTime;
486 Checksum : CARDINAL;
487 I : INTEGER;
488 BEGIN
489 FillChar (Rec, RECORDSIZE, 0);
490 StrLCopy (TH.Name, PChar (DirRec.Name), NAMSIZ);
491 Mode := 0;
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, PChar (DirRec.LinkName), NAMSIZ);
526 StrLCopy (TH.Magic, PChar (DirRec.Magic + #32#32#32#32#32#32#32#32), 8);
527 StrLCopy (TH.UName, PChar (DirRec.UserName), TUNMLEN);
528 StrLCopy (TH.GName, PChar (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
TTarArchive.FindNextnull583 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 := Trim (ExtractText (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
TTarArchive.ReadFilenull707 FUNCTION TTarArchive.ReadFile : STRING;
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 (PChar (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
TTarWriter.AddFilenull790 FUNCTION TTarWriter.AddFile (Filename : STRING; TarFilename : STRING = '') : BOOLEAN;
791 VAR
792 S : TFileStream;
793 Date : TDateTime;
794 BEGIN
795 AddFile:=false;
796 Date := FileTimeGMT (Filename);
797 IF TarFilename = '' THEN
798 TarFilename := ConvertFilename (Filename);
799 TRY
800 S := TFileStream.Create (Filename, fmOpenRead OR fmShareDenyWrite);
801 EXCEPT
802 ON EFOpenError DO
803 BEGIN
804 Writeln(stderr,'LibTar error: unable to open file "',Filename,'" for reading.');
805 exit;
806 END;
807 END;
808
809 TRY
810 AddStream (S, TarFilename, Date);
811 // No error, AddFile succeeded
812 AddFile:=true;
813 FINALLY
814 S.Free
815 END;
816 END;
817
818
819 PROCEDURE TTarWriter.AddStream (Stream : TStream; TarFilename : STRING; FileDateGmt : TDateTime);
820 VAR
821 DirRec : TTarDirRec;
822 Rec : ARRAY [0..RECORDSIZE-1] OF CHAR;
823 BytesToRead : INT64; // Bytes to read from the Source Stream
824 BlockSize : INT64; // Bytes to write out for the current record
825 BEGIN
826 ClearDirRec (DirRec);
827 DirRec.Name := TarFilename;
828 DirRec.Size := Stream.Size - Stream.Position;
829 DirRec.DateTime := FileDateGmt;
830 DirRec.Permissions := FPermissions;
831 DirRec.FileType := ftNormal;
832 DirRec.LinkName := '';
833 DirRec.UID := FUID;
834 DirRec.GID := FGID;
835 DirRec.UserName := FUserName;
836 DirRec.GroupName := FGroupName;
837 DirRec.ChecksumOK := TRUE;
838 DirRec.Mode := FMode;
839 DirRec.Magic := FMagic;
840 DirRec.MajorDevNo := 0;
841 DirRec.MinorDevNo := 0;
842
843 WriteTarHeader (FStream, DirRec);
844 BytesToRead := DirRec.Size;
845 WHILE BytesToRead > 0 DO BEGIN
846 BlockSize := BytesToRead;
847 IF BlockSize > RECORDSIZE THEN BlockSize := RECORDSIZE;
848 FillChar (Rec, RECORDSIZE, 0);
849 Stream.Read (Rec, BlockSize);
850 FStream.Write (Rec, RECORDSIZE);
851 DEC (BytesToRead, BlockSize);
852 END;
853 END;
854
855
856 PROCEDURE TTarWriter.AddString (Contents : STRING; TarFilename : STRING; FileDateGmt : TDateTime);
857 VAR
858 S : TStringStream;
859 BEGIN
860 S := TStringStream.Create (Contents);
861 TRY
862 AddStream (S, TarFilename, FileDateGmt);
863 FINALLY
864 S.Free
865 END
866 END;
867
868
869 PROCEDURE TTarWriter.AddDir (Dirname : STRING; DateGmt : TDateTime; MaxDirSize : INT64 = 0);
870 VAR
871 DirRec : TTarDirRec;
872 BEGIN
873 ClearDirRec (DirRec);
874 DirRec.Name := Dirname;
875 DirRec.Size := MaxDirSize;
876 DirRec.DateTime := DateGmt;
877 DirRec.Permissions := FPermissions;
878 DirRec.FileType := ftDirectory;
879 DirRec.LinkName := '';
880 DirRec.UID := FUID;
881 DirRec.GID := FGID;
882 DirRec.UserName := FUserName;
883 DirRec.GroupName := FGroupName;
884 DirRec.ChecksumOK := TRUE;
885 DirRec.Mode := FMode;
886 DirRec.Magic := FMagic;
887 DirRec.MajorDevNo := 0;
888 DirRec.MinorDevNo := 0;
889
890 WriteTarHeader (FStream, DirRec);
891 END;
892
893
894 PROCEDURE TTarWriter.AddSymbolicLink (Filename, Linkname : STRING; DateGmt : TDateTime);
895 VAR
896 DirRec : TTarDirRec;
897 BEGIN
898 ClearDirRec (DirRec);
899 DirRec.Name := Filename;
900 DirRec.Size := 0;
901 DirRec.DateTime := DateGmt;
902 DirRec.Permissions := FPermissions;
903 DirRec.FileType := ftSymbolicLink;
904 DirRec.LinkName := Linkname;
905 DirRec.UID := FUID;
906 DirRec.GID := FGID;
907 DirRec.UserName := FUserName;
908 DirRec.GroupName := FGroupName;
909 DirRec.ChecksumOK := TRUE;
910 DirRec.Mode := FMode;
911 DirRec.Magic := FMagic;
912 DirRec.MajorDevNo := 0;
913 DirRec.MinorDevNo := 0;
914
915 WriteTarHeader (FStream, DirRec);
916 END;
917
918
919 PROCEDURE TTarWriter.AddLink (Filename, Linkname : STRING; DateGmt : TDateTime);
920 VAR
921 DirRec : TTarDirRec;
922 BEGIN
923 ClearDirRec (DirRec);
924 DirRec.Name := Filename;
925 DirRec.Size := 0;
926 DirRec.DateTime := DateGmt;
927 DirRec.Permissions := FPermissions;
928 DirRec.FileType := ftLink;
929 DirRec.LinkName := Linkname;
930 DirRec.UID := FUID;
931 DirRec.GID := FGID;
932 DirRec.UserName := FUserName;
933 DirRec.GroupName := FGroupName;
934 DirRec.ChecksumOK := TRUE;
935 DirRec.Mode := FMode;
936 DirRec.Magic := FMagic;
937 DirRec.MajorDevNo := 0;
938 DirRec.MinorDevNo := 0;
939
940 WriteTarHeader (FStream, DirRec);
941 END;
942
943
944 PROCEDURE TTarWriter.AddVolumeHeader (VolumeId : STRING; DateGmt : TDateTime);
945 VAR
946 DirRec : TTarDirRec;
947 BEGIN
948 ClearDirRec (DirRec);
949 DirRec.Name := VolumeId;
950 DirRec.Size := 0;
951 DirRec.DateTime := DateGmt;
952 DirRec.Permissions := FPermissions;
953 DirRec.FileType := ftVolumeHeader;
954 DirRec.LinkName := '';
955 DirRec.UID := FUID;
956 DirRec.GID := FGID;
957 DirRec.UserName := FUserName;
958 DirRec.GroupName := FGroupName;
959 DirRec.ChecksumOK := TRUE;
960 DirRec.Mode := FMode;
961 DirRec.Magic := FMagic;
962 DirRec.MajorDevNo := 0;
963 DirRec.MinorDevNo := 0;
964
965 WriteTarHeader (FStream, DirRec);
966 END;
967
968
969 PROCEDURE TTarWriter.Finalize;
970 // Writes the End-Of-File Tag
971 // Data after this tag will be ignored
972 // The destructor calls this automatically if you didn't do it before
973 VAR
974 Rec : ARRAY [0..RECORDSIZE-1] OF CHAR;
975 BEGIN
976 FillChar (Rec, SizeOf (Rec), 0);
977 FStream.Write (Rec, RECORDSIZE);
978 FFinalized := TRUE;
979 END;
980
981
982 END.
983
984