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