778f7a6a71edff90ebd478578122412b2fec5bfd
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}
22 {$IFDEF WINDOWS}
23 {$UNDEF ONELINELOG}
24 {$ENDIF}
25 program __wadcvt__;
27 uses
28 SysUtils,
29 Classes,
30 mempool in '../shared/mempool.pas',
31 utils in '../shared/utils.pas',
32 xstreams in '../shared/xstreams.pas',
33 xparser in '../shared/xparser.pas',
34 xdynrec in '../shared/xdynrec.pas',
35 crc,
36 sfs in '../sfs/sfs.pas',
37 sfsPlainFS in '../sfs/sfsPlainFS.pas',
38 sfsZipFS in '../sfs/sfsZipFS.pas',
39 paszlib,
40 wadreader in '../shared/wadreader.pas',
41 hashtable in '../shared/hashtable.pas',
42 conbuf in '../shared/conbuf.pas',
43 MAPDEF in '../shared/MAPDEF.pas',
44 CONFIG in '../shared/CONFIG.pas',
45 e_log in '../engine/e_log.pas',
46 ImagingTypes, Imaging, ImagingUtility;
49 {.$WARNINGS ON}
50 {.$NOTES ON}
51 {.$HINTS ON}
53 var
54 optConvertATX: Boolean = false;
55 optConvertTGA: Boolean = false;
56 optLoCaseNames: Boolean = false;
57 optAggressivePng: Boolean = false;
58 optRecompress: Boolean = false;
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;
83 wadSt.position := 0;
84 buflen := Integer(wadSt.size);
85 GetMem(buf, buflen);
86 try
87 wadSt.ReadBuffer(buf^, buflen);
89 WAD := TWADFile.Create();
90 //WAD.ReadFile(wadName);
91 WAD.ReadMemory(buf, buflen);
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;
100 try
101 cfg := TConfig.CreateMem(TextData, ResLength);
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;
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;
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;
123 if (_framecount < 1) or (_framecount > 1024) then
124 begin
125 writeln('invalid frame count: ', _framecount);
126 exit;
127 end;
129 cfg.Free();
130 cfg := nil;
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;
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)');
146 WAD.Free();
147 WAD := nil;
149 // now create animation frames
150 GlobalMetadata.ClearMetaItems();
151 GlobalMetadata.ClearMetaItemsForSaving();
153 GlobalMetadata.SetMetaItem(SMetaFrameDelay, _speed*28);
154 if _backanimation then
155 GlobalMetadata.SetMetaItem(SMetaAnimationLoops, 1)
156 else
157 GlobalMetadata.SetMetaItem(SMetaAnimationLoops, 0);
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);
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;
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;
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;
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;
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;
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;
382 procedure TProg.onFileStart (sender: TObject; const fileName: AnsiString);
383 begin
384 lastname := fileName;
385 putStr(Format('compressing %-33s %3d%%', [lastname, 0]));
386 end;
388 procedure TProg.onFileEnd (sender: TObject; const ratio: double);
389 begin
390 putStr(Format('compressed %-33s %f', [lastname, ratio]), true);
391 end;
392 }
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;
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;
515 constructor Create ();
516 end;
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;
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 );
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;
573 // this will write "extra field length" and extra field itself
574 {$IFDEF UTFEXTRA}
575 const UtfFlags = 0;
577 type
578 TByteArray = array of Byte;
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}
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;
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;
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;
790 Imaging.SetOption(ImagingPNGCompressLevel, 9);
791 Imaging.SetOption(ImagingPNGLoadAnimated, 1);
792 Imaging.SetOption(ImagingGIFLoadAnimated, 1);
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;
836 if not StrEquCI1251(ExtractFileExt(infname), '.wad') and not StrEquCI1251(ExtractFileExt(infname), '.dfwad') then
837 begin
838 writeln('wtf?!');
839 Halt(1);
840 end;
842 if length(outfname) = 0 then outfname := ChangeFileExt(infname, '.pk3');
844 if not SFSAddDataFile(infname) then begin WriteLn('shit!'); Halt(1); end;
845 dvfn := SFSGetLastVirtualName(infname);
847 files := nil;
849 fl := SFSFileList(dvfn);
850 if fl = nil then
851 begin
852 writeln('wtf?!');
853 Halt(1);
854 end;
856 {$IFNDEF WINDOWS}
857 optLoCaseNames := true;
858 {$ENDIF}
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.