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