DEADSOFTWARE

relaxed map reader, so "bloodlust", for example, is working now
[d2df-sdl.git] / src / shared / wadreader.pas
1 (* Copyright (C) DooM 2D:Forever Developers
2 *
3 * This program is free software: you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation, either version 3 of the License, or
6 * (at your option) any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this program. If not, see <http://www.gnu.org/licenses/>.
15 *)
16 {$INCLUDE a_modes.inc}
17 unit wadreader;
19 {$DEFINE SFS_DFWAD_DEBUG}
20 {$DEFINE SFS_MAPDETECT_FX}
22 interface
24 uses
25 sfs, xstreams, Classes;
28 type
29 SArray = array of ShortString;
31 TWADFile = class
32 private
33 fFileName: AnsiString; // empty: not opened
34 fIter: TSFSFileList;
36 function getIsOpen (): Boolean;
37 function isMapResource (idx: Integer): Boolean;
39 function GetResourceEx (name: AnsiString; wantMap: Boolean; var pData: Pointer; var Len: Integer): Boolean;
41 public
42 constructor Create ();
43 destructor Destroy (); override;
45 procedure FreeWAD ();
47 function ReadFile (FileName: AnsiString): Boolean;
48 function ReadMemory (Data: Pointer; Len: LongWord): Boolean;
50 function GetResource (name: AnsiString; var pData: Pointer; var Len: Integer): Boolean;
51 function GetMapResource (name: AnsiString; var pData: Pointer; var Len: Integer): Boolean;
52 function GetMapResources (): SArray;
54 // returns `nil` if file wasn't found
55 function openFileStream (name: AnsiString): TStream;
57 property isOpen: Boolean read getIsOpen;
58 end;
61 function g_ExtractWadName (resourceStr: AnsiString): AnsiString;
62 function g_ExtractWadNameNoPath (resourceStr: AnsiString): AnsiString;
63 function g_ExtractFilePath (resourceStr: AnsiString): AnsiString;
64 function g_ExtractFileName (resourceStr: AnsiString): AnsiString; // without path
65 function g_ExtractFilePathName (resourceStr: AnsiString): AnsiString;
67 // return fixed AnsiString or empty AnsiString
68 function findDiskWad (fname: AnsiString): AnsiString;
71 var
72 wadoptDebug: Boolean = false;
73 wadoptFast: Boolean = false;
76 implementation
78 uses
79 SysUtils, e_log, utils, MAPDEF;
82 function findDiskWad (fname: AnsiString): AnsiString;
83 begin
84 result := '';
85 if not findFileCI(fname) then
86 begin
87 //e_WriteLog(Format('findDiskWad: error looking for [%s]', [fname]), MSG_NOTIFY);
88 if StrEquCI1251(ExtractFileExt(fname), '.wad') then
89 begin
90 fname := ChangeFileExt(fname, '.pk3');
91 //e_WriteLog(Format(' looking for [%s]', [fname]), MSG_NOTIFY);
92 if not findFileCI(fname) then
93 begin
94 fname := ChangeFileExt(fname, '.zip');
95 //e_WriteLog(Format(' looking for [%s]', [fname]), MSG_NOTIFY);
96 if not findFileCI(fname) then exit;
97 end;
98 end
99 else
100 begin
101 exit;
102 end;
103 end;
104 //e_WriteLog(Format('findDiskWad: FOUND [%s]', [fname]), MSG_NOTIFY);
105 result := fname;
106 end;
109 function normSlashes (s: AnsiString): AnsiString;
110 var
111 f: Integer;
112 begin
113 for f := 1 to length(s) do if s[f] = '\' then s[f] := '/';
114 result := s;
115 end;
117 function g_ExtractWadNameNoPath (resourceStr: AnsiString): AnsiString;
118 var
119 f, c: Integer;
120 begin
121 for f := length(resourceStr) downto 1 do
122 begin
123 if resourceStr[f] = ':' then
124 begin
125 result := normSlashes(Copy(resourceStr, 1, f-1));
126 c := length(result);
127 while (c > 0) and (result[c] <> '/') do Dec(c);
128 if c > 0 then result := Copy(result, c+1, length(result));
129 exit;
130 end;
131 end;
132 result := '';
133 end;
135 function g_ExtractWadName (resourceStr: AnsiString): AnsiString;
136 var
137 f: Integer;
138 begin
139 for f := length(resourceStr) downto 1 do
140 begin
141 if resourceStr[f] = ':' then
142 begin
143 result := normSlashes(Copy(resourceStr, 1, f-1));
144 exit;
145 end;
146 end;
147 result := '';
148 end;
150 function g_ExtractFilePath (resourceStr: AnsiString): AnsiString;
151 var
152 f, lastSlash: Integer;
153 begin
154 result := '';
155 lastSlash := -1;
156 for f := length(resourceStr) downto 1 do
157 begin
158 if (lastSlash < 0) and (resourceStr[f] = '\') or (resourceStr[f] = '/') then lastSlash := f;
159 if resourceStr[f] = ':' then
160 begin
161 if lastSlash > 0 then
162 begin
163 result := normSlashes(Copy(resourceStr, f, lastSlash-f));
164 while (length(result) > 0) and (result[1] = '/') do Delete(result, 1, 1);
165 end;
166 exit;
167 end;
168 end;
169 if lastSlash > 0 then result := normSlashes(Copy(resourceStr, 1, lastSlash-1));
170 end;
172 function g_ExtractFileName (resourceStr: AnsiString): AnsiString; // without path
173 var
174 f, lastSlash: Integer;
175 begin
176 result := '';
177 lastSlash := -1;
178 for f := length(resourceStr) downto 1 do
179 begin
180 if (lastSlash < 0) and (resourceStr[f] = '\') or (resourceStr[f] = '/') then lastSlash := f;
181 if resourceStr[f] = ':' then
182 begin
183 if lastSlash > 0 then result := Copy(resourceStr, lastSlash+1, length(resourceStr));
184 exit;
185 end;
186 end;
187 if lastSlash > 0 then result := Copy(resourceStr, lastSlash+1, length(resourceStr));
188 end;
190 function g_ExtractFilePathName (resourceStr: AnsiString): AnsiString;
191 var
192 f: Integer;
193 begin
194 result := '';
195 for f := length(resourceStr) downto 1 do
196 begin
197 if resourceStr[f] = ':' then
198 begin
199 result := normSlashes(Copy(resourceStr, f+1, length(resourceStr)));
200 while (length(result) > 0) and (result[1] = '/') do Delete(result, 1, 1);
201 exit;
202 end;
203 end;
204 result := normSlashes(resourceStr);
205 while (length(result) > 0) and (result[1] = '/') do Delete(result, 1, 1);
206 end;
210 { TWADFile }
211 constructor TWADFile.Create();
212 begin
213 fFileName := '';
214 end;
217 destructor TWADFile.Destroy();
218 begin
219 FreeWAD();
220 inherited;
221 end;
224 function TWADFile.getIsOpen (): Boolean;
225 begin
226 result := (fFileName <> '');
227 end;
230 procedure TWADFile.FreeWAD();
231 begin
232 if fIter <> nil then FreeAndNil(fIter);
233 //if fFileName <> '' then e_WriteLog(Format('TWADFile.ReadFile: [%s] closed', [fFileName]), MSG_NOTIFY);
234 fFileName := '';
235 end;
238 //FIXME: detect text maps properly here
239 function TWADFile.isMapResource (idx: Integer): Boolean;
240 var
241 sign: packed array [0..2] of Char;
242 fs: TStream = nil;
243 begin
244 result := false;
245 if not isOpen or (fIter = nil) then exit;
246 if (idx < 0) or (idx >= fIter.Count) then exit;
247 try
248 fs := fIter.volume.OpenFileByIndex(idx);
249 fs.readBuffer(sign, 3);
250 result := (sign = MAP_SIGNATURE);
251 if not result then result := (sign[0] = 'm') and (sign[1] = 'a') and (sign[2] = 'p');
252 except
253 if fs <> nil then fs.Free();
254 exit;
255 end;
256 fs.Free();
257 end;
260 // returns `nil` if file wasn't found
261 function TWADFile.openFileStream (name: AnsiString): TStream;
262 var
263 f: Integer;
264 fi: TSFSFileInfo;
265 begin
266 result := nil;
267 // backwards, due to possible similar names and such
268 for f := fIter.Count-1 downto 0 do
269 begin
270 fi := fIter.Files[f];
271 if fi = nil then continue;
272 if StrEquCI1251(fi.name, name) then
273 begin
274 try
275 result := fIter.volume.OpenFileByIndex(f);
276 except
277 result := nil;
278 end;
279 if (result <> nil) then exit;
280 end;
281 end;
282 end;
285 function removeExt (s: AnsiString): AnsiString;
286 var
287 i: Integer;
288 begin
289 i := length(s)+1;
290 while (i > 1) and (s[i-1] <> '.') and (s[i-1] <> '/') do Dec(i);
291 if (i > 1) and (s[i-1] = '.') then
292 begin
293 //writeln('[', s, '] -> [', Copy(s, 1, i-2), ']');
294 s := Copy(s, 1, i-2);
295 end;
296 result := s;
297 end;
300 function TWADFile.GetResourceEx (name: AnsiString; wantMap: Boolean; var pData: Pointer; var Len: Integer): Boolean;
301 var
302 f, lastSlash: Integer;
303 fi: TSFSFileInfo;
304 fs: TStream;
305 fpp: Pointer;
306 rpath, rname: AnsiString;
307 sign: packed array [0..2] of Char;
308 goodMap: Boolean;
309 begin
310 Result := False;
311 if not isOpen or (fIter = nil) then Exit;
312 rname := removeExt(name);
313 if length(rname) = 0 then Exit; // just in case
314 lastSlash := -1;
315 for f := 1 to length(rname) do
316 begin
317 if rname[f] = '\' then rname[f] := '/';
318 if rname[f] = '/' then lastSlash := f;
319 end;
320 if lastSlash > 0 then
321 begin
322 rpath := Copy(rname, 1, lastSlash);
323 Delete(rname, 1, lastSlash);
324 end
325 else
326 begin
327 rpath := '';
328 end;
329 // backwards, due to possible similar names and such
330 for f := fIter.Count-1 downto 0 do
331 begin
332 fi := fIter.Files[f];
333 if fi = nil then continue;
334 if StrEquCI1251(removeExt(fi.name), rname) then
335 begin
336 // i found her (maybe)
337 if not wantMap then
338 begin
339 if length(fi.path) < length(rpath) then continue; // alas
340 if length(fi.path) = length(rpath) then
341 begin
342 if not StrEquCI1251(fi.path, rpath) then continue; // alas
343 end
344 else
345 begin
346 if fi.path[length(fi.path)-length(rpath)] <> '/' then continue; // alas
347 if not StrEquCI1251(Copy(fi.path, length(fi.path)+1-length(rpath), length(fi.path)), rpath) then continue; // alas
348 end;
349 end;
350 try
351 fs := fIter.volume.OpenFileByIndex(f);
352 except
353 fs := nil;
354 end;
355 if fs = nil then
356 begin
357 if wantMap then continue;
358 e_WriteLog(Format('DFWAD: can''t open file [%s] in [%s]', [name, fFileName]), MSG_WARNING);
359 break;
360 end;
361 // if we want only maps, check if this is map
362 {$IFDEF SFS_MAPDETECT_FX}
363 if wantMap then
364 begin
365 goodMap := false;
366 {$IF DEFINED(D2D_NEW_MAP_READER_DBG)}
367 e_LogWritefln('DFWAD: checking for good map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f]);
368 {$ENDIF}
369 try
370 fs.readBuffer(sign, 3);
371 goodMap := (sign = MAP_SIGNATURE);
372 if not goodMap then goodMap := (sign[0] = 'm') and (sign[1] = 'a') and (sign[2] = 'p');
373 {$IF DEFINED(D2D_NEW_MAP_READER_DBG)}
374 if goodMap then
375 e_LogWritefln(' GOOD map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f])
376 else
377 e_LogWritefln(' BAD map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f]);
378 {$ENDIF}
379 except
380 end;
381 if not goodMap then
382 begin
383 {$IF DEFINED(D2D_NEW_MAP_READER_DBG)}
384 e_LogWritefln(' not a map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f]);
385 {$ENDIF}
386 fs.Free();
387 continue;
388 end;
389 fs.position := 0;
390 end;
391 {$ENDIF}
392 Len := Integer(fs.size);
393 GetMem(pData, Len);
394 fpp := pData;
395 try
396 fs.ReadBuffer(pData^, Len);
397 fpp := nil;
398 finally
399 if fpp <> nil then
400 begin
401 FreeMem(fpp);
402 pData := nil;
403 Len := 0;
404 end;
405 fs.Free;
406 end;
407 {$IFNDEF SFS_MAPDETECT_FX}
408 if wantMap then
409 begin
410 goodMap := false;
411 if Len >= 3 then
412 begin
413 Move(pData^, sign, 3);
414 goodMap := (sign = MAP_SIGNATURE);
415 end;
416 if not goodMap then
417 begin
418 //e_WriteLog(Format(' not a map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f]), MSG_NOTIFY);
419 FreeMem(pData);
420 pData := nil;
421 Len := 0;
422 continue;
423 end;
424 end;
425 {$ENDIF}
426 result := true;
427 {$IFDEF SFS_DFWAD_DEBUG}
428 if wadoptDebug then
429 e_WriteLog(Format('DFWAD: file [%s] FOUND in [%s]; size is %d bytes', [name, fFileName, Len]), MSG_NOTIFY);
430 {$ENDIF}
431 exit;
432 end;
433 end;
434 e_WriteLog(Format('DFWAD: file [%s] not found in [%s]', [name, fFileName]), MSG_WARNING);
435 end;
437 function TWADFile.GetResource (name: AnsiString; var pData: Pointer; var Len: Integer): Boolean;
438 begin
439 result := GetResourceEx(name, false, pData, Len);
440 end;
442 function TWADFile.GetMapResource (name: AnsiString; var pData: Pointer; var Len: Integer): Boolean;
443 begin
444 result := GetResourceEx(name, true, pData, Len);
445 end;
447 function TWADFile.GetMapResources (): SArray;
448 var
449 f, c: Integer;
450 fi: TSFSFileInfo;
451 s: AnsiString;
452 begin
453 Result := nil;
454 if not isOpen or (fIter = nil) then Exit;
455 for f := fIter.Count-1 downto 0 do
456 begin
457 fi := fIter.Files[f];
458 if fi = nil then continue;
459 if length(fi.name) = 0 then continue;
460 {$IF DEFINED(D2D_NEW_MAP_READER)}
461 //e_LogWritefln('DFWAD: checking for map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f]);
462 {$ENDIF}
463 if isMapResource(f) then
464 begin
465 s := removeExt(fi.name);
466 c := High(result);
467 while c >= 0 do
468 begin
469 if StrEquCI1251(result[c], s) then break;
470 Dec(c);
471 end;
472 if c < 0 then
473 begin
474 SetLength(result, Length(result)+1);
475 result[high(result)] := removeExt(fi.name);
476 end;
477 end;
478 end;
479 end;
482 function TWADFile.ReadFile (FileName: AnsiString): Boolean;
483 var
484 rfn: AnsiString;
485 //f: Integer;
486 //fi: TSFSFileInfo;
487 begin
488 Result := False;
489 //e_WriteLog(Format('TWADFile.ReadFile: [%s]', [FileName]), MSG_NOTIFY);
490 FreeWAD();
491 rfn := findDiskWad(FileName);
492 if length(rfn) = 0 then
493 begin
494 e_WriteLog(Format('TWADFile.ReadFile: error looking for [%s]', [FileName]), MSG_NOTIFY);
495 exit;
496 end;
497 {$IFDEF SFS_DFWAD_DEBUG}
498 if wadoptDebug then e_WriteLog(Format('TWADFile.ReadFile: FOUND [%s]', [rfn]), MSG_NOTIFY);
499 {$ENDIF}
500 // cache this wad
501 try
502 if wadoptFast then
503 begin
504 if not SFSAddDataFile(rfn, true) then exit;
505 end
506 else
507 begin
508 if not SFSAddDataFileTemp(rfn, true) then exit;
509 end;
510 except
511 exit;
512 end;
513 fIter := SFSFileList(rfn);
514 if fIter = nil then Exit;
515 fFileName := rfn;
516 {$IFDEF SFS_DFWAD_DEBUG}
517 if wadoptDebug then e_WriteLog(Format('TWADFile.ReadFile: [%s] opened', [fFileName]), MSG_NOTIFY);
518 {$ENDIF}
519 Result := True;
520 end;
523 var
524 uniqueCounter: Integer = 0;
526 function TWADFile.ReadMemory (Data: Pointer; Len: LongWord): Boolean;
527 var
528 fn: AnsiString;
529 st: TStream = nil;
530 //f: Integer;
531 //fi: TSFSFileInfo;
532 begin
533 Result := False;
534 FreeWAD();
535 if (Data = nil) or (Len = 0) then
536 begin
537 e_WriteLog('TWADFile.ReadMemory: EMPTY SUBWAD!', MSG_WARNING);
538 Exit;
539 end;
541 fn := Format(' -- memwad %d -- ', [uniqueCounter]);
542 Inc(uniqueCounter);
543 {$IFDEF SFS_DFWAD_DEBUG}
544 if wadoptDebug then e_WriteLog(Format('TWADFile.ReadMemory: [%s]', [fn]), MSG_NOTIFY);
545 {$ENDIF}
547 try
548 st := TSFSMemoryStreamRO.Create(Data, Len);
549 if not SFSAddSubDataFile(fn, st, true) then
550 begin
551 st.Free;
552 Exit;
553 end;
554 except
555 st.Free;
556 Exit;
557 end;
559 fIter := SFSFileList(fn);
560 if fIter = nil then Exit;
562 fFileName := fn;
563 {$IFDEF SFS_DFWAD_DEBUG}
564 if wadoptDebug then e_WriteLog(Format('TWADFile.ReadMemory: [%s] opened', [fFileName]), MSG_NOTIFY);
565 {$ENDIF}
568 for f := 0 to fIter.Count-1 do
569 begin
570 fi := fIter.Files[f];
571 if fi = nil then continue;
572 st := fIter.volume.OpenFileByIndex(f);
573 if st = nil then
574 begin
575 e_WriteLog(Format('[%s]: [%s : %s] CAN''T OPEN', [fFileName, fi.path, fi.name]), MSG_NOTIFY);
576 end
577 else
578 begin
579 e_WriteLog(Format('[%s]: [%s : %s] %u', [fFileName, fi.path, fi.name, st.size]), MSG_NOTIFY);
580 st.Free;
581 end;
582 end;
583 //fIter.volume.OpenFileByIndex(0);
586 Result := True;
587 end;
590 begin
591 sfsDiskDirs := '<exedir>/data'; //FIXME
592 end.