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