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