src/sfs/sfsZipFS.pas

   1 // Streaming R/O Virtual File System v0.2.0
   2 // Copyright (C) XL A.S. Ketmar.  All rights reserved
   3 // See the file aplicense.txt for conditions of use.
   4 //
   5 // grouping files with packing:
   6 //   zip, jar: PKZIP-compatible archives (store, deflate)
   7 //   fout2   : Fallout II .DAT
   8 //   vtdb    : Asphyre's VTDb
   9 //   dfwad   : D2D:F wad archives
  10 //
  11 {.$DEFINE SFS_DEBUG_ZIPFS}
  12 {$MODE DELPHI}
  13 {.$R-}
  14 unit sfsZipFS;
  15
  16 interface
  17
  18 uses
  19   SysUtils, Classes, Contnrs, sfs;
  20
  21
  22
  23 type
  24   TSFSZipVolumeType = (sfszvNone, sfszvZIP, sfszvF2DAT, sfszvVTDB, sfszvDFWAD);
  25
  26   TSFSZipVolume = class(TSFSVolume)
  27   protected
  28     fType: TSFSZipVolumeType;
  29
  30     procedure ZIPReadDirectory ();
  31     procedure F2DATReadDirectory ();
  32     procedure VTDBReadDirectory ();
  33     procedure DFWADReadDirectory ();
  34
  35     procedure ReadDirectory (); override;
  36     procedure removeCommonPath (); override;
  37
  38   public
  39     function OpenFileByIndex (const index: Integer): TStream; override;
  40   end;
  41
  42   TSFSZipVolumeFactory = class (TSFSVolumeFactory)
  43   public
  44     function IsMyVolumePrefix (const prefix: TSFSString): Boolean; override;
  45     function Produce (const prefix, fileName: TSFSString; st: TStream): TSFSVolume; override;
  46     procedure Recycle (vol: TSFSVolume); override;
  47   end;
  48
  49
  50
  51 implementation
  52
  53 uses
  54   zstream, xstreams;
  55
  56
  57 type
  58   TZDecompressionStream = TDecompressionStream;
  59
  60 type
  61   TSFSZipFileInfo = class (TSFSFileInfo)
  62   public
  63     fMethod: Byte; // 0: store; 8: deflate; 255: other
  64     fPackSz: Int64;
  65   end;
  66
  67   TZLocalFileHeader = packed record
  68     version: Byte;
  69     hostOS: Byte;
  70     flags: Word;
  71     method: Word;
  72     time: LongWord;
  73     crc: LongWord;
  74     packSz: LongWord;
  75     unpackSz: LongWord;
  76     fnameSz: Word;
  77     localExtraSz: Word;
  78   end;
  79
  80
  81 function ZIPCheckMagic (st: TStream): Boolean;
  82 var
  83   sign: packed array [0..3] of Char;
  84 begin
  85   result := false;
  86   st.ReadBuffer(sign[0], 4);
  87   st.Seek(-4, soCurrent);
  88   if (sign <> 'PK'#3#4) and (sign <> 'PK'#5#6) then exit;
  89   result := true;
  90 end;
  91
  92 function F2DATCheckMagic (st: TStream): Boolean;
  93 var
  94   dsize, fiSz: Integer;
  95 begin
  96   result := false;
  97   st.Position := st.Size-8;
  98   st.ReadBuffer(dsize, 4); st.ReadBuffer(fiSz, 4);
  99   st.Position := 0;
 100   if (fiSz <> st.Size) or (dsize < 5+13) or (dsize > fiSz-4) then exit;
 101   result := true;
 102 end;
 103
 104 function VTDBCheckMagic (st: TStream): Boolean;
 105 var
 106   sign: packed array [0..3] of Char;
 107   fcnt, dofs: Integer;
 108 begin
 109   result := false;
 110   if st.Size < 32 then exit;
 111   st.ReadBuffer(sign[0], 4);
 112   st.ReadBuffer(fcnt, 4); st.ReadBuffer(dofs, 4);
 113   st.Seek(-12, soCurrent);
 114   if sign <> 'vtdm' then exit;
 115   if (fcnt < 0) or (dofs < 32) or (dofs+fcnt*8 > st.Size) then exit;
 116   result := true;
 117 end;
 118
 119 function DFWADCheckMagic (st: TStream): Boolean;
 120 var
 121   sign: packed array [0..5] of Char;
 122   fcnt: Word;
 123 begin
 124   result := false;
 125   if st.Size < 10 then exit;
 126   st.ReadBuffer(sign[0], 6);
 127   st.ReadBuffer(fcnt, 2);
 128   st.Seek(-8, soCurrent);
 129   //writeln('trying DFWAD... [', sign, ']');
 130   if (sign[0] <> 'D') and (sign[1] <> 'F') and (sign[2] <> 'W') and
 131      (sign[3] <> 'A') and (sign[4] <> 'D') and (sign[5] <> #$01) then exit;
 132   //writeln('DFWAD FOUND, with ', fcnt, ' files');
 133   //if (fcnt < 0) then exit;
 134   result := true;
 135 end;
 136
 137 function maxPrefix (s0: string; s1: string): Integer;
 138 var
 139   f: Integer;
 140 begin
 141   for f := 1 to length(s0) do
 142   begin
 143     if f > length(s1) then begin result := f; exit; end;
 144     if SFSUpCase(s0[f]) <> SFSUpCase(s1[f]) then begin result := f; exit; end;
 145   end;
 146   result := length(s0);
 147 end;
 148
 149 procedure TSFSZipVolume.removeCommonPath ();
 150 var
 151   f, pl, maxsc, sc, c: integer;
 152   cp, s: string;
 153   fi: TSFSZipFileInfo;
 154 begin
 155   if fType <> sfszvZIP then exit;
 156   maxsc := 0;
 157   if fFiles.Count = 0 then exit;
 158   cp := '';
 159   for f := 0 to fFiles.Count-1 do
 160   begin
 161     fi := TSFSZipFileInfo(fFiles[f]);
 162     s := fi.fPath;
 163     if length(s) > 0 then begin cp := s; break; end;
 164   end;
 165   if length(cp) = 0 then exit;
 166   for f := 0 to fFiles.Count-1 do
 167   begin
 168     fi := TSFSZipFileInfo(fFiles[f]);
 169     s := fi.fPath;
 170     if length(s) = 0 then continue;
 171     pl := maxPrefix(cp, s);
 172     //writeln('s=[', s, ']; cp=[', cp, ']; pl=', pl);
 173     if pl = 0 then exit; // no common prefix at all
 174     cp := Copy(cp, 1, pl);
 175     sc := 0;
 176     for c := 1 to length(s) do if s[c] = '/' then Inc(sc);
 177     if sc > maxsc then maxsc := sc;
 178   end;
 179   if maxsc < 2 then exit; // alas
 180   while (length(cp) > 0) and (cp[length(cp)] <> '/') do cp := Copy(cp, 1, length(cp)-1);
 181   if length(cp) < 2 then exit; // nothing to do
 182   for f := 0 to fFiles.Count-1 do
 183   begin
 184     fi := TSFSZipFileInfo(fFiles[f]);
 185     if length(fi.fPath) >= length(cp) then
 186     begin
 187       s := fi.fPath;
 188       fi.fPath := Copy(fi.fPath, length(cp)+1, length(fi.fPath));
 189       //writeln('FIXED [', s, '] -> [', fi.fPath, ']');
 190     end;
 191   end;
 192 end;
 193
 194 { TSFSZipVolume }
 195 procedure TSFSZipVolume.ZIPReadDirectory ();
 196 var
 197   fi: TSFSZipFileInfo;
 198   name: ShortString;
 199   sign, dSign: packed array [0..3] of Char;
 200   lhdr: TZLocalFileHeader;
 201   ignoreFile, skipped: Boolean;
 202   crc, psz, usz: LongWord;
 203   buf: packed array of Byte;
 204   bufPos, bufUsed: Integer;
 205 begin
 206   SetLength(buf, 0);
 207   // read local directory
 208   repeat
 209     fFileStream.ReadBuffer(sign[0], Length(sign));
 210
 211     if sign <> 'PK'#3#4 then break;
 212
 213     ignoreFile := false;
 214     skipped := false;
 215
 216     fi := TSFSZipFileInfo.Create(self);
 217     fi.fPackSz := 0;
 218     fi.fMethod := 0;
 219
 220     fFileStream.ReadBuffer(lhdr, SizeOf(lhdr));
 221     if lhdr.fnameSz > 255 then name[0] := #255 else name[0] := chr(lhdr.fnameSz);
 222     fFileStream.ReadBuffer(name[1], Length(name));
 223     fFileStream.Seek(lhdr.fnameSz-Length(name), soCurrent); // rest of the name (if any)
 224     fi.fName := name;
 225     fFileStream.Seek(lhdr.localExtraSz, soCurrent);
 226
 227     if (lhdr.flags and 1) <> 0 then
 228     begin
 229       // encrypted file: skip it
 230       ignoreFile := true;
 231     end;
 232
 233     if (lhdr.method <> 0) and (lhdr.method <> 8) then
 234     begin
 235       // not stored. not deflated. skip.
 236       ignoreFile := true;
 237     end;
 238
 239     fi.fOfs := fFileStream.Position;
 240     fi.fSize := lhdr.unpackSz;
 241     fi.fPackSz := lhdr.packSz;
 242     fi.fMethod := lhdr.method;
 243
 244     if (lhdr.flags and (1 shl 3)) <> 0 then
 245     begin
 246       // it has a descriptor. stupid thing at all...
 247       {$IFDEF SFS_DEBUG_ZIPFS}
 248       WriteLn(ErrOutput, 'descr: $', IntToHex(fFileStream.Position, 8));
 249       WriteLn(ErrOutput, 'size: ', lhdr.unpackSz);
 250       WriteLn(ErrOutput, 'psize: ', lhdr.packSz);
 251       {$ENDIF}
 252       skipped := true;
 253
 254       if lhdr.packSz <> 0 then
 255       begin
 256         // some kind of idiot already did our work (maybe paritally)
 257         // trust him (her? %-)
 258         fFileStream.Seek(lhdr.packSz, soCurrent);
 259       end;
 260
 261       // scan for descriptor
 262       if Length(buf) = 0 then SetLength(buf, 65536);
 263       bufPos := 0; bufUsed := 0;
 264       fFileStream.ReadBuffer(dSign[0], 4);
 265       repeat
 266         if dSign <> 'PK'#7#8 then
 267         begin
 268           // skip one byte
 269           Move(dSign[1], dSign[0], 3);
 270           if bufPos >= bufUsed then
 271           begin
 272             bufPos := 0;
 273             // int64!
 274             if fFileStream.Size-fFileStream.Position > Length(buf) then
 275               bufUsed := Length(buf)
 276             else bufUsed := fFileStream.Size-fFileStream.Position;
 277             if bufUsed = 0 then raise ESFSError.Create('invalid ZIP file');
 278             fFileStream.ReadBuffer(buf[0], bufUsed);
 279           end;
 280           dSign[3] := chr(buf[bufPos]); Inc(bufPos);
 281           Inc(lhdr.packSz);
 282           continue;
 283         end;
 284         // signature found: check if it is a real one
 285         // ???: make stronger check (for the correct following signature)?
 286         // sign, crc, packsize, unpacksize
 287         fFileStream.Seek(-bufUsed+bufPos, soCurrent); bufPos := 0; bufUsed := 0;
 288         fFileStream.ReadBuffer(crc, 4); // crc
 289         fFileStream.ReadBuffer(psz, 4); // packed size
 290         // is size correct?
 291         if psz = lhdr.packSz then
 292         begin
 293           // this is a real description. fuck it off
 294           fFileStream.ReadBuffer(usz, 4); // unpacked size
 295           break;
 296         end;
 297         // this is just a sequence of bytes
 298         fFileStream.Seek(-8, soCurrent);
 299         fFileStream.ReadBuffer(dSign[0], 4);
 300         Inc(lhdr.packSz, 4);
 301       until false;
 302       // store correct values
 303       fi.fSize := usz;
 304       fi.fPackSz := psz;
 305     end;
 306
 307     // skip packed data
 308     if not skipped then fFileStream.Seek(lhdr.packSz, soCurrent);
 309     if ignoreFile then fi.Free();
 310   until false;
 311
 312   if (sign <> 'PK'#1#2) and (sign <> 'PK'#5#6) then
 313   begin
 314     {$IFDEF SFS_DEBUG_ZIPFS}
 315     WriteLn(ErrOutput, 'end: $', IntToHex(fFileStream.Position, 8));
 316     WriteLn(ErrOutput, 'sign: $', sign[0], sign[1], '#', ord(sign[2]), '#', ord(sign[3]));
 317     {$ENDIF}
 318     raise ESFSError.Create('invalid .ZIP archive (no central dir)');
 319   end;
 320 end;
 321
 322 procedure TSFSZipVolume.F2DATReadDirectory ();
 323 var
 324   dsize: Integer;
 325   fi: TSFSZipFileInfo;
 326   name: ShortString;
 327   f: Integer;
 328   b: Byte;
 329 begin
 330   fFileStream.Position := fFileStream.Size-8;
 331   fFileStream.ReadBuffer(dsize, 4);
 332   fFileStream.Seek(-dsize, soCurrent); Dec(dsize, 4);
 333   while dsize > 0 do
 334   begin
 335     fi := TSFSZipFileInfo.Create(self);
 336     fFileStream.ReadBuffer(f, 4);
 337     if (f < 1) or (f > 255) then raise ESFSError.Create('invalid Fallout II .DAT file');
 338     Dec(dsize, 4+f+13);
 339     if dsize < 0 then raise ESFSError.Create('invalid Fallout II .DAT file');
 340     name[0] := chr(f); if f > 0 then fFileStream.ReadBuffer(name[1], f);
 341     f := 1; while (f <= ord(name[0])) and (name[f] <> #0) do Inc(f); name[0] := chr(f-1);
 342     fi.fName := name;
 343     fFileStream.ReadBuffer(b, 1); // packed?
 344     if b = 0 then fi.fMethod := 0 else fi.fMethod := 255;
 345     fFileStream.ReadBuffer(fi.fSize, 4);
 346     fFileStream.ReadBuffer(fi.fPackSz, 4);
 347     fFileStream.ReadBuffer(fi.fOfs, 4);
 348   end;
 349 end;
 350
 351 procedure TSFSZipVolume.VTDBReadDirectory ();
 352 // idiotic format
 353 var
 354   fcnt, dofs: Integer;
 355   keys: array of record name: string; ofs: Integer; end;
 356   fi: TSFSZipFileInfo;
 357   f, c: Integer;
 358   rtype: Word;
 359 begin
 360   fFileStream.Seek(4, soCurrent); // skip signature
 361   fFileStream.ReadBuffer(fcnt, 4);
 362   fFileStream.ReadBuffer(dofs, 4);
 363   fFileStream.Seek(dofs, soBeginning);
 364
 365   // read keys
 366   SetLength(keys, fcnt);
 367   for f := 0 to fcnt-1 do
 368   begin
 369     fFileStream.ReadBuffer(c, 4);
 370     if (c < 0) or (c > 1023) then raise ESFSError.Create('invalid VTDB file');
 371     SetLength(keys[f].name, c);
 372     if c > 0 then
 373     begin
 374       fFileStream.ReadBuffer(keys[f].name[1], c);
 375       keys[f].name := SFSReplacePathDelims(keys[f].name, '/');
 376       if keys[f].name[1] = '/' then Delete(keys[f].name, 1, 1);
 377     end;
 378     fFileStream.ReadBuffer(keys[f].ofs, 4);
 379   end;
 380
 381   // read records (record type will be converted to directory name)
 382   for f := 0 to fcnt-1 do
 383   begin
 384     fFileStream.Position := keys[f].ofs;
 385     fi := TSFSZipFileInfo.Create(self);
 386     fFileStream.ReadBuffer(rtype, 2);
 387     fFileStream.ReadBuffer(fi.fSize, 4);
 388     fFileStream.ReadBuffer(fi.fPackSz, 4);
 389     fi.fOfs := fFileStream.Position+12;
 390     fi.fName := keys[f].name;
 391     fi.fPath := IntToHex(rtype, 4)+'/';
 392     fi.fMethod := 255;
 393   end;
 394 end;
 395
 396 procedure TSFSZipVolume.DFWADReadDirectory ();
 397 // idiotic format
 398 var
 399   fcnt: Word;
 400   fi: TSFSZipFileInfo;
 401   f, c, fofs, fpksize: Integer;
 402   curpath, fname: string;
 403   name: packed array [0..15] of Char;
 404 begin
 405   curpath := '';
 406   fFileStream.Seek(6, soCurrent); // skip signature
 407   fFileStream.ReadBuffer(fcnt, 2);
 408   if fcnt = 0 then exit;
 409   // read files
 410   for f := 0 to fcnt-1 do
 411   begin
 412     fFileStream.ReadBuffer(name[0], 16);
 413     fFileStream.ReadBuffer(fofs, 4);
 414     fFileStream.ReadBuffer(fpksize, 4);
 415     c := 0;
 416     fname := '';
 417     while (c < 16) and (name[c] <> #0) do
 418     begin
 419       if name[c] = '\' then name[c] := '/'
 420       else if name[c] = '/' then name[c] := '_';
 421       fname := fname+name[c];
 422       Inc(c);
 423     end;
 424     // new directory?
 425     if (fofs = 0) and (fpksize = 0) then
 426     begin
 427       if length(fname) <> 0 then fname := fname+'/';
 428       curpath := fname;
 429       continue;
 430     end;
 431     if length(fname) = 0 then continue; // just in case
 432     //writeln('DFWAD: [', curpath, '] [', fname, '] at ', fofs, ', size ', fpksize);
 433     // create file record
 434     fi := TSFSZipFileInfo.Create(self);
 435     fi.fOfs := fofs;
 436     fi.fSize := -1;
 437     fi.fPackSz := fpksize;
 438     fi.fName := fname;
 439     fi.fPath := curpath;
 440     fi.fMethod := 255;
 441   end;
 442 end;
 443
 444 procedure TSFSZipVolume.ReadDirectory ();
 445 begin
 446   case fType of
 447     sfszvZIP: ZIPReadDirectory();
 448     sfszvF2DAT: F2DATReadDirectory();
 449     sfszvVTDB: VTDBReadDirectory();
 450     sfszvDFWAD: DFWADReadDirectory();
 451     else raise ESFSError.Create('invalid zipped SFS');
 452   end;
 453 end;
 454
 455 function TSFSZipVolume.OpenFileByIndex (const index: Integer): TStream;
 456 var
 457   zs: TZDecompressionStream;
 458   fs: TStream;
 459   gs: TSFSGuardStream;
 460   kill: Boolean;
 461   buf: packed array [0..1023] of Char;
 462   rd: LongInt;
 463 begin
 464   result := nil;
 465   zs := nil;
 466   fs := nil;
 467   gs := nil;
 468   if fFiles = nil then exit;
 469   if (index < 0) or (index >= fFiles.Count) or (fFiles[index] = nil) then exit;
 470   kill := false;
 471   try
 472     {
 473     try
 474       fs := TFileStream.Create(fFileName, fmOpenRead or fmShareDenyWrite);
 475       kill := true;
 476     except
 477       fs := fFileStream;
 478     end;
 479     }
 480     fs := fFileStream;
 481     if TSFSZipFileInfo(fFiles[index]).fMethod = 0 then
 482     begin
 483       result := TSFSPartialStream.Create(fs,
 484         TSFSZipFileInfo(fFiles[index]).fOfs,
 485         TSFSZipFileInfo(fFiles[index]).fSize, kill);
 486     end
 487     else
 488     begin
 489       fs.Seek(TSFSZipFileInfo(fFiles[index]).fOfs, soBeginning);
 490       if TSFSZipFileInfo(fFiles[index]).fMethod = 255 then
 491       begin
 492         zs := TZDecompressionStream.Create(fs)
 493       end
 494       else
 495       begin
 496         zs := TZDecompressionStream.Create(fs, true {-15}{MAX_WBITS});
 497       end;
 498       // sorry, pals, DFWAD is completely broken, so users of it should SUFFER
 499       if TSFSZipFileInfo(fFiles[index]).fSize = -1 then
 500       begin
 501         TSFSZipFileInfo(fFiles[index]).fSize := 0;
 502         //writeln('trying to determine file size for [', TSFSZipFileInfo(fFiles[index]).fPath, TSFSZipFileInfo(fFiles[index]).fName, ']');
 503         try
 504           while true do
 505           begin
 506             rd := zs.read(buf, 1024);
 507             //writeln('  got ', rd, ' bytes');
 508             if rd > 0 then Inc(TSFSZipFileInfo(fFiles[index]).fSize, rd);
 509             if rd < 1024 then break;
 510           end;
 511           //writeln('  resulting size: ', TSFSZipFileInfo(fFiles[index]).fSize, ' bytes');
 512           // recreate stream
 513           FreeAndNil(zs);
 514           fs.Seek(TSFSZipFileInfo(fFiles[index]).fOfs, soBeginning);
 515           zs := TZDecompressionStream.Create(fs)
 516         except
 517           //writeln('*** CAN''T determine file size for [', TSFSZipFileInfo(fFiles[index]).fPath, TSFSZipFileInfo(fFiles[index]).fName, ']');
 518           FreeAndNil(zs);
 519           if kill then FreeAndNil(fs);
 520           result := nil;
 521           exit;
 522         end;
 523       end;
 524       gs := TSFSGuardStream.Create(zs, fs, true, kill, false);
 525       zs := nil;
 526       fs := nil;
 527       result := TSFSPartialStream.Create(gs, 0, TSFSZipFileInfo(fFiles[index]).fSize, true);
 528     end;
 529   except
 530     FreeAndNil(gs);
 531     FreeAndNil(zs);
 532     if kill then FreeAndNil(fs);
 533     result := nil;
 534     exit;
 535   end;
 536 end;
 537
 538
 539 { TSFSZipVolumeFactory }
 540 function TSFSZipVolumeFactory.IsMyVolumePrefix (const prefix: TSFSString): Boolean;
 541 begin
 542   result :=
 543     SFSStrEqu(prefix, 'zip') or
 544     SFSStrEqu(prefix, 'jar') or
 545     SFSStrEqu(prefix, 'fout2') or
 546     SFSStrEqu(prefix, 'vtdb') or
 547     SFSStrEqu(prefix, 'wad') or
 548     SFSStrEqu(prefix, 'dfwad');
 549 end;
 550
 551 procedure TSFSZipVolumeFactory.Recycle (vol: TSFSVolume);
 552 begin
 553   vol.Free();
 554 end;
 555
 556 function TSFSZipVolumeFactory.Produce (const prefix, fileName: TSFSString; st: TStream): TSFSVolume;
 557 var
 558   vt: TSFSZipVolumeType;
 559 begin
 560   vt := sfszvNone;
 561   if ZIPCheckMagic(st) then vt := sfszvZIP
 562   else if DFWADCheckMagic(st) then vt := sfszvDFWAD
 563   else if F2DATCheckMagic(st) then vt := sfszvF2DAT
 564   else if VTDBCheckMagic(st) then vt := sfszvVTDB;
 565
 566   if vt <> sfszvNone then
 567   begin
 568     result := TSFSZipVolume.Create(fileName, st);
 569     TSFSZipVolume(result).fType := vt;
 570     try
 571       result.DoDirectoryRead();
 572     except {$IFDEF SFS_DEBUG_ZIPFS} on e: Exception do begin
 573       WriteLn(errOutput, 'ZIP ERROR: [', e.ClassName, ']: ', e.Message);
 574       {$ENDIF}
 575       FreeAndNil(result);
 576       raise;
 577       {$IFDEF SFS_DEBUG_ZIPFS}end;{$ENDIF}
 578     end;
 579   end
 580   else
 581   begin
 582     result := nil;
 583   end;
 584 end;
 585
 586
 587 var
 588   zipf: TSFSZipVolumeFactory;
 589 initialization
 590   zipf := TSFSZipVolumeFactory.Create();
 591   SFSRegisterVolumeFactory(zipf);
 592 finalization
 593   SFSUnregisterVolumeFactory(zipf);
 594 end.