2
0

libtar.pas 33 KB

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