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