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, pk3: PKZIP-compatible archives (store, deflate)
   7 //   dfwad   : D2D:F wad archives
   8 //
   9 {.$DEFINE SFS_DEBUG_ZIPFS}
  10 {$MODE DELPHI}
  11 {$R+}
  12 unit sfsZipFS;
  13
  14 interface
  15
  16 uses
  17   SysUtils, Classes, Contnrs, sfs;
  18
  19
  20 type
  21   TSFSZipVolumeType = (sfszvNone, sfszvZIP, sfszvDFWAD);
  22
  23   TSFSZipVolume = class(TSFSVolume)
  24   protected
  25     fType: TSFSZipVolumeType;
  26
  27     procedure ZIPReadDirectory ();
  28     procedure DFWADReadDirectory ();
  29
  30     procedure ReadDirectory (); override;
  31     procedure removeCommonPath (); override;
  32
  33   public
  34     function OpenFileByIndex (const index: Integer): TStream; override;
  35   end;
  36
  37   TSFSZipVolumeFactory = class(TSFSVolumeFactory)
  38   public
  39     function IsMyVolumePrefix (const prefix: AnsiString): Boolean; override;
  40     function Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume; override;
  41     procedure Recycle (vol: TSFSVolume); override;
  42   end;
  43
  44
  45 implementation
  46
  47 uses
  48   xstreams, utils;
  49
  50
  51 type
  52   TSFSZipFileInfo = class(TSFSFileInfo)
  53   public
  54     fMethod: Byte; // 0: store; 8: deflate; 255: other
  55     fPackSz: Int64; // can be -1
  56   end;
  57
  58   TZLocalFileHeader = packed record
  59     version: Byte;
  60     hostOS: Byte;
  61     flags: Word;
  62     method: Word;
  63     time: LongWord;
  64     crc: LongWord;
  65     packSz: LongWord;
  66     unpackSz: LongWord;
  67     fnameSz: Word;
  68     localExtraSz: Word;
  69   end;
  70
  71
  72 function ZIPCheckMagic (st: TStream): Boolean;
  73 var
  74   sign: packed array [0..3] of Char;
  75 begin
  76   result := false;
  77   st.ReadBuffer(sign[0], 4);
  78   st.Seek(-4, soCurrent);
  79   if (sign <> 'PK'#3#4) and (sign <> 'PK'#5#6) then exit;
  80   result := true;
  81 end;
  82
  83
  84 function DFWADCheckMagic (st: TStream): Boolean;
  85 var
  86   sign: packed array [0..5] of Char;
  87   fcnt: Word;
  88 begin
  89   result := false;
  90   if st.Size < 10 then exit;
  91   st.ReadBuffer(sign[0], 6);
  92   st.ReadBuffer(fcnt, 2);
  93   st.Seek(-8, soCurrent);
  94   //writeln('trying DFWAD... [', sign, ']');
  95   if (sign[0] <> 'D') and (sign[1] <> 'F') and (sign[2] <> 'W') and
  96      (sign[3] <> 'A') and (sign[4] <> 'D') and (sign[5] <> #$01) then exit;
  97   //writeln('DFWAD FOUND, with ', fcnt, ' files');
  98   //if (fcnt < 0) then exit;
  99   result := true;
 100 end;
 101
 102
 103 function maxPrefix (s0: string; s1: string): Integer;
 104 var
 105   f: Integer;
 106 begin
 107   for f := 1 to length(s0) do
 108   begin
 109     if f > length(s1) then begin result := f; exit; end;
 110     if UpCase1251(s0[f]) <> UpCase1251(s1[f]) then begin result := f; exit; end;
 111   end;
 112   result := length(s0);
 113 end;
 114
 115
 116 procedure TSFSZipVolume.removeCommonPath ();
 117 var
 118   f, pl, maxsc, sc, c: integer;
 119   cp, s: string;
 120   fi: TSFSZipFileInfo;
 121 begin
 122   if fType <> sfszvZIP then exit;
 123   maxsc := 0;
 124   if fFiles.Count = 0 then exit;
 125   cp := '';
 126   for f := 0 to fFiles.Count-1 do
 127   begin
 128     fi := TSFSZipFileInfo(fFiles[f]);
 129     s := fi.fPath;
 130     if length(s) > 0 then begin cp := s; break; end;
 131   end;
 132   if length(cp) = 0 then exit;
 133   for f := 0 to fFiles.Count-1 do
 134   begin
 135     fi := TSFSZipFileInfo(fFiles[f]);
 136     s := fi.fPath;
 137     if length(s) = 0 then continue;
 138     pl := maxPrefix(cp, s);
 139     //writeln('s=[', s, ']; cp=[', cp, ']; pl=', pl);
 140     if pl = 0 then exit; // no common prefix at all
 141     cp := Copy(cp, 1, pl);
 142     sc := 0;
 143     for c := 1 to length(s) do if s[c] = '/' then Inc(sc);
 144     if sc > maxsc then maxsc := sc;
 145   end;
 146   if maxsc < 2 then exit; // alas
 147   while (length(cp) > 0) and (cp[length(cp)] <> '/') do cp := Copy(cp, 1, length(cp)-1);
 148   if length(cp) < 2 then exit; // nothing to do
 149   for f := 0 to fFiles.Count-1 do
 150   begin
 151     fi := TSFSZipFileInfo(fFiles[f]);
 152     if length(fi.fPath) >= length(cp) then
 153     begin
 154       s := fi.fPath;
 155       fi.fPath := Copy(fi.fPath, length(cp)+1, length(fi.fPath));
 156       //writeln('FIXED [', s, '] -> [', fi.fPath, ']');
 157     end;
 158   end;
 159 end;
 160
 161
 162 { TSFSZipVolume }
 163 procedure TSFSZipVolume.ZIPReadDirectory ();
 164 var
 165   fi: TSFSZipFileInfo;
 166   name: ShortString;
 167   sign, dSign: packed array [0..3] of Char;
 168   lhdr: TZLocalFileHeader;
 169   ignoreFile, skipped: Boolean;
 170   crc, psz, usz: LongWord;
 171   buf: packed array of Byte;
 172   bufPos, bufUsed: Integer;
 173   efid, efsz: Word;
 174   izver: Byte;
 175   izcrc: LongWord;
 176 begin
 177   SetLength(buf, 0);
 178   // read local directory
 179   repeat
 180     fFileStream.ReadBuffer(sign[0], Length(sign));
 181
 182     if sign <> 'PK'#3#4 then break;
 183
 184     ignoreFile := false;
 185     skipped := false;
 186
 187     fi := TSFSZipFileInfo.Create(self);
 188     fi.fPackSz := 0;
 189     fi.fMethod := 0;
 190
 191     //fi.fOfs := fFileStream.Position;
 192
 193     fFileStream.ReadBuffer(lhdr, SizeOf(lhdr));
 194     if lhdr.fnameSz > 255 then name[0] := #255 else name[0] := chr(lhdr.fnameSz);
 195     fFileStream.ReadBuffer(name[1], Length(name));
 196     fFileStream.Seek(lhdr.fnameSz-Length(name), soCurrent); // rest of the name (if any)
 197     fi.fName := utf8to1251(name);
 198     //writeln(Format('0x%08x : %s', [Integer(fi.fOfs), name]));
 199
 200     // here we should process extra field: it may contain utf8 filename
 201     //fFileStream.Seek(lhdr.localExtraSz, soCurrent);
 202     while lhdr.localExtraSz >= 4 do
 203     begin
 204       efid := 0;
 205       efsz := 0;
 206       fFileStream.ReadBuffer(efid, 2);
 207       fFileStream.ReadBuffer(efsz, 2);
 208       Dec(lhdr.localExtraSz, 4);
 209       if efsz > lhdr.localExtraSz then break;
 210       // Info-ZIP Unicode Path Extra Field?
 211       if (efid = $7075) and (efsz <= 255+5) and (efsz > 5) then
 212       begin
 213         fFileStream.ReadBuffer(izver, 1);
 214         if izver <> 1 then
 215         begin
 216           // skip it
 217           Dec(efsz, 1);
 218         end
 219         else
 220         begin
 221           Dec(lhdr.localExtraSz, efsz);
 222           fFileStream.ReadBuffer(izcrc, 4); // name crc, ignore it
 223           Dec(efsz, 5);
 224           name[0] := chr(efsz);
 225           fFileStream.ReadBuffer(name[1], Length(name));
 226           fi.fName := utf8to1251(name);
 227           break;
 228         end;
 229       end;
 230       // skip it
 231       if efsz > 0 then
 232       begin
 233         fFileStream.Seek(efsz, soCurrent);
 234         Dec(lhdr.localExtraSz, efsz);
 235       end;
 236     end;
 237     // skip the rest
 238     if lhdr.localExtraSz > 0 then fFileStream.Seek(lhdr.localExtraSz, soCurrent);
 239
 240     if (lhdr.flags and 1) <> 0 then
 241     begin
 242       // encrypted file: skip it
 243       ignoreFile := true;
 244     end;
 245
 246     if (lhdr.method <> 0) and (lhdr.method <> 8) then
 247     begin
 248       // not stored. not deflated. skip.
 249       ignoreFile := true;
 250     end;
 251
 252     fi.fOfs := fFileStream.Position;
 253     fi.fSize := lhdr.unpackSz;
 254     fi.fPackSz := lhdr.packSz;
 255     fi.fMethod := lhdr.method;
 256
 257     if (lhdr.flags and (1 shl 3)) <> 0 then
 258     begin
 259       // it has a descriptor. stupid thing at all...
 260       {$IFDEF SFS_DEBUG_ZIPFS}
 261       WriteLn(ErrOutput, 'descr: $', IntToHex(fFileStream.Position, 8));
 262       WriteLn(ErrOutput, 'size: ', lhdr.unpackSz);
 263       WriteLn(ErrOutput, 'psize: ', lhdr.packSz);
 264       {$ENDIF}
 265       skipped := true;
 266
 267       if lhdr.packSz <> 0 then
 268       begin
 269         // some kind of idiot already did our work (maybe paritally)
 270         // trust him (her? %-)
 271         fFileStream.Seek(lhdr.packSz, soCurrent);
 272       end;
 273
 274       // scan for descriptor
 275       if Length(buf) = 0 then SetLength(buf, 65536);
 276       bufPos := 0; bufUsed := 0;
 277       fFileStream.ReadBuffer(dSign[0], 4);
 278       repeat
 279         if dSign <> 'PK'#7#8 then
 280         begin
 281           // skip one byte
 282           Move(dSign[1], dSign[0], 3);
 283           if bufPos >= bufUsed then
 284           begin
 285             bufPos := 0;
 286             // int64!
 287             if fFileStream.Size-fFileStream.Position > Length(buf) then bufUsed := Length(buf)
 288             else bufUsed := fFileStream.Size-fFileStream.Position;
 289             if bufUsed = 0 then raise ESFSError.Create('invalid ZIP file');
 290             fFileStream.ReadBuffer(buf[0], bufUsed);
 291           end;
 292           dSign[3] := chr(buf[bufPos]); Inc(bufPos);
 293           Inc(lhdr.packSz);
 294           continue;
 295         end;
 296         // signature found: check if it is a real one
 297         // ???: make stronger check (for the correct following signature)?
 298         // sign, crc, packsize, unpacksize
 299         fFileStream.Seek(-bufUsed+bufPos, soCurrent); bufPos := 0; bufUsed := 0;
 300         fFileStream.ReadBuffer(crc, 4); // crc
 301         fFileStream.ReadBuffer(psz, 4); // packed size
 302         // is size correct?
 303         if psz = lhdr.packSz then
 304         begin
 305           // this is a real description. fuck it off
 306           fFileStream.ReadBuffer(usz, 4); // unpacked size
 307           break;
 308         end;
 309         // this is just a sequence of bytes
 310         fFileStream.Seek(-8, soCurrent);
 311         fFileStream.ReadBuffer(dSign[0], 4);
 312         Inc(lhdr.packSz, 4);
 313       until false;
 314       // store correct values
 315       fi.fSize := usz;
 316       fi.fPackSz := psz;
 317     end;
 318
 319     // skip packed data
 320     if not skipped then fFileStream.Seek(lhdr.packSz, soCurrent);
 321     if ignoreFile then fi.Free();
 322   until false;
 323
 324   if (sign <> 'PK'#1#2) and (sign <> 'PK'#5#6) then
 325   begin
 326     {$IFDEF SFS_DEBUG_ZIPFS}
 327     WriteLn(ErrOutput, 'end: $', IntToHex(fFileStream.Position, 8));
 328     WriteLn(ErrOutput, 'sign: $', sign[0], sign[1], '#', ord(sign[2]), '#', ord(sign[3]));
 329     {$ENDIF}
 330     raise ESFSError.Create('invalid .ZIP archive (no central dir)');
 331   end;
 332 end;
 333
 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     sfszvDFWAD: DFWADReadDirectory();
 388     else raise ESFSError.Create('invalid archive');
 389   end;
 390 end;
 391
 392 function TSFSZipVolume.OpenFileByIndex (const index: Integer): TStream;
 393 var
 394   rs: TStream;
 395 begin
 396   result := nil;
 397   rs := nil;
 398   if fFiles = nil then exit;
 399   if (index < 0) or (index >= fFiles.Count) or (fFiles[index] = nil) then exit;
 400   try
 401     if TSFSZipFileInfo(fFiles[index]).fMethod = 0 then
 402     begin
 403       result := TSFSPartialStream.Create(fFileStream, TSFSZipFileInfo(fFiles[index]).fOfs, TSFSZipFileInfo(fFiles[index]).fSize, false);
 404     end
 405     else
 406     begin
 407       rs := TSFSPartialStream.Create(fFileStream, TSFSZipFileInfo(fFiles[index]).fOfs, TSFSZipFileInfo(fFiles[index]).fPackSz, false);
 408       result := TUnZStream.Create(rs, TSFSZipFileInfo(fFiles[index]).fSize, true, (TSFSZipFileInfo(fFiles[index]).fMethod <> 255));
 409     end;
 410   except
 411     FreeAndNil(rs);
 412     result := nil;
 413     exit;
 414   end;
 415 end;
 416
 417
 418 { TSFSZipVolumeFactory }
 419 function TSFSZipVolumeFactory.IsMyVolumePrefix (const prefix: AnsiString): Boolean;
 420 begin
 421   result :=
 422     StrEquCI1251(prefix, 'zip') or
 423     StrEquCI1251(prefix, 'pk3') or
 424     StrEquCI1251(prefix, 'dfwad');
 425 end;
 426
 427 procedure TSFSZipVolumeFactory.Recycle (vol: TSFSVolume);
 428 begin
 429   vol.Free();
 430 end;
 431
 432 function TSFSZipVolumeFactory.Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume;
 433 var
 434   vt: TSFSZipVolumeType;
 435 begin
 436   vt := sfszvNone;
 437        if ZIPCheckMagic(st) then vt := sfszvZIP
 438   else if DFWADCheckMagic(st) then vt := sfszvDFWAD;
 439
 440   if vt <> sfszvNone then
 441   begin
 442     result := TSFSZipVolume.Create(fileName, st);
 443     TSFSZipVolume(result).fType := vt;
 444     try
 445       result.DoDirectoryRead();
 446     except {$IFDEF SFS_DEBUG_ZIPFS} on e: Exception do begin
 447       WriteLn(errOutput, 'ZIP ERROR: [', e.ClassName, ']: ', e.Message);
 448       {$ENDIF}
 449       FreeAndNil(result);
 450       raise;
 451       {$IFDEF SFS_DEBUG_ZIPFS}end;{$ENDIF}
 452     end;
 453   end
 454   else
 455   begin
 456     result := nil;
 457   end;
 458 end;
 459
 460
 461 var
 462   zipf: TSFSZipVolumeFactory;
 463 initialization
 464   zipf := TSFSZipVolumeFactory.Create();
 465   SFSRegisterVolumeFactory(zipf);
 466 //finalization
 467 //  SFSUnregisterVolumeFactory(zipf);
 468 end.