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