src/tools/wadcvt.dpr

   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 {$MODE OBJFPC}
  16 {$IFDEF WINDOWS}
  17   {$APPTYPE CONSOLE}
  18 {$ENDIF}
  19 {$DEFINE UTFEXTRA}
  20 {.$DEFINE ONELINELOG}
  21
  22 {$IFDEF WINDOWS}
  23   {$UNDEF ONELINELOG}
  24 {$ENDIF}
  25 program __wadcvt__;
  26
  27 uses
  28   SysUtils,
  29   Classes,
  30   {$I ../shared/vampimg.inc}
  31   mempool in '../shared/mempool.pas',
  32   utils in '../shared/utils.pas',
  33   xstreams in '../shared/xstreams.pas',
  34   xparser in '../shared/xparser.pas',
  35   xdynrec in '../shared/xdynrec.pas',
  36   crc,
  37   sfs in '../sfs/sfs.pas',
  38   sfsPlainFS in '../sfs/sfsPlainFS.pas',
  39   sfsZipFS in '../sfs/sfsZipFS.pas',
  40   paszlib,
  41   wadreader in '../shared/wadreader.pas',
  42   hashtable in '../shared/hashtable.pas',
  43   conbuf in '../shared/conbuf.pas',
  44   MAPDEF in '../shared/MAPDEF.pas',
  45   CONFIG in '../shared/CONFIG.pas',
  46   e_log in '../engine/e_log.pas';
  47
  48
  49 {.$WARNINGS ON}
  50 {.$NOTES ON}
  51 {.$HINTS ON}
  52
  53 var
  54   optConvertATX: Boolean = false;
  55   optConvertTGA: Boolean = false;
  56   optLoCaseNames: Boolean = false;
  57   optAggressivePng: Boolean = false;
  58   optRecompress: Boolean = false;
  59
  60
  61 function convertAnimTexture (wadSt: TStream; wadName: AnsiString): TMemoryStream;
  62 var
  63   WAD: TWADFile = nil;
  64   TextureWAD: PChar = nil;
  65   TextData: Pointer = nil;
  66   TextureData: Pointer = nil;
  67   cfg: TConfig = nil;
  68   ResLength: Integer;
  69   TextureResource: String;
  70   _width, _height, _framecount, _speed: Integer;
  71   _backanimation: Boolean;
  72   ia: TDynImageDataArray = nil;
  73   f: Integer;
  74   img: TImageData;
  75   x, y, ofsx, ofsy, nx, ny: Integer;
  76   clr: TColor32Rec;
  77   sto: TMemoryStream = nil;
  78   buf: PChar;
  79   buflen: Integer;
  80 begin
  81   result := nil;
  82
  83   wadSt.position := 0;
  84   buflen := Integer(wadSt.size);
  85   GetMem(buf, buflen);
  86   try
  87     wadSt.ReadBuffer(buf^, buflen);
  88
  89     WAD := TWADFile.Create();
  90     //WAD.ReadFile(wadName);
  91     WAD.ReadMemory(buf, buflen);
  92
  93     // ×èòàåì INI-ðåñóðñ àíèì. òåêñòóðû è çàïîìèíàåì åãî óñòàíîâêè:
  94     if not WAD.GetResource('TEXT/ANIM', TextData, ResLength) then
  95     begin
  96       writeln(Format('Animated texture file "%s" has invalid INI', [wadName]));
  97       exit;
  98     end;
  99
 100     try
 101       cfg := TConfig.CreateMem(TextData, ResLength);
 102
 103       TextureResource := cfg.ReadStr('', 'resource', '');
 104       if TextureResource = '' then
 105       begin
 106         writeln(Format('Animated texture WAD file "%s" has no "resource"', [wadName]));
 107         exit;
 108       end;
 109
 110       _width := cfg.ReadInt('', 'framewidth', 0);
 111       _height := cfg.ReadInt('', 'frameheight', 0);
 112       _framecount := cfg.ReadInt('', 'framecount', 0);
 113       _speed := cfg.ReadInt('', 'waitcount', 0);
 114       _backanimation := cfg.ReadBool('', 'backanimation', False);
 115       if _speed < 0 then _speed := 0;
 116
 117       if (_width < 1) or (_width > 16383) or (_height < 1) or (_height > 16383) then
 118       begin
 119         writeln('invalid animation dimensions: ', _width, 'x', _height);
 120         exit;
 121       end;
 122
 123       if (_framecount < 1) or (_framecount > 1024) then
 124       begin
 125         writeln('invalid frame count: ', _framecount);
 126         exit;
 127       end;
 128
 129       cfg.Free();
 130       cfg := nil;
 131
 132       // ×èòàåì ðåñóðñ òåêñòóð (êàäðîâ) àíèì. òåêñòóðû â ïàìÿòü:
 133       if not WAD.GetResource('TEXTURES/'+TextureResource, TextureData, ResLength) then
 134       begin
 135         writeln(Format('Animated texture WAD file "%s" has no texture "%s"', [wadName, 'TEXTURES/'+TextureResource]));
 136         exit;
 137       end;
 138
 139       if not LoadImageFromMemory(TextureData, ResLength, img) then
 140       begin
 141         writeln(Format('Animated texture file "%s" has invalid texture image', [wadName]));
 142         exit;
 143       end;
 144       //writeln('texture image: ', img.width, 'x', img.height, ' (', img.width div _width, ' frames)');
 145
 146       WAD.Free();
 147       WAD := nil;
 148
 149       // now create animation frames
 150       GlobalMetadata.ClearMetaItems();
 151       GlobalMetadata.ClearMetaItemsForSaving();
 152
 153       GlobalMetadata.SetMetaItem(SMetaFrameDelay, _speed*28);
 154       if _backanimation then
 155         GlobalMetadata.SetMetaItem(SMetaAnimationLoops, 1)
 156       else
 157         GlobalMetadata.SetMetaItem(SMetaAnimationLoops, 0);
 158
 159       SetLength(ia, _framecount);
 160       //writeln('creating ', length(ia), ' animation frames...');
 161       for f := 0 to high(ia) do
 162       begin
 163         GlobalMetadata.SetMetaItem(SMetaFrameDelay, _speed*28, f);
 164         if _backanimation then
 165           GlobalMetadata.SetMetaItem(SMetaAnimationLoops, 1, f)
 166         else
 167           GlobalMetadata.SetMetaItem(SMetaAnimationLoops, 0, f);
 168
 169         InitImage(ia[f]);
 170         NewImage(_width, _height, TImageFormat.ifA8R8G8B8, ia[f]);
 171         ofsx := f*_width;
 172         ofsy := 0;
 173         for y := 0 to _height-1 do
 174         begin
 175           for x := 0 to _width-1 do
 176           begin
 177             nx := ofsx+x;
 178             ny := ofsy+y;
 179             if (nx >= 0) and (ny >= 0) and (nx < img.width) and (ny < img.height) then
 180             begin
 181               clr := GetPixel32(img, nx, ny);
 182             end
 183             else
 184             begin
 185               clr.r := 0;
 186               clr.g := 0;
 187               clr.b := 0;
 188               clr.a := 0;
 189             end;
 190             SetPixel32(ia[f], x, y, clr);
 191           end;
 192         end;
 193         //writeln('resizing image...');
 194         //ResizeImage(ia[f], 320, 200, TResizeFilter.rfNearest);
 195       end;
 196       GlobalMetadata.CopyLoadedMetaItemsForSaving;
 197
 198       sto := TMemoryStream.Create();
 199       //writeln(' ... [', ChangeFileExt(wadName, '.png'), '] (', length(ia), ') ');
 200       Imaging.SetOption(ImagingPNGCompressLevel, 9);
 201       if optAggressivePng then Imaging.SetOption(ImagingPNGPreFilter, 6);
 202       if SaveMultiImageToStream('png', sto, ia) then
 203       begin
 204         sto.position := 0;
 205         result := sto;
 206         sto := nil;
 207       end
 208       else
 209       begin
 210         //writeln(' ...WTF?!');
 211       end;
 212     finally
 213       FreeImage(img);
 214     end;
 215   finally
 216     for f := 0 to High(ia) do FreeImage(ia[f]);
 217     WAD.Free();
 218     cfg.Free();
 219     if TextureWAD <> nil then FreeMem(TextureWAD);
 220     if TextData <> nil then FreeMem(TextData);
 221     if TextureData <> nil then FreeMem(TextureData);
 222     sto.Free();
 223     FreeMem(buf);
 224   end;
 225 end;
 226
 227
 228 function recompressImageToPng (ist: TStream): TStream;
 229 var
 230   ia: TDynImageDataArray = nil;
 231   sto: TMemoryStream = nil;
 232   f: Integer;
 233 begin
 234   result := nil;
 235   ist.position := 0;
 236   GlobalMetadata.ClearMetaItems();
 237   GlobalMetadata.ClearMetaItemsForSaving();
 238   if not LoadMultiImageFromStream(ist, ia) then exit;
 239   try
 240     GlobalMetadata.CopyLoadedMetaItemsForSaving;
 241     sto := TMemoryStream.Create();
 242     Imaging.SetOption(ImagingPNGCompressLevel, 9);
 243     if optAggressivePng then Imaging.SetOption(ImagingPNGPreFilter, 6);
 244     if SaveMultiImageToStream('png', sto, ia) then
 245     begin
 246       sto.position := 0;
 247       result := sto;
 248       sto := nil;
 249     end;
 250   finally
 251     sto.Free();
 252     for f := 0 to High(ia) do FreeImage(ia[f]);
 253   end;
 254 end;
 255
 256
 257 // returs crc
 258 function zpack (ds: TStream; ss: TStream; var aborted: Boolean): LongWord;
 259 const
 260   IBSize = 65536;
 261   OBSize = 65536;
 262 var
 263   zst: TZStream;
 264   ib, ob: PByte;
 265   err: Integer;
 266   rd: Integer;
 267   eof: Boolean;
 268   crc: LongWord;
 269   dstp, srcsize: Int64;
 270 begin
 271   result := 0;
 272   //aborted := true; exit;
 273   aborted := false;
 274   crc := crc32(0, nil, 0);
 275   GetMem(ib, IBSize);
 276   GetMem(ob, OBSize);
 277   ss.position := 0;
 278   dstp := ds.position;
 279   srcsize := ss.size;
 280   try
 281     zst.next_out := ob;
 282     zst.avail_out := OBSize;
 283     zst.next_in := ib;
 284     zst.avail_in := 0;
 285     err := deflateInit2(zst, Z_BEST_COMPRESSION, Z_DEFLATED, -15, 9, 0);
 286     if err <> Z_OK then raise Exception.Create(zerror(err));
 287     try
 288       eof := false;
 289       repeat
 290         if zst.avail_in = 0 then
 291         begin
 292           // read input buffer part
 293           rd := ss.read(ib^, IBSize);
 294           if rd < 0 then raise Exception.Create('reading error');
 295           //writeln('  read ', rd, ' bytes');
 296           eof := (rd = 0);
 297           if rd <> 0 then begin crc := crc32(crc, Pointer(ib), rd); result := crc; end;
 298           zst.next_in := ib;
 299           zst.avail_in := rd;
 300         end;
 301         // now process the whole input
 302         while zst.avail_in > 0 do
 303         begin
 304           err := deflate(zst, Z_NO_FLUSH);
 305           if err <> Z_OK then raise Exception.Create(zerror(err));
 306           if zst.avail_out < OBSize then
 307           begin
 308             //writeln('  written ', OBSize-zst.avail_out, ' bytes');
 309             if ds.position+(OBSize-zst.avail_out)-dstp >= srcsize then
 310             begin
 311               // this will be overwritten anyway
 312               aborted := true;
 313               exit;
 314             end;
 315             ds.writeBuffer(ob^, OBSize-zst.avail_out);
 316             zst.next_out := ob;
 317             zst.avail_out := OBSize;
 318           end;
 319         end;
 320       until eof;
 321       // do leftovers
 322       while true do
 323       begin
 324         zst.avail_in := 0;
 325         err := deflate(zst, Z_FINISH);
 326         if (err <> Z_OK) and (err <> Z_STREAM_END) then raise Exception.Create(zerror(err));
 327         if zst.avail_out < OBSize then
 328         begin
 329           //writeln('  .written ', OBSize-zst.avail_out, ' bytes');
 330           if ds.position+(OBSize-zst.avail_out)-dstp >= srcsize then
 331           begin
 332             // this will be overwritten anyway
 333             aborted := true;
 334             exit;
 335           end;
 336           ds.writeBuffer(ob^, OBSize-zst.avail_out);
 337           zst.next_out := ob;
 338           zst.avail_out := OBSize;
 339         end;
 340         if err <> Z_OK then break;
 341       end;
 342       // succesfully flushed?
 343       if (err <> Z_STREAM_END) then raise Exception.Create(zerror(err));
 344     finally
 345       deflateEnd(zst);
 346     end;
 347   finally
 348     FreeMem(ob);
 349     FreeMem(ib);
 350   end;
 351 end;
 352
 353
 354 {
 355 procedure TProg.putStr (const s: AnsiString; newline: Boolean=false);
 356 begin
 357   write(#13, s);
 358   while lastlen > length(s) do
 359   begin
 360     write(' ');
 361     Dec(lastlen);
 362   end;
 363   if newline then
 364   begin
 365     writeln;
 366     lastlen := 0;
 367   end
 368   else
 369   begin
 370     lastlen := length(s);
 371   end;
 372 end;
 373
 374 procedure TProg.onProgress (sender: TObject; const percent: double);
 375 var
 376   prc: Integer;
 377 begin
 378   prc := trunc(percent*100.0);
 379   putStr(Format('compressing %-33s  %3d%%', [lastname, prc]));
 380 end;
 381
 382 procedure TProg.onFileStart (sender: TObject; const fileName: AnsiString);
 383 begin
 384   lastname := fileName;
 385   putStr(Format('compressing %-33s  %3d%%', [lastname, 0]));
 386 end;
 387
 388 procedure TProg.onFileEnd (sender: TObject; const ratio: double);
 389 begin
 390   putStr(Format('compressed  %-33s  %f', [lastname, ratio]), true);
 391 end;
 392 }
 393
 394
 395 // returns new file name
 396 function detectExt (fpath, fname: AnsiString; fs: TStream): AnsiString;
 397 var
 398   buf: PChar;
 399   buflen: Integer;
 400   f: Integer;
 401   st: string[24];
 402   img: string;
 403 begin
 404   result := fname;
 405   if length(ExtractFileExt(fname)) <> 0 then exit;
 406   if fs.size < 16 then exit;
 407   buflen := Integer(fs.size);
 408   GetMem(buf, buflen);
 409   try
 410     fs.ReadBuffer(buf^, buflen);
 411     // xm
 412     Move(buf^, (PChar(@st[1]))^, 16);
 413     st[0] := #16;
 414     if (st = 'Extended Module:') then
 415     begin
 416       result := result+'.xm';
 417       exit;
 418     end;
 419     if (buf[0] = 'D') and (buf[1] = 'F') and (buf[2] = 'W') and
 420        (buf[3] = 'A') and (buf[4] = 'D') and (buf[5] = #$1) then
 421     begin
 422       result := result+'.wad';
 423       exit;
 424     end;
 425     if (buf[0] = 'M') and (buf[1] = 'A') and (buf[2] = 'P') and (buf[3] = #$1) then
 426     begin
 427       result := result+'.dfmap';
 428       exit;
 429     end;
 430     if (buf[0] = 'M') and (buf[1] = 'T') and (buf[2] = 'h') and (buf[3] = 'd') then
 431     begin
 432       result := result+'.mid';
 433       exit;
 434     end;
 435     if (buf[0] = 'R') and (buf[1] = 'I') and (buf[2] = 'F') and (buf[3] = 'F') and
 436        (buf[8] = 'W') and (buf[9] = 'A') and (buf[10] = 'V') and (buf[11] = 'E') then
 437     begin
 438       result := result+'.wav';
 439       exit;
 440     end;
 441     // mp3 (stupid hack)
 442     for f := 0 to 128-6 do
 443     begin
 444       if (buf[f+0] = #$4) and (buf[f+1] = 'L') and
 445          (buf[f+2] = 'A') and (buf[f+3] = 'M') and
 446          (buf[f+4] = 'E') and (buf[f+5] = '3') then
 447       begin
 448         result := result+'.mp3';
 449         exit;
 450       end;
 451     end;
 452     // more mp3 hacks
 453     if (buf[0] = 'I') and (buf[1] = 'D') and (buf[2] = '3') and (buf[3] <= #4) then
 454     begin
 455       result := result+'.mp3';
 456       exit;
 457     end;
 458     if buflen > 128 then
 459     begin
 460       if (buf[buflen-128] = 'T') and (buf[buflen-127] = 'A') and (buf[buflen-126] = 'G') then
 461       begin
 462         result := result+'.mp3';
 463         exit;
 464       end;
 465     end;
 466     // targa (stupid hack; this "signature" is not required by specs)
 467     {
 468     if buflen >= 18 then
 469     begin
 470       Move((buf+buflen-18)^, (PChar(@st[1]))^, 16);
 471       st[0] := #16;
 472       if st = 'TRUEVISION-XFILE' then
 473       begin
 474         result := result+'.tga';
 475         exit;
 476       end;
 477     end;
 478     }
 479     // detect image format
 480     img := DetermineMemoryFormat(buf, buflen);
 481     if length(img) > 0 then
 482     begin
 483       result := result+'.'+img;
 484       exit;
 485     end;
 486     // check if this is text file
 487     if buflen > 16 then
 488     begin
 489       for f := 0 to buflen-1 do
 490       begin
 491         if buf[f] = #127 then exit;
 492         if buf[f] < #32 then
 493         begin
 494           if (buf[f] <> #9) and (buf[f] <> #10) and (buf[f] <> #13) then exit;
 495         end;
 496       end;
 497       result := result+'.txt';
 498     end;
 499   finally
 500     FreeMem(buf);
 501   end;
 502 end;
 503
 504
 505 type
 506   TFileInfo = class
 507   public
 508     name: AnsiString;
 509     pkofs: Int64; // offset of file header
 510     size: Int64;
 511     pksize: Int64;
 512     crc: LongWord;
 513     method: Word;
 514
 515     constructor Create ();
 516   end;
 517
 518 constructor TFileInfo.Create ();
 519 begin
 520   name := '';
 521   pkofs := 0;
 522   size := 0;
 523   pksize := 0;
 524   crc := crc32(0, nil, 0);
 525   method := 0;
 526 end;
 527
 528
 529 const
 530   uni2wint: array [128..255] of Word = (
 531     $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
 532     $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
 533     $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
 534     $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
 535     $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
 536     $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
 537     $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
 538     $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
 539   );
 540
 541
 542 function toUtf8 (const s: AnsiString): AnsiString;
 543 var
 544   uc: PUnicodeChar;
 545   xdc: PChar;
 546   pos, f: Integer;
 547 begin
 548   GetMem(uc, length(s)*8);
 549   GetMem(xdc, length(s)*8);
 550   try
 551     FillChar(uc^, length(s)*8, 0);
 552     FillChar(xdc^, length(s)*8, 0);
 553     pos := 0;
 554     for f := 1 to length(s) do
 555     begin
 556       if ord(s[f]) < 128 then
 557         uc[pos] := UnicodeChar(ord(s[f]))
 558       else
 559         uc[pos] := UnicodeChar(uni2wint[ord(s[f])]);
 560       Inc(pos);
 561     end;
 562     FillChar(xdc^, length(s)*8, 0);
 563     f := UnicodeToUtf8(xdc, length(s)*8, uc, pos);
 564     while (f > 0) and (xdc[f-1] = #0) do Dec(f);
 565     SetLength(result, f);
 566     Move(xdc^, result[1], f);
 567   finally
 568     FreeMem(xdc);
 569     FreeMem(uc);
 570   end;
 571 end;
 572
 573 // this will write "extra field length" and extra field itself
 574 {$IFDEF UTFEXTRA}
 575 const UtfFlags = 0;
 576
 577 type
 578   TByteArray = array of Byte;
 579
 580 function buildUtfExtra (fname: AnsiString): TByteArray;
 581 var
 582   crc: LongWord;
 583   fu: AnsiString;
 584   sz: Word;
 585 begin
 586   fu := toUtf8(fname);
 587   if fu = fname then begin result := nil; exit; end; // no need to write anything
 588   crc := crc32(0, @fname[1], length(fname));
 589   sz := 2+2+1+4+length(fu);
 590   SetLength(result, sz);
 591   result[0] := ord('u');
 592   result[1] := ord('p');
 593   Dec(sz, 4);
 594   result[2] := sz and $ff;
 595   result[3] := (sz shr 8) and $ff;
 596   result[4] := 1;
 597   result[5] := crc and $ff;
 598   result[6] := (crc shr 8) and $ff;
 599   result[7] := (crc shr 16) and $ff;
 600   result[8] := (crc shr 24) and $ff;
 601   Move(fu[1], result[9], length(fu));
 602 end;
 603 {$ELSE}
 604 const UtfFlags = (1 shl 10); // bit 11
 605 {$ENDIF}
 606
 607 function ZipOne (ds: TStream; fname: AnsiString; st: TStream; dopack: Boolean=true): TFileInfo;
 608 var
 609   oldofs, nfoofs, pkdpos, rd: Int64;
 610   sign: packed array [0..3] of Char;
 611   buf: PChar;
 612   bufsz: Integer;
 613   aborted: Boolean = false;
 614 {$IFDEF UTFEXTRA}
 615   ef: TByteArray;
 616 {$ENDIF}
 617 begin
 618   result := TFileInfo.Create();
 619   result.pkofs := ds.position;
 620   result.size := st.size;
 621   if result.size > 0 then result.method := 8 else result.method := 0;
 622   if not dopack then
 623   begin
 624     result.method := 0;
 625     result.pksize := result.size;
 626   end;
 627 {$IFDEF UTFEXTRA}
 628   result.name := fname;
 629   ef := buildUtfExtra(result.name);
 630 {$ELSE}
 631   result.name := toUtf8(fname);
 632 {$ENDIF}
 633   // write local header
 634   sign := 'PK'#3#4;
 635   ds.writeBuffer(sign, 4);
 636   writeInt(ds, Word($0A10)); // version to extract
 637   writeInt(ds, Word(UtfFlags)); // flags
 638   writeInt(ds, Word(result.method)); // compression method
 639   writeInt(ds, Word(0)); // file time
 640   writeInt(ds, Word(0)); // file date
 641   nfoofs := ds.position;
 642   writeInt(ds, LongWord(result.crc)); // crc32
 643   writeInt(ds, LongWord(result.pksize)); // packed size
 644   writeInt(ds, LongWord(result.size)); // unpacked size
 645   writeInt(ds, Word(length(fname))); // name length
 646 {$IFDEF UTFEXTRA}
 647   writeInt(ds, Word(length(ef))); // extra field length
 648 {$ELSE}
 649   writeInt(ds, Word(0)); // extra field length
 650 {$ENDIF}
 651   ds.writeBuffer(fname[1], length(fname));
 652 {$IFDEF UTFEXTRA}
 653   if length(ef) > 0 then ds.writeBuffer(ef[0], length(ef));
 654 {$ENDIF}
 655   if dopack then
 656   begin
 657     // now write packed data
 658     if result.size > 0 then
 659     begin
 660       pkdpos := ds.position;
 661       st.position := 0;
 662       result.crc := zpack(ds, st, aborted);
 663       result.pksize := ds.position-pkdpos;
 664       if {result.pksize >= result.size} aborted then
 665       begin
 666         // there's no sence to pack this file, so just store it
 667         st.position := 0;
 668         ds.position := result.pkofs;
 669         result.Free();
 670         // store it
 671         result := ZipOne(ds, fname, st, false);
 672         exit;
 673       end
 674       else
 675       begin
 676         // fix header
 677         oldofs := ds.position;
 678         ds.position := nfoofs;
 679         writeInt(ds, LongWord(result.crc)); // crc32
 680         writeInt(ds, LongWord(result.pksize)); // crc32
 681         ds.position := oldofs;
 682       end;
 683     end;
 684   end
 685   else
 686   begin
 687     bufsz := 1024*1024;
 688     GetMem(buf, bufsz);
 689     try
 690       st.position := 0;
 691       result.crc := crc32(0, nil, 0);
 692       result.pksize := 0;
 693       while result.pksize < result.size do
 694       begin
 695         rd := result.size-result.pksize;
 696         if rd > bufsz then rd := bufsz;
 697         st.readBuffer(buf^, rd);
 698         ds.writeBuffer(buf^, rd);
 699         Inc(result.pksize, rd);
 700         result.crc := crc32(result.crc, buf, rd);
 701       end;
 702     finally
 703       FreeMem(buf);
 704     end;
 705     // fix header
 706     oldofs := ds.position;
 707     ds.position := nfoofs;
 708     writeInt(ds, LongWord(result.crc)); // crc32
 709     ds.position := oldofs;
 710     write('(S) ');
 711   end;
 712 end;
 713
 714
 715 procedure writeCentralDir (ds: TStream; files: array of TFileInfo);
 716 var
 717   cdofs, cdend: Int64;
 718   sign: packed array [0..3] of Char;
 719   f: Integer;
 720 {$IFDEF UTFEXTRA}
 721   ef: TByteArray;
 722 {$ENDIF}
 723 begin
 724   cdofs := ds.position;
 725   for f := 0 to high(files) do
 726   begin
 727 {$IFDEF UTFEXTRA}
 728     ef := buildUtfExtra(files[f].name);
 729 {$ENDIF}
 730     sign := 'PK'#1#2;
 731     ds.writeBuffer(sign, 4);
 732     writeInt(ds, Word($0A10)); // version made by
 733     writeInt(ds, Word($0010)); // version to extract
 734     writeInt(ds, Word(UtfFlags)); // flags
 735     writeInt(ds, Word(files[f].method)); // compression method
 736     writeInt(ds, Word(0)); // file time
 737     writeInt(ds, Word(0)); // file date
 738     writeInt(ds, LongWord(files[f].crc));
 739     writeInt(ds, LongWord(files[f].pksize));
 740     writeInt(ds, LongWord(files[f].size));
 741     writeInt(ds, Word(length(files[f].name))); // name length
 742 {$IFDEF UTFEXTRA}
 743     writeInt(ds, Word(length(ef))); // extra field length
 744 {$ELSE}
 745     writeInt(ds, Word(0)); // extra field length
 746 {$ENDIF}
 747     writeInt(ds, Word(0)); // comment length
 748     writeInt(ds, Word(0)); // disk start
 749     writeInt(ds, Word(0)); // internal attributes
 750     writeInt(ds, LongWord(0)); // external attributes
 751     writeInt(ds, LongWord(files[f].pkofs)); // header offset
 752     ds.writeBuffer(files[f].name[1], length(files[f].name));
 753 {$IFDEF UTFEXTRA}
 754     if length(ef) > 0 then ds.writeBuffer(ef[0], length(ef));
 755 {$ENDIF}
 756   end;
 757   cdend := ds.position;
 758   // write end of central dir
 759   sign := 'PK'#5#6;
 760   ds.writeBuffer(sign, 4);
 761   writeInt(ds, Word(0)); // disk number
 762   writeInt(ds, Word(0)); // disk with central dir
 763   writeInt(ds, Word(length(files))); // number of files on this dist
 764   writeInt(ds, Word(length(files))); // number of files total
 765   writeInt(ds, LongWord(cdend-cdofs)); // size of central directory
 766   writeInt(ds, LongWord(cdofs)); // central directory offset
 767   writeInt(ds, Word(0)); // archive comment length
 768 end;
 769
 770
 771 var
 772   fs, fo, ast: TStream;
 773   fl: TSFSFileList;
 774   f, c: Integer;
 775   infname: AnsiString = '';
 776   outfname: AnsiString = '';
 777   dvfn: AnsiString;
 778   newname: AnsiString;
 779   files: array of TFileInfo;
 780   nfo: TFileInfo;
 781   nomoreopts: Boolean;
 782   arg: AnsiString;
 783 begin
 784   if ParamCount() < 1 then
 785   begin
 786     WriteLn('usage: wadcvt file.wad');
 787     Halt(1);
 788   end;
 789
 790   Imaging.SetOption(ImagingPNGCompressLevel, 9);
 791   Imaging.SetOption(ImagingPNGLoadAnimated, 1);
 792   Imaging.SetOption(ImagingGIFLoadAnimated, 1);
 793
 794   for f := 1 to ParamCount() do
 795   begin
 796     arg := ParamStr(f);
 797     if length(arg) = 0 then continue;
 798     if not nomoreopts and (arg[1] = '-') then
 799     begin
 800            if arg = '--apng' then optConvertATX := true
 801       else if arg = '--tga' then optConvertTGA := true
 802       else if arg = '--locase' then optLoCaseNames := true
 803       else if arg = '--nocase' then optLoCaseNames := false
 804       else if arg = '--aggressive' then begin optAggressivePng := true; Imaging.SetOption(ImagingPNGPreFilter, 6); end
 805       else if arg = '--recompress' then optRecompress := true
 806       else if (arg = '--help') or (arg = '-h') then
 807       begin
 808         writeln('usage: wadcvt [options] file.wad');
 809         writeln('options:');
 810         writeln('  --apng    convert animated textures to APNG format');
 811         writeln('  --tga     convert Targa images to PNG format');
 812 {$IFNDEF WINDOWS}
 813         writeln('  --locase  convert file names to lower case');
 814 {$ENDIF}
 815         Halt(1);
 816       end
 817       else if arg = '--' then nomoreopts := true
 818       else
 819       begin
 820         writeln('unknown option: "', arg, '"');
 821         Halt(1);
 822       end;
 823     end
 824     else
 825     begin
 826            if length(infname) = 0 then infname := arg
 827       else if length(outfname) = 0 then outfname := arg
 828       else
 829       begin
 830         writeln('FATAL: too many arguments!');
 831         Halt(1);
 832       end;
 833     end;
 834   end;
 835
 836   if not StrEquCI1251(ExtractFileExt(infname), '.wad') and not StrEquCI1251(ExtractFileExt(infname), '.dfwad') then
 837   begin
 838     writeln('wtf?!');
 839     Halt(1);
 840   end;
 841
 842   if length(outfname) = 0 then outfname := ChangeFileExt(infname, '.pk3');
 843
 844   if not SFSAddDataFile(infname) then begin WriteLn('shit!'); Halt(1); end;
 845   dvfn := SFSGetLastVirtualName(infname);
 846
 847   files := nil;
 848
 849   fl := SFSFileList(dvfn);
 850   if fl = nil then
 851   begin
 852     writeln('wtf?!');
 853     Halt(1);
 854   end;
 855
 856 {$IFNDEF WINDOWS}
 857   optLoCaseNames := true;
 858 {$ENDIF}
 859
 860   fo := TFileStream.Create(outfname, fmCreate);
 861   try
 862     for f := 0 to fl.Count-1 do
 863     begin
 864       if length(fl[f].fName) = 0 then continue;
 865       fs := SFSFileOpen(dvfn+'::'+fl[f].fPath+fl[f].fName);
 866       newname := detectExt(fl[f].fPath, fl[f].fName, fs);
 867       //fs.Free();
 868       //fs := SFSFileOpen(dvfn+'::'+fl[f].fPath+fl[f].fName);
 869       fs.position := 0;
 870 {$IFNDEF ONELINELOG}
 871       write(#13'[', f+1, '/', fl.Count, ']: ', fl[f].fPath, newname, '  ', fs.size, ' ... '#27'[K');
 872 {$ELSE}
 873       write('[', f+1, '/', fl.Count, ']: ', fl[f].fPath, newname, '  ', fs.size, ' ... ');
 874 {$ENDIF}
 875       //writeln(' : ', newname, ' : [', ExtractFileExt(newname), ']');
 876       if optConvertATX and (StrEquCI1251(ExtractFileExt(newname), '.dfwad') or StrEquCI1251(ExtractFileExt(newname), '.wad')) then
 877       begin
 878         //writeln('  ANIMTEXT!');
 879         ast := convertAnimTexture(fs, newname);
 880         if ast <> nil then
 881         begin
 882           fs.Free();
 883           fs := ast;
 884           newname := ChangeFileExt(newname, '.png');
 885 {$IFNDEF ONELINELOG}
 886           write('APNG ');
 887 {$ENDIF}
 888         end;
 889       end
 890       else if optRecompress or (optConvertTGA and (StrEquCI1251(ExtractFileExt(newname), '.tga') or StrEquCI1251(ExtractFileExt(newname), '.bmp'))) then
 891       begin
 892         ast := recompressImageToPng(fs);
 893         if ast <> nil then
 894         begin
 895           fs.Free();
 896           fs := ast;
 897           newname := ChangeFileExt(newname, '.png');
 898 {$IFNDEF ONELINELOG}
 899           write('PNG ');
 900 {$ENDIF}
 901         end;
 902         fs.position := 0;
 903       end;
 904       newname := fl[f].fPath+newname;
 905       if optLoCaseNames then for c := 1 to length(newname) do newname[c] := LoCase1251(newname[c]);
 906       nfo := ZipOne(fo, newname, fs);
 907       write(nfo.pksize, ' DONE');
 908 {$IFNDEF ONELINELOG}
 909       writeln;
 910 {$ENDIF}
 911       SetLength(files, length(files)+1);
 912       files[high(files)] := nfo;
 913     end;
 914 {$IFNDEF ONELINELOG}
 915     writeln(fl.Count, ' files processed.');
 916 {$ELSE}
 917     writeln(#13, fl.Count, ' files processed.'#27'[K');
 918 {$ENDIF}
 919     writeCentralDir(fo, files);
 920   except
 921     fo.Free();
 922     fo := nil;
 923     DeleteFile(outfname);
 924   end;
 925   if fo <> nil then fo.Free();
 926 end.