src/sfs/sfsZipFS.pas

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