src/sfs/wadcvt.dpr

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