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