src/shared/dfzip.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 {$INCLUDE ../shared/a_modes.inc}
  17 unit dfzip;
  18
  19   (** Based on WadCvt tool **)
  20
  21 interface
  22
  23   uses SysUtils, Classes;
  24
  25   type
  26     TFileInfo = class
  27     public
  28       name: AnsiString;
  29       pkofs: Int64; // offset of file header
  30       size: Int64;
  31       pksize: Int64;
  32       crc: LongWord;
  33       method: Word;
  34
  35       constructor Create ();
  36     end;
  37
  38   function ZipOne (ds: TStream; fname: AnsiString; st: TStream; dopack: Boolean=true): TFileInfo;
  39   procedure writeCentralDir (ds: TStream; files: array of TFileInfo);
  40
  41 implementation
  42
  43   uses utils, xstreams, crc, paszlib, e_log;
  44
  45   const
  46     uni2wint: array [128..255] of Word = (
  47       $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
  48       $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
  49       $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
  50       $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
  51       $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
  52       $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
  53       $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
  54       $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
  55     );
  56
  57 constructor TFileInfo.Create;
  58 begin
  59   name := '';
  60   pkofs := 0;
  61   size := 0;
  62   pksize := 0;
  63   crc := crc32(0, nil, 0);
  64   method := 0;
  65 end;
  66
  67 function toUtf8 (const s: AnsiString): AnsiString;
  68 var
  69   uc: PUnicodeChar;
  70   xdc: PChar;
  71   pos, f: Integer;
  72 begin
  73   GetMem(uc, length(s)*8);
  74   GetMem(xdc, length(s)*8);
  75   try
  76     FillChar(uc^, length(s)*8, 0);
  77     FillChar(xdc^, length(s)*8, 0);
  78     pos := 0;
  79     for f := 1 to length(s) do
  80     begin
  81       if ord(s[f]) < 128 then
  82         uc[pos] := UnicodeChar(ord(s[f]))
  83       else
  84         uc[pos] := UnicodeChar(uni2wint[ord(s[f])]);
  85       Inc(pos);
  86     end;
  87     FillChar(xdc^, length(s)*8, 0);
  88     f := UnicodeToUtf8(xdc, length(s)*8, uc, pos);
  89     while (f > 0) and (xdc[f-1] = #0) do Dec(f);
  90     SetLength(result, f);
  91     Move(xdc^, result[1], f);
  92   finally
  93     FreeMem(xdc);
  94     FreeMem(uc);
  95   end;
  96 end;
  97
  98 // returs crc
  99 function zpack (ds: TStream; ss: TStream; var aborted: Boolean): LongWord;
 100 const
 101   IBSize = 65536;
 102   OBSize = 65536;
 103 var
 104   zst: TZStream;
 105   ib, ob: PByte;
 106   err: Integer;
 107   rd: Integer;
 108   eof: Boolean;
 109   crc: LongWord;
 110   dstp, srcsize: Int64;
 111 begin
 112   result := 0;
 113   //aborted := true; exit;
 114   aborted := false;
 115   crc := crc32(0, nil, 0);
 116   GetMem(ib, IBSize);
 117   GetMem(ob, OBSize);
 118   ss.position := 0;
 119   dstp := ds.position;
 120   srcsize := ss.size;
 121   try
 122     zst.next_out := ob;
 123     zst.avail_out := OBSize;
 124     zst.next_in := ib;
 125     zst.avail_in := 0;
 126     err := deflateInit2(zst, Z_BEST_COMPRESSION, Z_DEFLATED, -15, 9, 0);
 127     if err <> Z_OK then raise Exception.Create(zerror(err));
 128     try
 129       eof := false;
 130       repeat
 131         if zst.avail_in = 0 then
 132         begin
 133           // read input buffer part
 134           rd := ss.read(ib^, IBSize);
 135           if rd < 0 then raise Exception.Create('reading error');
 136           //writeln('  read ', rd, ' bytes');
 137           eof := (rd = 0);
 138           if rd <> 0 then begin crc := crc32(crc, Pointer(ib), rd); result := crc; end;
 139           zst.next_in := ib;
 140           zst.avail_in := rd;
 141         end;
 142         // now process the whole input
 143         while zst.avail_in > 0 do
 144         begin
 145           err := deflate(zst, Z_NO_FLUSH);
 146           if err <> Z_OK then raise Exception.Create(zerror(err));
 147           if zst.avail_out < OBSize then
 148           begin
 149             //writeln('  written ', OBSize-zst.avail_out, ' bytes');
 150             if ds.position+(OBSize-zst.avail_out)-dstp >= srcsize then
 151             begin
 152               // this will be overwritten anyway
 153               aborted := true;
 154               exit;
 155             end;
 156             ds.writeBuffer(ob^, OBSize-zst.avail_out);
 157             zst.next_out := ob;
 158             zst.avail_out := OBSize;
 159           end;
 160         end;
 161       until eof;
 162       // do leftovers
 163       while true do
 164       begin
 165         zst.avail_in := 0;
 166         err := deflate(zst, Z_FINISH);
 167         if (err <> Z_OK) and (err <> Z_STREAM_END) then raise Exception.Create(zerror(err));
 168         if zst.avail_out < OBSize then
 169         begin
 170           //writeln('  .written ', OBSize-zst.avail_out, ' bytes');
 171           if ds.position+(OBSize-zst.avail_out)-dstp >= srcsize then
 172           begin
 173             // this will be overwritten anyway
 174             aborted := true;
 175             exit;
 176           end;
 177           ds.writeBuffer(ob^, OBSize-zst.avail_out);
 178           zst.next_out := ob;
 179           zst.avail_out := OBSize;
 180         end;
 181         if err <> Z_OK then break;
 182       end;
 183       // succesfully flushed?
 184       if (err <> Z_STREAM_END) then raise Exception.Create(zerror(err));
 185     finally
 186       deflateEnd(zst);
 187     end;
 188   finally
 189     FreeMem(ob);
 190     FreeMem(ib);
 191   end;
 192 end;
 193
 194 // this will write "extra field length" and extra field itself
 195 {$IFDEF UTFEXTRA}
 196 const UtfFlags = 0;
 197
 198 type
 199   TByteArray = array of Byte;
 200
 201 function buildUtfExtra (fname: AnsiString): TByteArray;
 202 var
 203   crc: LongWord;
 204   fu: AnsiString;
 205   sz: Word;
 206 begin
 207   fu := toUtf8(fname);
 208   if fu = fname then begin result := nil; exit; end; // no need to write anything
 209   crc := crc32(0, @fname[1], length(fname));
 210   sz := 2+2+1+4+length(fu);
 211   SetLength(result, sz);
 212   result[0] := ord('u');
 213   result[1] := ord('p');
 214   Dec(sz, 4);
 215   result[2] := sz and $ff;
 216   result[3] := (sz shr 8) and $ff;
 217   result[4] := 1;
 218   result[5] := crc and $ff;
 219   result[6] := (crc shr 8) and $ff;
 220   result[7] := (crc shr 16) and $ff;
 221   result[8] := (crc shr 24) and $ff;
 222   Move(fu[1], result[9], length(fu));
 223 end;
 224 {$ELSE}
 225 const UtfFlags = (1 shl 10); // bit 11
 226 {$ENDIF}
 227
 228 function ZipOne (ds: TStream; fname: AnsiString; st: TStream; dopack: Boolean=true): TFileInfo;
 229 var
 230   oldofs, nfoofs, pkdpos, rd: Int64;
 231   sign: packed array [0..3] of Char;
 232   buf: PChar;
 233   bufsz: Integer;
 234   aborted: Boolean = false;
 235 {$IFDEF UTFEXTRA}
 236   ef: TByteArray;
 237 {$ENDIF}
 238 begin
 239   result := TFileInfo.Create();
 240   result.pkofs := ds.position;
 241   result.size := st.size;
 242   if result.size > 0 then result.method := 8 else result.method := 0;
 243   if not dopack then
 244   begin
 245     result.method := 0;
 246     result.pksize := result.size;
 247   end;
 248 {$IFDEF UTFEXTRA}
 249   result.name := fname;
 250   ef := buildUtfExtra(result.name);
 251 {$ELSE}
 252   result.name := toUtf8(fname);
 253 {$ENDIF}
 254   // write local header
 255   sign := 'PK'#3#4;
 256   ds.writeBuffer(sign, 4);
 257   writeInt(ds, Word($0A10)); // version to extract
 258   writeInt(ds, Word(UtfFlags)); // flags
 259   writeInt(ds, Word(result.method)); // compression method
 260   writeInt(ds, Word(0)); // file time
 261   writeInt(ds, Word(0)); // file date
 262   nfoofs := ds.position;
 263   writeInt(ds, LongWord(result.crc)); // crc32
 264   writeInt(ds, LongWord(result.pksize)); // packed size
 265   writeInt(ds, LongWord(result.size)); // unpacked size
 266   writeInt(ds, Word(length(fname))); // name length
 267 {$IFDEF UTFEXTRA}
 268   writeInt(ds, Word(length(ef))); // extra field length
 269 {$ELSE}
 270   writeInt(ds, Word(0)); // extra field length
 271 {$ENDIF}
 272   ds.writeBuffer(fname[1], length(fname));
 273 {$IFDEF UTFEXTRA}
 274   if length(ef) > 0 then ds.writeBuffer(ef[0], length(ef));
 275 {$ENDIF}
 276   if dopack then
 277   begin
 278     // now write packed data
 279     if result.size > 0 then
 280     begin
 281       pkdpos := ds.position;
 282       st.position := 0;
 283       result.crc := zpack(ds, st, aborted);
 284       result.pksize := ds.position-pkdpos;
 285       if {result.pksize >= result.size} aborted then
 286       begin
 287         // there's no sence to pack this file, so just store it
 288         st.position := 0;
 289         ds.position := result.pkofs;
 290         result.Free();
 291         // store it
 292         result := ZipOne(ds, fname, st, false);
 293         exit;
 294       end
 295       else
 296       begin
 297         // fix header
 298         oldofs := ds.position;
 299         ds.position := nfoofs;
 300         writeInt(ds, LongWord(result.crc)); // crc32
 301         writeInt(ds, LongWord(result.pksize)); // crc32
 302         ds.position := oldofs;
 303       end;
 304     end;
 305   end
 306   else
 307   begin
 308     bufsz := 1024*1024;
 309     GetMem(buf, bufsz);
 310     try
 311       st.position := 0;
 312       result.crc := crc32(0, nil, 0);
 313       result.pksize := 0;
 314       while result.pksize < result.size do
 315       begin
 316         rd := result.size-result.pksize;
 317         if rd > bufsz then rd := bufsz;
 318         st.readBuffer(buf^, rd);
 319         ds.writeBuffer(buf^, rd);
 320         Inc(result.pksize, rd);
 321         result.crc := crc32(result.crc, buf, rd);
 322       end;
 323     finally
 324       FreeMem(buf);
 325     end;
 326     // fix header
 327     oldofs := ds.position;
 328     ds.position := nfoofs;
 329     writeInt(ds, LongWord(result.crc)); // crc32
 330     ds.position := oldofs;
 331     write('(S) ');
 332   end;
 333 end;
 334
 335
 336 procedure writeCentralDir (ds: TStream; files: array of TFileInfo);
 337 var
 338   cdofs, cdend: Int64;
 339   sign: packed array [0..3] of Char;
 340   f: Integer;
 341 {$IFDEF UTFEXTRA}
 342   ef: TByteArray;
 343 {$ENDIF}
 344 begin
 345   cdofs := ds.position;
 346   for f := 0 to high(files) do
 347   begin
 348 {$IFDEF UTFEXTRA}
 349     ef := buildUtfExtra(files[f].name);
 350 {$ENDIF}
 351     sign := 'PK'#1#2;
 352     ds.writeBuffer(sign, 4);
 353     writeInt(ds, Word($0A10)); // version made by
 354     writeInt(ds, Word($0010)); // version to extract
 355     writeInt(ds, Word(UtfFlags)); // flags
 356     writeInt(ds, Word(files[f].method)); // compression method
 357     writeInt(ds, Word(0)); // file time
 358     writeInt(ds, Word(0)); // file date
 359     writeInt(ds, LongWord(files[f].crc));
 360     writeInt(ds, LongWord(files[f].pksize));
 361     writeInt(ds, LongWord(files[f].size));
 362     writeInt(ds, Word(length(files[f].name))); // name length
 363 {$IFDEF UTFEXTRA}
 364     writeInt(ds, Word(length(ef))); // extra field length
 365 {$ELSE}
 366     writeInt(ds, Word(0)); // extra field length
 367 {$ENDIF}
 368     writeInt(ds, Word(0)); // comment length
 369     writeInt(ds, Word(0)); // disk start
 370     writeInt(ds, Word(0)); // internal attributes
 371     writeInt(ds, LongWord(0)); // external attributes
 372     writeInt(ds, LongWord(files[f].pkofs)); // header offset
 373     ds.writeBuffer(files[f].name[1], length(files[f].name));
 374 {$IFDEF UTFEXTRA}
 375     if length(ef) > 0 then ds.writeBuffer(ef[0], length(ef));
 376 {$ENDIF}
 377   end;
 378   cdend := ds.position;
 379   // write end of central dir
 380   sign := 'PK'#5#6;
 381   ds.writeBuffer(sign, 4);
 382   writeInt(ds, Word(0)); // disk number
 383   writeInt(ds, Word(0)); // disk with central dir
 384   writeInt(ds, Word(length(files))); // number of files on this dist
 385   writeInt(ds, Word(length(files))); // number of files total
 386   writeInt(ds, LongWord(cdend-cdofs)); // size of central directory
 387   writeInt(ds, LongWord(cdofs)); // central directory offset
 388   writeInt(ds, Word(0)); // archive comment length
 389 end;
 390
 391 end.