1 {$IFDEF WIN32}
2 {$APPTYPE CONSOLE}
3 {$ENDIF}
4 {$MODE DELPHI}
5 program __wadcvt__;
7 uses
8 SysUtils,
9 Classes,
10 SDL2 in '../lib/sdl2/sdl2.pas',
11 utils in '../shared/utils.pas',
12 sfs,
13 sfsPlainFS,
14 sfsZipFS,
15 sfsMemFS,
16 zipper;
19 type
20 TProg = class(TObject)
21 lastname: string;
22 lastlen: Integer;
24 procedure putStr (const s: string; newline: Boolean=false);
26 procedure onProgress (sender: TObject; const percent: double);
27 procedure onFileStart (sender: TObject; const fileName: string);
28 procedure onFileEnd (sender: TObject; const ratio: double);
29 end;
32 procedure TProg.putStr (const s: string; newline: Boolean=false);
33 begin
34 write(#13, s);
35 while lastlen > length(s) do
36 begin
37 write(' ');
38 Dec(lastlen);
39 end;
40 if newline then
41 begin
42 writeln;
43 lastlen := 0;
44 end
45 else
46 begin
47 lastlen := length(s);
48 end;
49 end;
51 procedure TProg.onProgress (sender: TObject; const percent: double);
52 var
53 prc: Integer;
54 begin
55 prc := trunc(percent*100.0);
56 putStr(Format('compressing %-33s %3d%%', [lastname, prc]));
57 end;
59 procedure TProg.onFileStart (sender: TObject; const fileName: string);
60 begin
61 lastname := fileName;
62 putStr(Format('compressing %-33s %3d%%', [lastname, 0]));
63 end;
65 procedure TProg.onFileEnd (sender: TObject; const ratio: double);
66 begin
67 putStr(Format('compressed %-33s %f', [lastname, ratio]), true);
68 end;
71 // returns new file name
72 function detectExt (fpath, fname: string; fs: TStream): string;
73 var
74 buf: PChar;
75 buflen: Integer;
76 f: Integer;
77 st: string[24];
78 begin
79 result := fname;
80 if length(ExtractFileExt(fname)) <> 0 then exit;
81 if fs.size < 16 then exit;
82 buflen := Integer(fs.size);
83 GetMem(buf, buflen);
84 try
85 fs.ReadBuffer(buf^, buflen);
86 // xm
87 Move(buf^, (PChar(@st[1]))^, 16);
88 st[0] := #16;
89 if (st = 'Extended Module:') then
90 begin
91 result := result+'.xm';
92 exit;
93 end;
94 if (buf[0] = 'D') and (buf[1] = 'F') and (buf[2] = 'W') and
95 (buf[3] = 'A') and (buf[4] = 'D') and (buf[5] = #$1) then
96 begin
97 result := result+'.wad';
98 exit;
99 end;
100 if (buf[0] = 'M') and (buf[1] = 'A') and (buf[2] = 'P') and (buf[3] = #$1) then
101 begin
102 result := result+'.dfmap';
103 exit;
104 end;
105 if (buf[0] = 'M') and (buf[1] = 'T') and (buf[2] = 'h') and (buf[3] = 'd') then
106 begin
107 result := result+'.mid';
108 exit;
109 end;
110 if (buf[0] = 'R') and (buf[1] = 'I') and (buf[2] = 'F') and (buf[3] = 'F') and
111 (buf[8] = 'W') and (buf[9] = 'A') and (buf[10] = 'V') and (buf[11] = 'E') then
112 begin
113 result := result+'.wav';
114 exit;
115 end;
116 // mp3 (stupid hack)
117 for f := 0 to 128-6 do
118 begin
119 if (buf[f+0] = #$4) and (buf[f+1] = 'L') and
120 (buf[f+2] = 'A') and (buf[f+3] = 'M') and
121 (buf[f+4] = 'E') and (buf[f+5] = '3') then
122 begin
123 result := result+'.mp3';
124 exit;
125 end;
126 end;
127 // more mp3 hacks
128 if (buf[0] = 'I') and (buf[1] = 'D') and (buf[2] = '3') and (buf[3] <= #4) then
129 begin
130 result := result+'.mp3';
131 exit;
132 end;
133 if buflen > 128 then
134 begin
135 if (buf[buflen-128] = 'T') and (buf[buflen-127] = 'A') and (buf[buflen-126] = 'G') then
136 begin
137 result := result+'.mp3';
138 exit;
139 end;
140 end;
141 // targa (stupid hack; this "signature" is not required by specs)
142 if buflen >= 18 then
143 begin
144 Move((buf+buflen-18)^, (PChar(@st[1]))^, 16);
145 st[0] := #16;
146 if st = 'TRUEVISION-XFILE' then
147 begin
148 result := result+'.tga';
149 exit;
150 end;
151 end;
152 finally
153 FreeMem(buf);
154 end;
155 end;
158 var
159 fs: TStream;
160 fl: TSFSFileList;
161 f: Integer;
162 infname: string;
163 outfname: string;
164 zip: TZipper;
165 dvfn: string;
166 ZEntries: TZipFileEntries;
167 newname: string;
168 prg: TProg;
169 begin
170 if ParamCount() < 1 then
171 begin
172 WriteLn('usage: wadcvt file.wad');
173 Halt(1);
174 end;
176 infname := ParamStr(1);
177 if not StrEquCI1251(ExtractFileExt(infname), '.wad') and not StrEquCI1251(ExtractFileExt(infname), '.dfwad') then
178 begin
179 writeln('wtf?!');
180 Halt(1);
181 end;
183 if ParamCount() > 1 then
184 begin
185 outfname := ParamStr(2);
186 end
187 else
188 begin
189 outfname := ChangeFileExt(infname, '.pk3');
190 end;
192 if not SFSAddDataFile(infname) then begin WriteLn('shit!'); Halt(1); end;
193 dvfn := SFSGetLastVirtualName(infname);
195 {
196 tot := 0;
197 fl := SFSFileList(ParamStr(1));
198 if fl <> nil then
199 begin
200 for f := 0 to fl.Count-1 do
201 begin
202 WriteLn(f:4, ': ', fl[f].fSize:10, ' "', fl[f].fPath, fl[f].fName, '"');
203 Inc(tot, fl[f].fSize);
204 end;
205 WriteLn('===================================================');
206 WriteLn(fl.Count, ' files; ', Int64ToStrComma(tot), ' bytes.');
207 fl.Free();
208 end;
209 }
211 zip := TZipper.Create;
212 zip.Filename := outfname;
214 fl := SFSFileList(dvfn);
215 if fl <> nil then
216 begin
217 ZEntries := TZipFileEntries.Create(TZipFileEntry);
218 for f := 0 to fl.Count-1 do
219 begin
220 if length(fl[f].fName) = 0 then continue;
221 fs := SFSFileOpen(dvfn+'::'+fl[f].fPath+fl[f].fName);
222 newname := detectExt(fl[f].fPath, fl[f].fName, fs);
223 fs.Free;
224 fs := SFSFileOpen(dvfn+'::'+fl[f].fPath+fl[f].fName);
225 writeln('[', f+1, '/', fl.Count, ']: ', fl[f].fPath+newname, ' ', fs.size);
226 ZEntries.AddFileEntry(fs, fl[f].fPath+newname);
227 end;
228 try
229 if ZEntries.Count > 0 then
230 begin
231 writeln('creating ''', outfname, '''');
232 prg := TProg.Create();
233 zip.OnProgress := prg.onProgress;
234 zip.OnStartFile := prg.onFileStart;
235 zip.OnEndFile := prg.onFileEnd;
236 zip.ZipFiles(ZEntries);
237 prg.Free;
238 end;
239 except
240 on E: EZipError do E.CreateFmt('Zipfile could not be created%sReason: %s', [LineEnding, E.Message])
241 end;
242 end
243 else
244 begin
245 writeln('SFSFileList(): faled!');
246 end;
247 end.