src/sfs/wadcvt.dpr

   1 {$MODE OBJFPC}
   2 {$IFDEF WINDOWS}
   3   {$APPTYPE CONSOLE}
   4 {$ENDIF}
   5 {$DEFINE UTFEXTRA}
   6 program __wadcvt__;
   7
   8 uses
   9   SysUtils,
  10   Classes,
  11   utils in '../shared/utils.pas',
  12   xstreams in '../shared/xstreams.pas',
  13   crc,
  14   sfs,
  15   sfsPlainFS,
  16   sfsZipFS,
  17   paszlib,
  18   ImagingTypes, Imaging, ImagingUtility;
  19
  20
  21 procedure processed (count: Cardinal);
  22 begin
  23   //writeln('  read ', count, ' bytes');
  24 end;
  25
  26
  27 // returs crc
  28 function zpack (ds: TStream; ss: TStream; var aborted: Boolean): LongWord;
  29 const
  30   IBSize = 65536;
  31   OBSize = 65536;
  32 var
  33   zst: TZStream;
  34   ib, ob: PByte;
  35   err: Integer;
  36   rd: Integer;
  37   eof: Boolean;
  38   crc: LongWord;
  39   dstp, srcsize: Int64;
  40 begin
  41   result := 0;
  42   //aborted := true; exit;
  43   aborted := false;
  44   crc := crc32(0, nil, 0);
  45   GetMem(ib, IBSize);
  46   GetMem(ob, OBSize);
  47   ss.position := 0;
  48   dstp := ds.position;
  49   srcsize := ss.size;
  50   try
  51     zst.next_out := ob;
  52     zst.avail_out := OBSize;
  53     zst.next_in := ib;
  54     zst.avail_in := 0;
  55     err := deflateInit2(zst, Z_BEST_COMPRESSION, Z_DEFLATED, -15, 9, 0);
  56     if err <> Z_OK then raise Exception.Create(zerror(err));
  57     try
  58       eof := false;
  59       repeat
  60         if zst.avail_in = 0 then
  61         begin
  62           // read input buffer part
  63           rd := ss.read(ib^, IBSize);
  64           if rd < 0 then raise Exception.Create('reading error');
  65           //writeln('  read ', rd, ' bytes');
  66           eof := (rd = 0);
  67           if rd <> 0 then begin crc := crc32(crc, Pointer(ib), rd); result := crc; end;
  68           zst.next_in := ib;
  69           zst.avail_in := rd;
  70         end;
  71         // now process the whole input
  72         while zst.avail_in > 0 do
  73         begin
  74           err := deflate(zst, Z_NO_FLUSH);
  75           if err <> Z_OK then raise Exception.Create(zerror(err));
  76           if zst.avail_out < OBSize then
  77           begin
  78             //writeln('  written ', OBSize-zst.avail_out, ' bytes');
  79             if ds.position+(OBSize-zst.avail_out)-dstp >= srcsize then
  80             begin
  81               // this will be overwritten anyway
  82               aborted := true;
  83               exit;
  84             end;
  85             ds.writeBuffer(ob^, OBSize-zst.avail_out);
  86             zst.next_out := ob;
  87             zst.avail_out := OBSize;
  88           end;
  89         end;
  90       until eof;
  91       // do leftovers
  92       while true do
  93       begin
  94         zst.avail_in := 0;
  95         err := deflate(zst, Z_FINISH);
  96         if (err <> Z_OK) and (err <> Z_STREAM_END) then raise Exception.Create(zerror(err));
  97         if zst.avail_out < OBSize then
  98         begin
  99           //writeln('  .written ', OBSize-zst.avail_out, ' bytes');
 100           if ds.position+(OBSize-zst.avail_out)-dstp >= srcsize then
 101           begin
 102             // this will be overwritten anyway
 103             aborted := true;
 104             exit;
 105           end;
 106           ds.writeBuffer(ob^, OBSize-zst.avail_out);
 107           zst.next_out := ob;
 108           zst.avail_out := OBSize;
 109         end;
 110         if err <> Z_OK then break;
 111       end;
 112       // succesfully flushed?
 113       if (err <> Z_STREAM_END) then raise Exception.Create(zerror(err));
 114     finally
 115       deflateEnd(zst);
 116     end;
 117   finally
 118     FreeMem(ob);
 119     FreeMem(ib);
 120   end;
 121 end;
 122
 123
 124 {
 125 procedure TProg.putStr (const s: AnsiString; newline: Boolean=false);
 126 begin
 127   write(#13, s);
 128   while lastlen > length(s) do
 129   begin
 130     write(' ');
 131     Dec(lastlen);
 132   end;
 133   if newline then
 134   begin
 135     writeln;
 136     lastlen := 0;
 137   end
 138   else
 139   begin
 140     lastlen := length(s);
 141   end;
 142 end;
 143
 144 procedure TProg.onProgress (sender: TObject; const percent: double);
 145 var
 146   prc: Integer;
 147 begin
 148   prc := trunc(percent*100.0);
 149   putStr(Format('compressing %-33s  %3d%%', [lastname, prc]));
 150 end;
 151
 152 procedure TProg.onFileStart (sender: TObject; const fileName: AnsiString);
 153 begin
 154   lastname := fileName;
 155   putStr(Format('compressing %-33s  %3d%%', [lastname, 0]));
 156 end;
 157
 158 procedure TProg.onFileEnd (sender: TObject; const ratio: double);
 159 begin
 160   putStr(Format('compressed  %-33s  %f', [lastname, ratio]), true);
 161 end;
 162 }
 163
 164
 165 // returns new file name
 166 function detectExt (fpath, fname: AnsiString; fs: TStream): AnsiString;
 167 var
 168   buf: PChar;
 169   buflen: Integer;
 170   f: Integer;
 171   st: string[24];
 172   img: string;
 173 begin
 174   result := fname;
 175   if length(ExtractFileExt(fname)) <> 0 then exit;
 176   if fs.size < 16 then exit;
 177   buflen := Integer(fs.size);
 178   GetMem(buf, buflen);
 179   try
 180     fs.ReadBuffer(buf^, buflen);
 181     // xm
 182     Move(buf^, (PChar(@st[1]))^, 16);
 183     st[0] := #16;
 184     if (st = 'Extended Module:') then
 185     begin
 186       result := result+'.xm';
 187       exit;
 188     end;
 189     if (buf[0] = 'D') and (buf[1] = 'F') and (buf[2] = 'W') and
 190        (buf[3] = 'A') and (buf[4] = 'D') and (buf[5] = #$1) then
 191     begin
 192       result := result+'.wad';
 193       exit;
 194     end;
 195     if (buf[0] = 'M') and (buf[1] = 'A') and (buf[2] = 'P') and (buf[3] = #$1) then
 196     begin
 197       result := result+'.dfmap';
 198       exit;
 199     end;
 200     if (buf[0] = 'M') and (buf[1] = 'T') and (buf[2] = 'h') and (buf[3] = 'd') then
 201     begin
 202       result := result+'.mid';
 203       exit;
 204     end;
 205     if (buf[0] = 'R') and (buf[1] = 'I') and (buf[2] = 'F') and (buf[3] = 'F') and
 206        (buf[8] = 'W') and (buf[9] = 'A') and (buf[10] = 'V') and (buf[11] = 'E') then
 207     begin
 208       result := result+'.wav';
 209       exit;
 210     end;
 211     // mp3 (stupid hack)
 212     for f := 0 to 128-6 do
 213     begin
 214       if (buf[f+0] = #$4) and (buf[f+1] = 'L') and
 215          (buf[f+2] = 'A') and (buf[f+3] = 'M') and
 216          (buf[f+4] = 'E') and (buf[f+5] = '3') then
 217       begin
 218         result := result+'.mp3';
 219         exit;
 220       end;
 221     end;
 222     // more mp3 hacks
 223     if (buf[0] = 'I') and (buf[1] = 'D') and (buf[2] = '3') and (buf[3] <= #4) then
 224     begin
 225       result := result+'.mp3';
 226       exit;
 227     end;
 228     if buflen > 128 then
 229     begin
 230       if (buf[buflen-128] = 'T') and (buf[buflen-127] = 'A') and (buf[buflen-126] = 'G') then
 231       begin
 232         result := result+'.mp3';
 233         exit;
 234       end;
 235     end;
 236     // targa (stupid hack; this "signature" is not required by specs)
 237     {
 238     if buflen >= 18 then
 239     begin
 240       Move((buf+buflen-18)^, (PChar(@st[1]))^, 16);
 241       st[0] := #16;
 242       if st = 'TRUEVISION-XFILE' then
 243       begin
 244         result := result+'.tga';
 245         exit;
 246       end;
 247     end;
 248     }
 249     // detect image format
 250     img := DetermineMemoryFormat(buf, buflen);
 251     if length(img) > 0 then
 252     begin
 253       result := result+'.'+img;
 254       exit;
 255     end;
 256     // check if this is text file
 257     if buflen > 16 then
 258     begin
 259       for f := 0 to buflen-1 do
 260       begin
 261         if buf[f] = #127 then exit;
 262         if buf[f] < #32 then
 263         begin
 264           if (buf[f] <> #9) and (buf[f] <> #10) and (buf[f] <> #13) then exit;
 265         end;
 266       end;
 267       result := result+'.txt';
 268     end;
 269   finally
 270     FreeMem(buf);
 271   end;
 272 end;
 273
 274
 275 type
 276   TFileInfo = class
 277   public
 278     name: AnsiString;
 279     pkofs: Int64; // offset of file header
 280     size: Int64;
 281     pksize: Int64;
 282     crc: LongWord;
 283     method: Word;
 284
 285     constructor Create ();
 286   end;
 287
 288 constructor TFileInfo.Create ();
 289 begin
 290   name := '';
 291   pkofs := 0;
 292   size := 0;
 293   pksize := 0;
 294   crc := crc32(0, nil, 0);
 295   method := 0;
 296 end;
 297
 298
 299 const
 300   uni2wint: array [128..255] of Word = (
 301     $0402,$0403,$201A,$0453,$201E,$2026,$2020,$2021,$20AC,$2030,$0409,$2039,$040A,$040C,$040B,$040F,
 302     $0452,$2018,$2019,$201C,$201D,$2022,$2013,$2014,$003F,$2122,$0459,$203A,$045A,$045C,$045B,$045F,
 303     $00A0,$040E,$045E,$0408,$00A4,$0490,$00A6,$00A7,$0401,$00A9,$0404,$00AB,$00AC,$00AD,$00AE,$0407,
 304     $00B0,$00B1,$0406,$0456,$0491,$00B5,$00B6,$00B7,$0451,$2116,$0454,$00BB,$0458,$0405,$0455,$0457,
 305     $0410,$0411,$0412,$0413,$0414,$0415,$0416,$0417,$0418,$0419,$041A,$041B,$041C,$041D,$041E,$041F,
 306     $0420,$0421,$0422,$0423,$0424,$0425,$0426,$0427,$0428,$0429,$042A,$042B,$042C,$042D,$042E,$042F,
 307     $0430,$0431,$0432,$0433,$0434,$0435,$0436,$0437,$0438,$0439,$043A,$043B,$043C,$043D,$043E,$043F,
 308     $0440,$0441,$0442,$0443,$0444,$0445,$0446,$0447,$0448,$0449,$044A,$044B,$044C,$044D,$044E,$044F
 309   );
 310
 311
 312 function toUtf8 (const s: AnsiString): AnsiString;
 313 var
 314   uc: PUnicodeChar;
 315   xdc: PChar;
 316   pos, f: Integer;
 317 begin
 318   GetMem(uc, length(s)*8);
 319   GetMem(xdc, length(s)*8);
 320   try
 321     FillChar(uc^, length(s)*8, 0);
 322     FillChar(xdc^, length(s)*8, 0);
 323     pos := 0;
 324     for f := 1 to length(s) do
 325     begin
 326       if ord(s[f]) < 128 then
 327         uc[pos] := UnicodeChar(ord(s[f]))
 328       else
 329         uc[pos] := UnicodeChar(uni2wint[ord(s[f])]);
 330       Inc(pos);
 331     end;
 332     FillChar(xdc^, length(s)*8, 0);
 333     f := UnicodeToUtf8(xdc, length(s)*8, uc, pos);
 334     while (f > 0) and (xdc[f-1] = #0) do Dec(f);
 335     SetLength(result, f);
 336     Move(xdc^, result[1], f);
 337   finally
 338     FreeMem(xdc);
 339     FreeMem(uc);
 340   end;
 341 end;
 342
 343 // this will write "extra field length" and extra field itself
 344 {$IFDEF UTFEXTRA}
 345 const UtfFlags = 0;
 346
 347 type
 348   TByteArray = array of Byte;
 349
 350 function buildUtfExtra (fname: AnsiString): TByteArray;
 351 var
 352   crc: LongWord;
 353   fu: AnsiString;
 354   sz: Word;
 355 begin
 356   fu := toUtf8(fname);
 357   if fu = fname then begin result := nil; exit; end; // no need to write anything
 358   crc := crc32(0, @fname[1], length(fname));
 359   sz := 2+2+1+4+length(fu);
 360   SetLength(result, sz);
 361   result[0] := ord('u');
 362   result[1] := ord('p');
 363   Dec(sz, 4);
 364   result[2] := sz and $ff;
 365   result[3] := (sz shr 8) and $ff;
 366   result[4] := 1;
 367   result[5] := crc and $ff;
 368   result[6] := (crc shr 8) and $ff;
 369   result[7] := (crc shr 16) and $ff;
 370   result[8] := (crc shr 24) and $ff;
 371   Move(fu[1], result[9], length(fu));
 372 end;
 373 {$ELSE}
 374 const UtfFlags = (1 shl 10); // bit 11
 375 {$ENDIF}
 376
 377 function ZipOne (ds: TStream; fname: AnsiString; st: TStream; dopack: Boolean=true): TFileInfo;
 378 var
 379   oldofs, nfoofs, pkdpos, rd: Int64;
 380   sign: packed array [0..3] of Char;
 381   buf: PChar;
 382   bufsz: Integer;
 383   aborted: Boolean = false;
 384 {$IFDEF UTFEXTRA}
 385   ef: TByteArray;
 386 {$ENDIF}
 387 begin
 388   result := TFileInfo.Create();
 389   result.pkofs := ds.position;
 390   result.size := st.size;
 391   if result.size > 0 then result.method := 8 else result.method := 0;
 392   if not dopack then
 393   begin
 394     result.method := 0;
 395     result.pksize := result.size;
 396   end;
 397 {$IFDEF UTFEXTRA}
 398   result.name := fname;
 399   ef := buildUtfExtra(result.name);
 400 {$ELSE}
 401   result.name := toUtf8(fname);
 402 {$ENDIF}
 403   // write local header
 404   sign := 'PK'#3#4;
 405   ds.writeBuffer(sign, 4);
 406   writeInt(ds, Word($0A10)); // version to extract
 407   writeInt(ds, Word(UtfFlags)); // flags
 408   writeInt(ds, Word(result.method)); // compression method
 409   writeInt(ds, Word(0)); // file time
 410   writeInt(ds, Word(0)); // file date
 411   nfoofs := ds.position;
 412   writeInt(ds, LongWord(result.crc)); // crc32
 413   writeInt(ds, LongWord(result.pksize)); // packed size
 414   writeInt(ds, LongWord(result.size)); // unpacked size
 415   writeInt(ds, Word(length(fname))); // name length
 416 {$IFDEF UTFEXTRA}
 417   writeInt(ds, Word(length(ef))); // extra field length
 418 {$ELSE}
 419   writeInt(ds, Word(0)); // extra field length
 420 {$ENDIF}
 421   ds.writeBuffer(fname[1], length(fname));
 422 {$IFDEF UTFEXTRA}
 423   if length(ef) > 0 then ds.writeBuffer(ef[0], length(ef));
 424 {$ENDIF}
 425   if dopack then
 426   begin
 427     // now write packed data
 428     if result.size > 0 then
 429     begin
 430       pkdpos := ds.position;
 431       st.position := 0;
 432       result.crc := zpack(ds, st, aborted);
 433       result.pksize := ds.position-pkdpos;
 434       if {result.pksize >= result.size} aborted then
 435       begin
 436         // there's no sence to pack this file, so just store it
 437         st.position := 0;
 438         ds.position := result.pkofs;
 439         result.Free();
 440         // store it
 441         result := ZipOne(ds, fname, st, false);
 442         exit;
 443       end
 444       else
 445       begin
 446         // fix header
 447         oldofs := ds.position;
 448         ds.position := nfoofs;
 449         writeInt(ds, LongWord(result.crc)); // crc32
 450         writeInt(ds, LongWord(result.pksize)); // crc32
 451         ds.position := oldofs;
 452       end;
 453     end;
 454   end
 455   else
 456   begin
 457     bufsz := 1024*1024;
 458     GetMem(buf, bufsz);
 459     try
 460       st.position := 0;
 461       result.crc := crc32(0, nil, 0);
 462       result.pksize := 0;
 463       while result.pksize < result.size do
 464       begin
 465         rd := result.size-result.pksize;
 466         if rd > bufsz then rd := bufsz;
 467         st.readBuffer(buf^, rd);
 468         ds.writeBuffer(buf^, rd);
 469         Inc(result.pksize, rd);
 470         result.crc := crc32(result.crc, buf, rd);
 471       end;
 472     finally
 473       FreeMem(buf);
 474     end;
 475     // fix header
 476     oldofs := ds.position;
 477     ds.position := nfoofs;
 478     writeInt(ds, LongWord(result.crc)); // crc32
 479     ds.position := oldofs;
 480     write('(S) ');
 481   end;
 482 end;
 483
 484
 485 procedure writeCentralDir (ds: TStream; files: array of TFileInfo);
 486 var
 487   cdofs, cdend: Int64;
 488   sign: packed array [0..3] of Char;
 489   f: Integer;
 490 {$IFDEF UTFEXTRA}
 491   ef: TByteArray;
 492 {$ENDIF}
 493 begin
 494   cdofs := ds.position;
 495   for f := 0 to high(files) do
 496   begin
 497 {$IFDEF UTFEXTRA}
 498     ef := buildUtfExtra(files[f].name);
 499 {$ENDIF}
 500     sign := 'PK'#1#2;
 501     ds.writeBuffer(sign, 4);
 502     writeInt(ds, Word($0A10)); // version made by
 503     writeInt(ds, Word($0010)); // version to extract
 504     writeInt(ds, Word(UtfFlags)); // flags
 505     writeInt(ds, Word(files[f].method)); // compression method
 506     writeInt(ds, Word(0)); // file time
 507     writeInt(ds, Word(0)); // file date
 508     writeInt(ds, LongWord(files[f].crc));
 509     writeInt(ds, LongWord(files[f].pksize));
 510     writeInt(ds, LongWord(files[f].size));
 511     writeInt(ds, Word(length(files[f].name))); // name length
 512 {$IFDEF UTFEXTRA}
 513     writeInt(ds, Word(length(ef))); // extra field length
 514 {$ELSE}
 515     writeInt(ds, Word(0)); // extra field length
 516 {$ENDIF}
 517     writeInt(ds, Word(0)); // comment length
 518     writeInt(ds, Word(0)); // disk start
 519     writeInt(ds, Word(0)); // internal attributes
 520     writeInt(ds, LongWord(0)); // external attributes
 521     writeInt(ds, LongWord(files[f].pkofs)); // header offset
 522     ds.writeBuffer(files[f].name[1], length(files[f].name));
 523 {$IFDEF UTFEXTRA}
 524     if length(ef) > 0 then ds.writeBuffer(ef[0], length(ef));
 525 {$ENDIF}
 526   end;
 527   cdend := ds.position;
 528   // write end of central dir
 529   sign := 'PK'#5#6;
 530   ds.writeBuffer(sign, 4);
 531   writeInt(ds, Word(0)); // disk number
 532   writeInt(ds, Word(0)); // disk with central dir
 533   writeInt(ds, Word(length(files))); // number of files on this dist
 534   writeInt(ds, Word(length(files))); // number of files total
 535   writeInt(ds, LongWord(cdend-cdofs)); // size of central directory
 536   writeInt(ds, LongWord(cdofs)); // central directory offset
 537   writeInt(ds, Word(0)); // archive comment length
 538 end;
 539
 540
 541 var
 542   fs, fo: TStream;
 543   fl: TSFSFileList;
 544   f: Integer;
 545   infname: AnsiString;
 546   outfname: AnsiString;
 547   dvfn: AnsiString;
 548   newname: AnsiString;
 549   files: array of TFileInfo;
 550   nfo: TFileInfo;
 551 begin
 552   if ParamCount() < 1 then
 553   begin
 554     WriteLn('usage: wadcvt file.wad');
 555     Halt(1);
 556   end;
 557
 558   infname := ParamStr(1);
 559   if not StrEquCI1251(ExtractFileExt(infname), '.wad') and not StrEquCI1251(ExtractFileExt(infname), '.dfwad') then
 560   begin
 561     writeln('wtf?!');
 562     Halt(1);
 563   end;
 564
 565   if ParamCount() > 1 then
 566   begin
 567     outfname := ParamStr(2);
 568   end
 569   else
 570   begin
 571     outfname := ChangeFileExt(infname, '.pk3');
 572   end;
 573
 574   if not SFSAddDataFile(infname) then begin WriteLn('shit!'); Halt(1); end;
 575   dvfn := SFSGetLastVirtualName(infname);
 576
 577   files := nil;
 578
 579   fl := SFSFileList(dvfn);
 580   if fl = nil then
 581   begin
 582     writeln('wtf?!');
 583     Halt(1);
 584   end;
 585
 586   fo := TFileStream.Create(outfname, fmCreate);
 587   try
 588     for f := 0 to fl.Count-1 do
 589     begin
 590       if length(fl[f].fName) = 0 then continue;
 591       fs := SFSFileOpen(dvfn+'::'+fl[f].fPath+fl[f].fName);
 592       newname := detectExt(fl[f].fPath, fl[f].fName, fs);
 593       //fs.Free();
 594       //fs := SFSFileOpen(dvfn+'::'+fl[f].fPath+fl[f].fName);
 595       fs.position := 0;
 596 {$IFNDEF WINDOWS}
 597       write(#13'[', f+1, '/', fl.Count, ']: ', fl[f].fPath, newname, '  ', fs.size, ' ... '#27'[K');
 598 {$ELSE}
 599       write('[', f+1, '/', fl.Count, ']: ', fl[f].fPath, newname, '  ', fs.size, ' ... ');
 600 {$ENDIF}
 601       nfo := ZipOne(fo, fl[f].fPath+newname, fs);
 602       write('DONE');
 603 {$IFDEF WINDOWS}
 604       writeln;
 605 {$ENDIF}
 606       SetLength(files, length(files)+1);
 607       files[high(files)] := nfo;
 608     end;
 609 {$IFNDEF WINDOWS}
 610     writeln(#13, fl.Count, ' files processed'#27'[K');
 611 {$ENDIF}
 612     writeCentralDir(fo, files);
 613   except
 614     fo.Free();
 615     fo := nil;
 616     DeleteFile(outfname);
 617   end;
 618   if fo <> nil then fo.Free();
 619 end.