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