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