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 MAPDEF in '../shared/MAPDEF.pas',
45 CONFIG in '../shared/CONFIG.pas',
46 e_log in '../engine/e_log.pas',
47 ImagingTypes, Imaging, ImagingUtility;
50 {.$WARNINGS ON}
51 {.$NOTES ON}
52 {.$HINTS ON}
54 var
55 optConvertATX: Boolean = false;
56 optConvertTGA: Boolean = false;
57 optLoCaseNames: Boolean = false;
58 optAggressivePng: Boolean = false;
59 optRecompress: Boolean = false;
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;
84 wadSt.position := 0;
85 buflen := Integer(wadSt.size);
86 GetMem(buf, buflen);
87 try
88 wadSt.ReadBuffer(buf^, buflen);
90 WAD := TWADFile.Create();
91 //WAD.ReadFile(wadName);
92 WAD.ReadMemory(buf, buflen);
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;
101 try
102 cfg := TConfig.CreateMem(TextData, ResLength);
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;
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;
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;
124 if (_framecount < 1) or (_framecount > 1024) then
125 begin
126 writeln('invalid frame count: ', _framecount);
127 exit;
128 end;
130 cfg.Free();
131 cfg := nil;
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;
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)');
147 WAD.Free();
148 WAD := nil;
150 // now create animation frames
151 GlobalMetadata.ClearMetaItems();
152 GlobalMetadata.ClearMetaItemsForSaving();
154 GlobalMetadata.SetMetaItem(SMetaFrameDelay, _speed*28);
155 if _backanimation then
156 GlobalMetadata.SetMetaItem(SMetaAnimationLoops, 1)
157 else
158 GlobalMetadata.SetMetaItem(SMetaAnimationLoops, 0);
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);
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;
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;
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;
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;
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;
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;
383 procedure TProg.onFileStart (sender: TObject; const fileName: AnsiString);
384 begin
385 lastname := fileName;
386 putStr(Format('compressing %-33s %3d%%', [lastname, 0]));
387 end;
389 procedure TProg.onFileEnd (sender: TObject; const ratio: double);
390 begin
391 putStr(Format('compressed %-33s %f', [lastname, ratio]), true);
392 end;
393 }
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;
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;
516 constructor Create ();
517 end;
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;
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 );
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;
574 // this will write "extra field length" and extra field itself
575 {$IFDEF UTFEXTRA}
576 const UtfFlags = 0;
578 type
579 TByteArray = array of Byte;
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}
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;
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;
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;
791 Imaging.SetOption(ImagingPNGCompressLevel, 9);
792 Imaging.SetOption(ImagingPNGLoadAnimated, 1);
793 Imaging.SetOption(ImagingGIFLoadAnimated, 1);
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;
837 if not StrEquCI1251(ExtractFileExt(infname), '.wad') and not StrEquCI1251(ExtractFileExt(infname), '.dfwad') then
838 begin
839 writeln('wtf?!');
840 Halt(1);
841 end;
843 if length(outfname) = 0 then outfname := ChangeFileExt(infname, '.pk3');
845 if not SFSAddDataFile(infname) then begin WriteLn('shit!'); Halt(1); end;
846 dvfn := SFSGetLastVirtualName(infname);
848 files := nil;
850 fl := SFSFileList(dvfn);
851 if fl = nil then
852 begin
853 writeln('wtf?!');
854 Halt(1);
855 end;
857 {$IFNDEF WINDOWS}
858 optLoCaseNames := true;
859 {$ENDIF}
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.