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