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