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