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