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
  32   public
  33     function OpenFileByIndex (const index: Integer): TStream; override;
  34   end;
  35
  36   TSFSZipVolumeFactory = class(TSFSVolumeFactory)
  37   public
  38     function IsMyVolumePrefix (const prefix: AnsiString): Boolean; override;
  39     function Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume; override;
  40     procedure Recycle (vol: TSFSVolume); override;
  41   end;
  42
  43
  44 implementation
  45
  46 uses
  47   xstreams, utils;
  48
  49
  50 type
  51   TSFSZipFileInfo = class(TSFSFileInfo)
  52   public
  53     fMethod: Byte; // 0: store; 8: deflate; 255: other
  54     fPackSz: Int64; // can be -1
  55   end;
  56
  57   TZLocalFileHeader = packed record
  58     version: Byte;
  59     hostOS: Byte;
  60     flags: Word;
  61     method: Word;
  62     time: LongWord;
  63     crc: LongWord;
  64     packSz: LongWord;
  65     unpackSz: LongWord;
  66     fnameSz: Word;
  67     localExtraSz: Word;
  68   end;
  69
  70 procedure readLFH (st: TStream; var hdr: TZLocalFileHeader);
  71 {.$IFDEF ENDIAN_LITTLE}
  72 begin
  73   hdr.version := readByte(st);
  74   hdr.hostOS := readByte(st);
  75   hdr.flags := readWord(st);
  76   hdr.method := readWord(st);
  77   hdr.time := readLongWord(st);
  78   hdr.crc := readLongWord(st);
  79   hdr.packSz := readLongWord(st);
  80   hdr.unpackSz := readLongWord(st);
  81   hdr.fnameSz := readWord(st);
  82   hdr.localExtraSz := readWord(st);
  83 end;
  84
  85
  86 function ZIPCheckMagic (st: TStream): Boolean;
  87 var
  88   sign: packed array [0..3] of Char;
  89 begin
  90   result := false;
  91   st.ReadBuffer(sign[0], 4);
  92   st.Seek(-4, soCurrent);
  93   if (sign <> 'PK'#3#4) and (sign <> 'PK'#5#6) then exit;
  94   result := true;
  95 end;
  96
  97
  98 function DFWADCheckMagic (st: TStream): Boolean;
  99 var
 100   sign: packed array [0..5] of Char;
 101 begin
 102   result := false;
 103   if st.Size < 10 then exit;
 104   st.ReadBuffer(sign[0], 6);
 105   {fcnt :=} readWord(st);
 106   st.Seek(-8, soCurrent);
 107   if (sign[0] <> 'D') and (sign[1] <> 'F') and (sign[2] <> 'W') and
 108      (sign[3] <> 'A') and (sign[4] <> 'D') and (sign[5] <> #$01) then exit;
 109   result := true;
 110 end;
 111
 112
 113 { TSFSZipVolume }
 114 procedure TSFSZipVolume.ZIPReadDirectory ();
 115 var
 116   fi: TSFSZipFileInfo;
 117   fname: AnsiString = '';
 118   sign: packed array [0..3] of Char;
 119   lhdr: TZLocalFileHeader;
 120   ignoreFile: Boolean;
 121   efid, efsz: Word;
 122   izver: Byte;
 123   izcrc: LongWord;
 124   buf: PByte;
 125   bufsz, f: Integer;
 126   cdofs, hdrofs: Int64;
 127   cdsize: LongWord;
 128   fileOffsets: array of Int64 = nil;
 129   nameLen, extraLen, commentLen: Word;
 130   fileIdx: Integer = -1;
 131 begin
 132   // search for central dir pointer
 133   if fFileStream.size > 65636 then bufsz := 65636 else bufsz := fFileStream.size;
 134   fFileStream.position := fFileStream.size-bufsz;
 135   GetMem(buf, bufsz);
 136   cdofs := -1;
 137   cdsize := 0;
 138   try
 139     fFileStream.readBuffer(buf^, bufsz);
 140     for f := bufsz-16 downto 4 do
 141     begin
 142       if (buf[f-4] = ord('P')) and (buf[f-3] = ord('K')) and (buf[f-2] = 5) and (buf[f-1] = 6) then
 143       begin
 144         cdsize := LongWord(buf[f+8])+(LongWord(buf[f+9])<<8)+(LongWord(buf[f+10])<<16)+(LongWord(buf[f+11])<<24);
 145         cdofs := Int64(buf[f+12])+(Int64(buf[f+13])<<8)+(Int64(buf[f+14])<<16)+(Int64(buf[f+15])<<24);
 146         break;
 147       end;
 148     end;
 149   finally
 150     FreeMem(buf);
 151   end;
 152
 153   if (cdofs >= 0) and (cdsize > 0) then
 154   begin
 155     // wow, we got central directory! process it
 156     fFileStream.position := cdofs;
 157     while cdsize >= 4 do
 158     begin
 159       Dec(cdsize, 4);
 160       fFileStream.readBuffer(sign, 4);
 161       if sign = 'PK'#1#2 then
 162       begin
 163         if cdsize < 42 then break;
 164         Dec(cdsize, 42);
 165         // skip uninteresting fields
 166         fFileStream.seek(2+2+2+2+2+2+4+4+4, soCurrent);
 167         nameLen := readWord(fFileStream);
 168         extraLen := readWord(fFileStream);
 169         commentLen := readWord(fFileStream);
 170         // skip uninteresting fields
 171         fFileStream.seek(2+2+4, soCurrent);
 172         hdrofs := readLongWord(fFileStream);
 173         // now skip name, extra and comment
 174         if cdsize < nameLen+extraLen+commentLen then break;
 175         Dec(cdsize, nameLen+extraLen+commentLen);
 176         fFileStream.seek(nameLen+extraLen+commentLen, soCurrent);
 177         SetLength(fileOffsets, length(fileOffsets)+1);
 178         fileOffsets[high(fileOffsets)] := hdrofs;
 179         //writeln('file #', high(fileOffsets), ' found at ', hdrofs);
 180       end
 181       else if sign = 'PK'#7#8 then
 182       begin
 183         if cdsize < 3*4 then break;
 184         Dec(cdsize, 3*4);
 185         fFileStream.seek(3*4, soCurrent);
 186       end
 187       else
 188       begin
 189         break;
 190       end;
 191     end;
 192     if length(fileOffsets) = 0 then exit; // no files at all
 193     fileIdx := 0;
 194   end
 195   else
 196   begin
 197     fFileStream.position := 0;
 198   end;
 199
 200   // read local directory
 201   repeat
 202     if fileIdx >= 0 then
 203     begin
 204       if fileIdx > High(fileOffsets) then break;
 205       //writeln('reading file #', fileIdx, ' at ', fileOffsets[fileIdx]);
 206       fFileStream.position := fileOffsets[fileIdx];
 207       Inc(fileIdx);
 208     end;
 209
 210     while true do
 211     begin
 212       fFileStream.ReadBuffer(sign[0], Length(sign));
 213       // skip data descriptor
 214       if sign = 'PK'#7#8 then
 215       begin
 216         fFileStream.seek(3*4, soCurrent);
 217         continue;
 218       end;
 219       break;
 220     end;
 221     if sign <> 'PK'#3#4 then break;
 222
 223     ignoreFile := false;
 224
 225     readLFH(fFileStream, lhdr);
 226
 227     fi := TSFSZipFileInfo.Create(self);
 228     fi.fPackSz := 0;
 229     fi.fMethod := 0;
 230
 231     SetLength(fname, lhdr.fnameSz);
 232     if lhdr.fnameSz > 0 then
 233     begin
 234       fFileStream.ReadBuffer(fname[1], length(fname));
 235       fi.fName := utf8to1251(fname);
 236     end;
 237
 238     // here we should process extra field: it may contain utf8 filename
 239     while lhdr.localExtraSz >= 4 do
 240     begin
 241       efid := readWord(fFileStream);
 242       efsz := readWord(fFileStream);
 243       Dec(lhdr.localExtraSz, 4);
 244       if efsz > lhdr.localExtraSz then break;
 245       // Info-ZIP Unicode Path Extra Field?
 246       if (efid = $7075) and (efsz > 5) then
 247       begin
 248         fFileStream.ReadBuffer(izver, 1);
 249         Dec(efsz, 1);
 250         Dec(lhdr.localExtraSz, 1);
 251         if izver = 1 then
 252         begin
 253           //writeln('!!!!!!!!!!!!');
 254           Dec(lhdr.localExtraSz, efsz);
 255           fFileStream.ReadBuffer(izcrc, 4); // name crc, ignore it for now
 256           Dec(efsz, 4);
 257           SetLength(fname, efsz);
 258           if length(fname) > 0 then fFileStream.readBuffer(fname[1], length(fname));
 259           fi.fName := utf8to1251(fname);
 260           //writeln('++++++ [', fi.fName, ']');
 261           efsz := 0;
 262         end;
 263       end;
 264       // skip it
 265       if efsz > 0 then
 266       begin
 267         fFileStream.Seek(efsz, soCurrent);
 268         Dec(lhdr.localExtraSz, efsz);
 269       end;
 270     end;
 271     // skip the rest
 272     if lhdr.localExtraSz > 0 then fFileStream.Seek(lhdr.localExtraSz, soCurrent);
 273
 274     if (lhdr.flags and 1) <> 0 then
 275     begin
 276       // encrypted file: skip it
 277       ignoreFile := true;
 278     end;
 279
 280     if (lhdr.method <> 0) and (lhdr.method <> 8) then
 281     begin
 282       // not stored. not deflated. skip.
 283       ignoreFile := true;
 284     end;
 285
 286     if (length(fi.fName) = 0) or (fname[length(fi.fName)] = '/') or (fname[length(fi.fName)] = '\') then
 287     begin
 288       ignoreFile := true;
 289     end
 290     else
 291     begin
 292       for f := 1 to length(fi.fName) do if fi.fName[f] = '\' then fi.fName[f] := '/';
 293     end;
 294
 295     fi.fOfs := fFileStream.Position;
 296     fi.fSize := lhdr.unpackSz;
 297     fi.fPackSz := lhdr.packSz;
 298     fi.fMethod := lhdr.method;
 299     if fi.fMethod = 0 then fi.fPackSz := fi.fSize;
 300
 301     // skip packed data
 302     if fileIdx < 0 then fFileStream.Seek(lhdr.packSz, soCurrent);
 303     if ignoreFile then fi.Free();
 304   until false;
 305   (*
 306   if (sign <> 'PK'#1#2) and (sign <> 'PK'#5#6) then
 307   begin
 308     {$IFDEF SFS_DEBUG_ZIPFS}
 309     WriteLn(ErrOutput, 'end: $', IntToHex(fFileStream.Position, 8));
 310     WriteLn(ErrOutput, 'sign: $', sign[0], sign[1], '#', ord(sign[2]), '#', ord(sign[3]));
 311     {$ENDIF}
 312     raise ESFSError.Create('invalid .ZIP archive (no central dir)');
 313   end;
 314   *)
 315 end;
 316
 317
 318 procedure TSFSZipVolume.DFWADReadDirectory ();
 319 // idiotic format
 320 var
 321   fcnt: Word;
 322   fi: TSFSZipFileInfo;
 323   f, c: Integer;
 324   fofs, fpksize: LongWord;
 325   curpath, fname: string;
 326   name: packed array [0..15] of Char;
 327 begin
 328   curpath := '';
 329   fFileStream.Seek(6, soCurrent); // skip signature
 330   fcnt := readWord(fFileStream);
 331   if fcnt = 0 then exit;
 332   // read files
 333   for f := 0 to fcnt-1 do
 334   begin
 335     fFileStream.ReadBuffer(name[0], 16);
 336     fofs := readLongWord(fFileStream);
 337     fpksize := readLongWord(fFileStream);
 338     c := 0;
 339     fname := '';
 340     while (c < 16) and (name[c] <> #0) do
 341     begin
 342       if name[c] = '\' then name[c] := '/'
 343       else if name[c] = '/' then name[c] := '_';
 344       fname := fname+name[c];
 345       Inc(c);
 346     end;
 347     // new directory?
 348     if (fofs = 0) and (fpksize = 0) then
 349     begin
 350       if length(fname) <> 0 then fname := fname+'/';
 351       curpath := fname;
 352       continue;
 353     end;
 354     if length(fname) = 0 then continue; // just in case
 355     //writeln('DFWAD: [', curpath, '] [', fname, '] at ', fofs, ', size ', fpksize);
 356     // create file record
 357     fi := TSFSZipFileInfo.Create(self);
 358     fi.fOfs := fofs;
 359     fi.fSize := -1;
 360     fi.fPackSz := fpksize;
 361     fi.fName := fname;
 362     fi.fPath := curpath;
 363     fi.fMethod := 255;
 364   end;
 365 end;
 366
 367 procedure TSFSZipVolume.ReadDirectory ();
 368 begin
 369   case fType of
 370     sfszvZIP: ZIPReadDirectory();
 371     sfszvDFWAD: DFWADReadDirectory();
 372     else raise ESFSError.Create('invalid archive');
 373   end;
 374 end;
 375
 376 function TSFSZipVolume.OpenFileByIndex (const index: Integer): TStream;
 377 var
 378   rs: TStream;
 379 begin
 380   result := nil;
 381   rs := nil;
 382   if fFiles = nil then exit;
 383   if (index < 0) or (index >= fFiles.Count) or (fFiles[index] = nil) then exit;
 384   try
 385     if TSFSZipFileInfo(fFiles[index]).fMethod = 0 then
 386     begin
 387       result := TSFSPartialStream.Create(fFileStream, TSFSZipFileInfo(fFiles[index]).fOfs, TSFSZipFileInfo(fFiles[index]).fSize, false);
 388     end
 389     else
 390     begin
 391       rs := TSFSPartialStream.Create(fFileStream, TSFSZipFileInfo(fFiles[index]).fOfs, TSFSZipFileInfo(fFiles[index]).fPackSz, false);
 392       result := TUnZStream.Create(rs, TSFSZipFileInfo(fFiles[index]).fSize, true, (TSFSZipFileInfo(fFiles[index]).fMethod <> 255));
 393     end;
 394   except
 395     FreeAndNil(rs);
 396     result := nil;
 397     exit;
 398   end;
 399 end;
 400
 401
 402 { TSFSZipVolumeFactory }
 403 function TSFSZipVolumeFactory.IsMyVolumePrefix (const prefix: AnsiString): Boolean;
 404 begin
 405   result :=
 406     StrEquCI1251(prefix, 'zip') or
 407     StrEquCI1251(prefix, 'pk3') or
 408     StrEquCI1251(prefix, 'dfwad');
 409 end;
 410
 411 procedure TSFSZipVolumeFactory.Recycle (vol: TSFSVolume);
 412 begin
 413   vol.Free();
 414 end;
 415
 416 function TSFSZipVolumeFactory.Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume;
 417 var
 418   vt: TSFSZipVolumeType;
 419 begin
 420   vt := sfszvNone;
 421        if ZIPCheckMagic(st) then vt := sfszvZIP
 422   else if DFWADCheckMagic(st) then vt := sfszvDFWAD;
 423
 424   if vt <> sfszvNone then
 425   begin
 426     result := TSFSZipVolume.Create(fileName, st);
 427     TSFSZipVolume(result).fType := vt;
 428     try
 429       result.DoDirectoryRead();
 430     except {$IFDEF SFS_DEBUG_ZIPFS} on e: Exception do begin
 431       WriteLn(errOutput, 'ZIP ERROR: [', e.ClassName, ']: ', e.Message);
 432       {$ENDIF}
 433       FreeAndNil(result);
 434       raise;
 435       {$IFDEF SFS_DEBUG_ZIPFS}end;{$ENDIF}
 436     end;
 437   end
 438   else
 439   begin
 440     result := nil;
 441   end;
 442 end;
 443
 444
 445 var
 446   zipf: TSFSZipVolumeFactory;
 447 initialization
 448   zipf := TSFSZipVolumeFactory.Create();
 449   SFSRegisterVolumeFactory(zipf);
 450 //finalization
 451 //  SFSUnregisterVolumeFactory(zipf);
 452 end.