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   //writeln('trying DFWAD... [', sign, ']');
 108   if (sign[0] <> 'D') and (sign[1] <> 'F') and (sign[2] <> 'W') and
 109      (sign[3] <> 'A') and (sign[4] <> 'D') and (sign[5] <> #$01) then exit;
 110   //writeln('DFWAD FOUND, with ', fcnt, ' files');
 111   //if (fcnt < 0) then exit;
 112   result := true;
 113 end;
 114
 115
 116 { TSFSZipVolume }
 117 procedure TSFSZipVolume.ZIPReadDirectory ();
 118 var
 119   fi: TSFSZipFileInfo;
 120   name: ShortString;
 121   sign: packed array [0..3] of Char;
 122   lhdr: TZLocalFileHeader;
 123   ignoreFile: Boolean;
 124   efid, efsz: Word;
 125   izver: Byte;
 126   izcrc: LongWord;
 127 begin
 128   // read local directory
 129   repeat
 130     fFileStream.ReadBuffer(sign[0], Length(sign));
 131
 132     // skip data descriptor
 133     if sign = 'PK'#7#8 then
 134     begin
 135       fFileStream.seek(3*4, soCurrent);
 136       continue;
 137     end;
 138
 139     if sign <> 'PK'#3#4 then break;
 140
 141     ignoreFile := false;
 142
 143     readLFH(fFileStream, lhdr);
 144
 145     fi := TSFSZipFileInfo.Create(self);
 146     fi.fPackSz := 0;
 147     fi.fMethod := 0;
 148
 149     if lhdr.fnameSz > 255 then name[0] := #255 else name[0] := chr(lhdr.fnameSz);
 150     fFileStream.ReadBuffer(name[1], Length(name));
 151     fFileStream.Seek(lhdr.fnameSz-Length(name), soCurrent); // rest of the name (if any)
 152     fi.fName := utf8to1251(name);
 153
 154     // here we should process extra field: it may contain utf8 filename
 155     while lhdr.localExtraSz >= 4 do
 156     begin
 157       efid := readWord(fFileStream);
 158       efsz := readWord(fFileStream);
 159       Dec(lhdr.localExtraSz, 4);
 160       if efsz > lhdr.localExtraSz then break;
 161       // Info-ZIP Unicode Path Extra Field?
 162       if (efid = $7075) and (efsz <= 255+5) and (efsz > 5) then
 163       begin
 164         fFileStream.ReadBuffer(izver, 1);
 165         if izver <> 1 then
 166         begin
 167           // skip it
 168           Dec(efsz, 1);
 169         end
 170         else
 171         begin
 172           Dec(lhdr.localExtraSz, efsz);
 173           fFileStream.ReadBuffer(izcrc, 4); // name crc, ignore it
 174           Dec(efsz, 5);
 175           name[0] := chr(efsz);
 176           fFileStream.ReadBuffer(name[1], Length(name));
 177           fi.fName := utf8to1251(name);
 178           break;
 179         end;
 180       end;
 181       // skip it
 182       if efsz > 0 then
 183       begin
 184         fFileStream.Seek(efsz, soCurrent);
 185         Dec(lhdr.localExtraSz, efsz);
 186       end;
 187     end;
 188     // skip the rest
 189     if lhdr.localExtraSz > 0 then fFileStream.Seek(lhdr.localExtraSz, soCurrent);
 190
 191     if (lhdr.flags and 1) <> 0 then
 192     begin
 193       // encrypted file: skip it
 194       ignoreFile := true;
 195     end;
 196
 197     if (lhdr.method <> 0) and (lhdr.method <> 8) then
 198     begin
 199       // not stored. not deflated. skip.
 200       ignoreFile := true;
 201     end;
 202
 203     fi.fOfs := fFileStream.Position;
 204     fi.fSize := lhdr.unpackSz;
 205     fi.fPackSz := lhdr.packSz;
 206     fi.fMethod := lhdr.method;
 207
 208     // skip packed data
 209     fFileStream.Seek(lhdr.packSz, soCurrent);
 210     if ignoreFile then fi.Free();
 211   until false;
 212   (*
 213   if (sign <> 'PK'#1#2) and (sign <> 'PK'#5#6) then
 214   begin
 215     {$IFDEF SFS_DEBUG_ZIPFS}
 216     WriteLn(ErrOutput, 'end: $', IntToHex(fFileStream.Position, 8));
 217     WriteLn(ErrOutput, 'sign: $', sign[0], sign[1], '#', ord(sign[2]), '#', ord(sign[3]));
 218     {$ENDIF}
 219     raise ESFSError.Create('invalid .ZIP archive (no central dir)');
 220   end;
 221   *)
 222 end;
 223
 224
 225 procedure TSFSZipVolume.DFWADReadDirectory ();
 226 // idiotic format
 227 var
 228   fcnt: Word;
 229   fi: TSFSZipFileInfo;
 230   f, c: Integer;
 231   fofs, fpksize: LongWord;
 232   curpath, fname: string;
 233   name: packed array [0..15] of Char;
 234 begin
 235   curpath := '';
 236   fFileStream.Seek(6, soCurrent); // skip signature
 237   fcnt := readWord(fFileStream);
 238   if fcnt = 0 then exit;
 239   // read files
 240   for f := 0 to fcnt-1 do
 241   begin
 242     fFileStream.ReadBuffer(name[0], 16);
 243     fofs := readLongWord(fFileStream);
 244     fpksize := readLongWord(fFileStream);
 245     c := 0;
 246     fname := '';
 247     while (c < 16) and (name[c] <> #0) do
 248     begin
 249       if name[c] = '\' then name[c] := '/'
 250       else if name[c] = '/' then name[c] := '_';
 251       fname := fname+name[c];
 252       Inc(c);
 253     end;
 254     // new directory?
 255     if (fofs = 0) and (fpksize = 0) then
 256     begin
 257       if length(fname) <> 0 then fname := fname+'/';
 258       curpath := fname;
 259       continue;
 260     end;
 261     if length(fname) = 0 then continue; // just in case
 262     //writeln('DFWAD: [', curpath, '] [', fname, '] at ', fofs, ', size ', fpksize);
 263     // create file record
 264     fi := TSFSZipFileInfo.Create(self);
 265     fi.fOfs := fofs;
 266     fi.fSize := -1;
 267     fi.fPackSz := fpksize;
 268     fi.fName := fname;
 269     fi.fPath := curpath;
 270     fi.fMethod := 255;
 271   end;
 272 end;
 273
 274 procedure TSFSZipVolume.ReadDirectory ();
 275 begin
 276   case fType of
 277     sfszvZIP: ZIPReadDirectory();
 278     sfszvDFWAD: DFWADReadDirectory();
 279     else raise ESFSError.Create('invalid archive');
 280   end;
 281 end;
 282
 283 function TSFSZipVolume.OpenFileByIndex (const index: Integer): TStream;
 284 var
 285   rs: TStream;
 286 begin
 287   result := nil;
 288   rs := nil;
 289   if fFiles = nil then exit;
 290   if (index < 0) or (index >= fFiles.Count) or (fFiles[index] = nil) then exit;
 291   try
 292     if TSFSZipFileInfo(fFiles[index]).fMethod = 0 then
 293     begin
 294       result := TSFSPartialStream.Create(fFileStream, TSFSZipFileInfo(fFiles[index]).fOfs, TSFSZipFileInfo(fFiles[index]).fSize, false);
 295     end
 296     else
 297     begin
 298       rs := TSFSPartialStream.Create(fFileStream, TSFSZipFileInfo(fFiles[index]).fOfs, TSFSZipFileInfo(fFiles[index]).fPackSz, false);
 299       result := TUnZStream.Create(rs, TSFSZipFileInfo(fFiles[index]).fSize, true, (TSFSZipFileInfo(fFiles[index]).fMethod <> 255));
 300     end;
 301   except
 302     FreeAndNil(rs);
 303     result := nil;
 304     exit;
 305   end;
 306 end;
 307
 308
 309 { TSFSZipVolumeFactory }
 310 function TSFSZipVolumeFactory.IsMyVolumePrefix (const prefix: AnsiString): Boolean;
 311 begin
 312   result :=
 313     StrEquCI1251(prefix, 'zip') or
 314     StrEquCI1251(prefix, 'pk3') or
 315     StrEquCI1251(prefix, 'dfwad');
 316 end;
 317
 318 procedure TSFSZipVolumeFactory.Recycle (vol: TSFSVolume);
 319 begin
 320   vol.Free();
 321 end;
 322
 323 function TSFSZipVolumeFactory.Produce (const prefix, fileName: AnsiString; st: TStream): TSFSVolume;
 324 var
 325   vt: TSFSZipVolumeType;
 326 begin
 327   vt := sfszvNone;
 328        if ZIPCheckMagic(st) then vt := sfszvZIP
 329   else if DFWADCheckMagic(st) then vt := sfszvDFWAD;
 330
 331   if vt <> sfszvNone then
 332   begin
 333     result := TSFSZipVolume.Create(fileName, st);
 334     TSFSZipVolume(result).fType := vt;
 335     try
 336       result.DoDirectoryRead();
 337     except {$IFDEF SFS_DEBUG_ZIPFS} on e: Exception do begin
 338       WriteLn(errOutput, 'ZIP ERROR: [', e.ClassName, ']: ', e.Message);
 339       {$ENDIF}
 340       FreeAndNil(result);
 341       raise;
 342       {$IFDEF SFS_DEBUG_ZIPFS}end;{$ENDIF}
 343     end;
 344   end
 345   else
 346   begin
 347     result := nil;
 348   end;
 349 end;
 350
 351
 352 var
 353   zipf: TSFSZipVolumeFactory;
 354 initialization
 355   zipf := TSFSZipVolumeFactory.Create();
 356   SFSRegisterVolumeFactory(zipf);
 357 //finalization
 358 //  SFSUnregisterVolumeFactory(zipf);
 359 end.