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;
  18
  19 {$DEFINE SFS_DFWAD_DEBUG}
  20 {$DEFINE SFS_MAPDETECT_FX}
  21
  22 interface
  23
  24 uses
  25   Classes,
  26   mempool, sfs, xstreams, utils;
  27
  28
  29 type
  30   TWADFile = class(TPoolObject)
  31   private
  32     fFileName: AnsiString; // empty: not opened
  33     fIter: TSFSFileList;
  34
  35     function getIsOpen (): Boolean;
  36     function isMapResource (idx: Integer): Boolean;
  37
  38     function GetResourceEx (name: AnsiString; wantMap: Boolean; var pData: Pointer; var Len: Integer; logError: Boolean=true): Boolean;
  39
  40    public
  41     constructor Create ();
  42     destructor Destroy (); override;
  43
  44     procedure FreeWAD ();
  45
  46     function ReadFile (FileName: AnsiString): Boolean;
  47     function ReadMemory (Data: Pointer; Len: LongWord): Boolean;
  48
  49     function GetResource (name: AnsiString; var pData: Pointer; var Len: Integer; logError: Boolean=true): Boolean;
  50     function GetMapResource (name: AnsiString; var pData: Pointer; var Len: Integer; logError: Boolean=true): Boolean;
  51     function GetMapResources (): SSArray;
  52
  53     // returns `nil` if file wasn't found
  54     function openFileStream (name: AnsiString): TStream;
  55
  56     property isOpen: Boolean read getIsOpen;
  57   end;
  58
  59
  60 function g_ExtractWadName (resourceStr: AnsiString): AnsiString;
  61 function g_ExtractWadNameNoPath (resourceStr: AnsiString): AnsiString;
  62 function g_ExtractFilePath (resourceStr: AnsiString): AnsiString;
  63 function g_ExtractFileName (resourceStr: AnsiString): AnsiString; // without path
  64 function g_ExtractFilePathName (resourceStr: AnsiString): AnsiString;
  65
  66 // return fixed AnsiString or empty AnsiString
  67 function findDiskWad (fname: AnsiString): AnsiString;
  68
  69
  70 var
  71   wadoptDebug: Boolean = false;
  72   wadoptFast: Boolean = false;
  73
  74
  75 implementation
  76
  77 uses
  78   SysUtils, e_log, MAPDEF, xdynrec;
  79
  80
  81 function findDiskWad (fname: AnsiString): AnsiString;
  82 begin
  83   result := '';
  84   if not findFileCI(fname) then
  85   begin
  86     //e_WriteLog(Format('findDiskWad: error looking for [%s]', [fname]), MSG_NOTIFY);
  87     if StrEquCI1251(ExtractFileExt(fname), '.wad') then
  88     begin
  89       fname := ChangeFileExt(fname, '.pk3');
  90       //e_WriteLog(Format('  looking for [%s]', [fname]), MSG_NOTIFY);
  91       if not findFileCI(fname) then
  92       begin
  93         fname := ChangeFileExt(fname, '.zip');
  94         //e_WriteLog(Format('  looking for [%s]', [fname]), MSG_NOTIFY);
  95         if not findFileCI(fname) then exit;
  96       end;
  97     end
  98     else
  99     begin
 100       exit;
 101     end;
 102   end;
 103   //e_WriteLog(Format('findDiskWad: FOUND [%s]', [fname]), MSG_NOTIFY);
 104   result := fname;
 105 end;
 106
 107
 108 function normSlashes (s: AnsiString): AnsiString;
 109 var
 110   f: Integer;
 111 begin
 112   for f := 1 to length(s) do if s[f] = '\' then s[f] := '/';
 113   result := s;
 114 end;
 115
 116 function g_ExtractWadNameNoPath (resourceStr: AnsiString): AnsiString;
 117 var
 118   f, c: Integer;
 119 begin
 120   for f := length(resourceStr) downto 1 do
 121   begin
 122     if resourceStr[f] = ':' then
 123     begin
 124       result := normSlashes(Copy(resourceStr, 1, f-1));
 125       c := length(result);
 126       while (c > 0) and (result[c] <> '/') do Dec(c);
 127       if c > 0 then result := Copy(result, c+1, length(result));
 128       exit;
 129     end;
 130   end;
 131   result := '';
 132 end;
 133
 134 function g_ExtractWadName (resourceStr: AnsiString): AnsiString;
 135 var
 136   f: Integer;
 137 begin
 138   for f := length(resourceStr) downto 1 do
 139   begin
 140     if resourceStr[f] = ':' then
 141     begin
 142       result := normSlashes(Copy(resourceStr, 1, f-1));
 143       exit;
 144     end;
 145   end;
 146   result := '';
 147 end;
 148
 149 function g_ExtractFilePath (resourceStr: AnsiString): AnsiString;
 150 var
 151   f, lastSlash: Integer;
 152 begin
 153   result := '';
 154   lastSlash := -1;
 155   for f := length(resourceStr) downto 1 do
 156   begin
 157     if (lastSlash < 0) and (resourceStr[f] = '\') or (resourceStr[f] = '/') then lastSlash := f;
 158     if resourceStr[f] = ':' then
 159     begin
 160       if lastSlash > 0 then
 161       begin
 162         result := normSlashes(Copy(resourceStr, f, lastSlash-f));
 163         while (length(result) > 0) and (result[1] = '/') do Delete(result, 1, 1);
 164       end;
 165       exit;
 166     end;
 167   end;
 168   if lastSlash > 0 then result := normSlashes(Copy(resourceStr, 1, lastSlash-1));
 169 end;
 170
 171 function g_ExtractFileName (resourceStr: AnsiString): AnsiString; // without path
 172 var
 173   f, lastSlash: Integer;
 174 begin
 175   result := '';
 176   lastSlash := -1;
 177   for f := length(resourceStr) downto 1 do
 178   begin
 179     if (lastSlash < 0) and (resourceStr[f] = '\') or (resourceStr[f] = '/') then lastSlash := f;
 180     if resourceStr[f] = ':' then
 181     begin
 182       if lastSlash > 0 then result := Copy(resourceStr, lastSlash+1, length(resourceStr));
 183       exit;
 184     end;
 185   end;
 186   if lastSlash > 0 then result := Copy(resourceStr, lastSlash+1, length(resourceStr));
 187 end;
 188
 189 function g_ExtractFilePathName (resourceStr: AnsiString): AnsiString;
 190 var
 191   f: Integer;
 192 begin
 193   result := '';
 194   for f := length(resourceStr) downto 1 do
 195   begin
 196     if resourceStr[f] = ':' then
 197     begin
 198       result := normSlashes(Copy(resourceStr, f+1, length(resourceStr)));
 199       while (length(result) > 0) and (result[1] = '/') do Delete(result, 1, 1);
 200       exit;
 201     end;
 202   end;
 203   result := normSlashes(resourceStr);
 204   while (length(result) > 0) and (result[1] = '/') do Delete(result, 1, 1);
 205 end;
 206
 207
 208
 209 { TWADFile }
 210 constructor TWADFile.Create();
 211 begin
 212   fFileName := '';
 213 end;
 214
 215
 216 destructor TWADFile.Destroy();
 217 begin
 218   FreeWAD();
 219   inherited;
 220 end;
 221
 222
 223 function TWADFile.getIsOpen (): Boolean;
 224 begin
 225   result := (fFileName <> '');
 226 end;
 227
 228
 229 procedure TWADFile.FreeWAD();
 230 begin
 231   if fIter <> nil then FreeAndNil(fIter);
 232   //if fFileName <> '' then e_WriteLog(Format('TWADFile.ReadFile: [%s] closed', [fFileName]), MSG_NOTIFY);
 233   fFileName := '';
 234 end;
 235
 236
 237 //FIXME: detect text maps properly here
 238 function TWADFile.isMapResource (idx: Integer): Boolean;
 239 var
 240   //sign: packed array [0..2] of Char;
 241   fs: TStream = nil;
 242 begin
 243   result := false;
 244   if not isOpen or (fIter = nil) then exit;
 245   if (idx < 0) or (idx >= fIter.Count) then exit;
 246   try
 247     fs := fIter.volume.OpenFileByIndex(idx);
 248     result := TDynMapDef.canBeMap(fs);
 249     (*
 250     fs.readBuffer(sign, 3);
 251     result := (sign = MAP_SIGNATURE);
 252     if not result then result := (sign[0] = 'm') and (sign[1] = 'a') and (sign[2] = 'p');
 253     *)
 254   except
 255     fs.Free();
 256     result := false; // just in case
 257     exit;
 258   end;
 259   fs.Free();
 260 end;
 261
 262
 263 // returns `nil` if file wasn't found
 264 function TWADFile.openFileStream (name: AnsiString): TStream;
 265 var
 266   f: Integer;
 267   fi: TSFSFileInfo;
 268 begin
 269   result := nil;
 270   // backwards, due to possible similar names and such
 271   for f := fIter.Count-1 downto 0 do
 272   begin
 273     fi := fIter.Files[f];
 274     if fi = nil then continue;
 275     if StrEquCI1251(fi.name, name) then
 276     begin
 277       try
 278         result := fIter.volume.OpenFileByIndex(f);
 279       except
 280         result := nil;
 281       end;
 282       if (result <> nil) then exit;
 283     end;
 284   end;
 285 end;
 286
 287
 288 function removeExt (s: AnsiString): AnsiString;
 289 var
 290   i: Integer;
 291 begin
 292   i := length(s)+1;
 293   while (i > 1) and (s[i-1] <> '.') and (s[i-1] <> '/') do Dec(i);
 294   if (i > 1) and (s[i-1] = '.') then
 295   begin
 296     //writeln('[', s, '] -> [', Copy(s, 1, i-2), ']');
 297     s := Copy(s, 1, i-2);
 298   end;
 299   result := s;
 300 end;
 301
 302
 303 function TWADFile.GetResourceEx (name: AnsiString; wantMap: Boolean; var pData: Pointer; var Len: Integer; logError: Boolean=true): Boolean;
 304 var
 305   f, lastSlash: Integer;
 306   fi: TSFSFileInfo;
 307   fs: TStream;
 308   fpp: Pointer;
 309   rpath, rname: AnsiString;
 310   //sign: packed array [0..2] of Char;
 311   goodMap: Boolean;
 312   {$IFNDEF SFS_MAPDETECT_FX}
 313   wst: TSFSMemoryChunkStream;
 314   {$ENDIF}
 315 begin
 316   Result := False;
 317   if not isOpen or (fIter = nil) then Exit;
 318   rname := removeExt(name);
 319   if length(rname) = 0 then Exit; // just in case
 320   lastSlash := -1;
 321   for f := 1 to length(rname) do
 322   begin
 323     if rname[f] = '\' then rname[f] := '/';
 324     if rname[f] = '/' then lastSlash := f;
 325   end;
 326   if lastSlash > 0 then
 327   begin
 328     rpath := Copy(rname, 1, lastSlash);
 329     Delete(rname, 1, lastSlash);
 330   end
 331   else
 332   begin
 333     rpath := '';
 334   end;
 335   // backwards, due to possible similar names and such
 336   for f := fIter.Count-1 downto 0 do
 337   begin
 338     fi := fIter.Files[f];
 339     if fi = nil then continue;
 340     if StrEquCI1251(removeExt(fi.name), rname) then
 341     begin
 342       // i found her (maybe)
 343       if not wantMap then
 344       begin
 345         if length(fi.path) < length(rpath) then continue; // alas
 346         if length(fi.path) = length(rpath) then
 347         begin
 348           if not StrEquCI1251(fi.path, rpath) then continue; // alas
 349         end
 350         else
 351         begin
 352           if fi.path[length(fi.path)-length(rpath)] <> '/' then continue; // alas
 353           if not StrEquCI1251(Copy(fi.path, length(fi.path)+1-length(rpath), length(fi.path)), rpath) then continue; // alas
 354         end;
 355       end;
 356       try
 357         fs := fIter.volume.OpenFileByIndex(f);
 358       except
 359         fs := nil;
 360       end;
 361       if fs = nil then
 362       begin
 363         if wantMap then continue;
 364         if logError then e_WriteLog(Format('DFWAD: can''t open file [%s] in [%s]', [name, fFileName]), TMsgType.Warning);
 365         break;
 366       end;
 367       // if we want only maps, check if this is map
 368 {$IFDEF SFS_MAPDETECT_FX}
 369       if wantMap then
 370       begin
 371         goodMap := false;
 372         {$IF DEFINED(D2D_NEW_MAP_READER_DBG)}
 373         e_LogWritefln('DFWAD: checking for good map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f]);
 374         {$ENDIF}
 375         try
 376           //fs.readBuffer(sign, 3);
 377           //goodMap := (sign = MAP_SIGNATURE);
 378           //if not goodMap then goodMap := (sign[0] = 'm') and (sign[1] = 'a') and (sign[2] = 'p');
 379           goodMap := TDynMapDef.canBeMap(fs);
 380           {$IF DEFINED(D2D_NEW_MAP_READER_DBG)}
 381           if goodMap then
 382             e_LogWritefln('  GOOD map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f])
 383           else
 384             e_LogWritefln('  BAD map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f]);
 385           {$ENDIF}
 386         except
 387         end;
 388         if not goodMap then
 389         begin
 390           {$IF DEFINED(D2D_NEW_MAP_READER_DBG)}
 391           e_LogWritefln('  not a map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f]);
 392           {$ENDIF}
 393           fs.Free();
 394           continue;
 395         end;
 396         fs.position := 0;
 397       end;
 398 {$ENDIF}
 399       Len := Integer(fs.size);
 400       GetMem(pData, Len);
 401       fpp := pData;
 402       try
 403         fs.ReadBuffer(pData^, Len);
 404         fpp := nil;
 405       finally
 406         if fpp <> nil then
 407         begin
 408           FreeMem(fpp);
 409           pData := nil;
 410           Len := 0;
 411         end;
 412         fs.Free;
 413       end;
 414 {$IFNDEF SFS_MAPDETECT_FX}
 415       if wantMap then
 416       begin
 417         goodMap := false;
 418         if Len >= 3 then
 419         begin
 420           //Move(pData^, sign, 3);
 421           //goodMap := (sign = MAP_SIGNATURE);
 422           wst := TSFSMemoryChunkStream.Create(pData, Len);
 423           try
 424             goodMap := TDynMapDef.canBeMap(wst);
 425           except
 426             goodMap := false;
 427           end;
 428           wst.Free();
 429         end;
 430         if not goodMap then
 431         begin
 432           //e_WriteLog(Format('  not a map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f]), MSG_NOTIFY);
 433           FreeMem(pData);
 434           pData := nil;
 435           Len := 0;
 436           continue;
 437         end;
 438       end;
 439 {$ENDIF}
 440       result := true;
 441       {$IFDEF SFS_DFWAD_DEBUG}
 442       if wadoptDebug then
 443         e_WriteLog(Format('DFWAD: file [%s] FOUND in [%s]; size is %d bytes', [name, fFileName, Len]), TMsgType.Notify);
 444       {$ENDIF}
 445       exit;
 446     end;
 447   end;
 448   if logError then e_WriteLog(Format('DFWAD: file [%s] not found in [%s]', [name, fFileName]), TMsgType.Warning);
 449 end;
 450
 451 function TWADFile.GetResource (name: AnsiString; var pData: Pointer; var Len: Integer; logError: Boolean=true): Boolean;
 452 begin
 453   result := GetResourceEx(name, false, pData, Len, logError);
 454 end;
 455
 456 function TWADFile.GetMapResource (name: AnsiString; var pData: Pointer; var Len: Integer; logError: Boolean=true): Boolean;
 457 begin
 458   result := GetResourceEx(name, true, pData, Len, logError);
 459 end;
 460
 461 function TWADFile.GetMapResources (): SSArray;
 462 var
 463   f, c: Integer;
 464   fi: TSFSFileInfo;
 465   s: AnsiString;
 466 begin
 467   Result := nil;
 468   if not isOpen or (fIter = nil) then Exit;
 469   for f := fIter.Count-1 downto 0 do
 470   begin
 471     fi := fIter.Files[f];
 472     if fi = nil then continue;
 473     if length(fi.name) = 0 then continue;
 474     {$IF DEFINED(D2D_NEW_MAP_READER)}
 475     //e_LogWritefln('DFWAD: checking for map in wad [%s], file [%s] (#%d)', [fFileName, fi.fname, f]);
 476     {$ENDIF}
 477     if isMapResource(f) then
 478     begin
 479       s := removeExt(fi.name);
 480       c := High(result);
 481       while c >= 0 do
 482       begin
 483         if StrEquCI1251(result[c], s) then break;
 484         Dec(c);
 485       end;
 486       if c < 0 then
 487       begin
 488         SetLength(result, Length(result)+1);
 489         result[high(result)] := removeExt(fi.name);
 490       end;
 491     end;
 492   end;
 493 end;
 494
 495
 496 function TWADFile.ReadFile (FileName: AnsiString): Boolean;
 497 var
 498   rfn: AnsiString;
 499   //f: Integer;
 500   //fi: TSFSFileInfo;
 501 begin
 502   Result := False;
 503   //e_WriteLog(Format('TWADFile.ReadFile: [%s]', [FileName]), MSG_NOTIFY);
 504   FreeWAD();
 505   rfn := findDiskWad(FileName);
 506   if length(rfn) = 0 then
 507   begin
 508     e_WriteLog(Format('TWADFile.ReadFile: error looking for [%s]', [FileName]), TMsgType.Notify);
 509     exit;
 510   end;
 511   {$IFDEF SFS_DFWAD_DEBUG}
 512   if wadoptDebug then e_WriteLog(Format('TWADFile.ReadFile: FOUND [%s]', [rfn]), TMsgType.Notify);
 513   {$ENDIF}
 514   // cache this wad
 515   try
 516     if wadoptFast then
 517     begin
 518       if not SFSAddDataFile(rfn, true) then exit;
 519     end
 520     else
 521     begin
 522       if not SFSAddDataFileTemp(rfn, true) then exit;
 523     end;
 524   except
 525     exit;
 526   end;
 527   fIter := SFSFileList(rfn);
 528   if fIter = nil then Exit;
 529   fFileName := rfn;
 530   {$IFDEF SFS_DFWAD_DEBUG}
 531   if wadoptDebug then e_WriteLog(Format('TWADFile.ReadFile: [%s] opened', [fFileName]), TMsgType.Notify);
 532   {$ENDIF}
 533   Result := True;
 534 end;
 535
 536
 537 var
 538   uniqueCounter: Integer = 0;
 539
 540 function TWADFile.ReadMemory (Data: Pointer; Len: LongWord): Boolean;
 541 var
 542   fn: AnsiString;
 543   st: TStream = nil;
 544   //f: Integer;
 545   //fi: TSFSFileInfo;
 546 begin
 547   Result := False;
 548   FreeWAD();
 549   if (Data = nil) or (Len = 0) then
 550   begin
 551     e_WriteLog('TWADFile.ReadMemory: EMPTY SUBWAD!', TMsgType.Warning);
 552     Exit;
 553   end;
 554
 555   fn := Format(' -- memwad %d -- ', [uniqueCounter]);
 556   Inc(uniqueCounter);
 557   {$IFDEF SFS_DFWAD_DEBUG}
 558   if wadoptDebug then e_WriteLog(Format('TWADFile.ReadMemory: [%s]', [fn]), TMsgType.Notify);
 559   {$ENDIF}
 560
 561   try
 562     st := TSFSMemoryStreamRO.Create(Data, Len);
 563     if not SFSAddSubDataFile(fn, st, true) then
 564     begin
 565       st.Free;
 566       Exit;
 567     end;
 568   except
 569     st.Free;
 570     Exit;
 571   end;
 572
 573   fIter := SFSFileList(fn);
 574   if fIter = nil then Exit;
 575
 576   fFileName := fn;
 577   {$IFDEF SFS_DFWAD_DEBUG}
 578   if wadoptDebug then e_WriteLog(Format('TWADFile.ReadMemory: [%s] opened', [fFileName]), TMsgType.Notify);
 579   {$ENDIF}
 580
 581   {
 582   for f := 0 to fIter.Count-1 do
 583   begin
 584     fi := fIter.Files[f];
 585     if fi = nil then continue;
 586     st := fIter.volume.OpenFileByIndex(f);
 587     if st = nil then
 588     begin
 589       e_WriteLog(Format('[%s]: [%s : %s] CAN''T OPEN', [fFileName, fi.path, fi.name]), MSG_NOTIFY);
 590     end
 591     else
 592     begin
 593       e_WriteLog(Format('[%s]: [%s : %s] %u', [fFileName, fi.path, fi.name, st.size]), MSG_NOTIFY);
 594       st.Free;
 595     end;
 596   end;
 597   //fIter.volume.OpenFileByIndex(0);
 598   }
 599
 600   Result := True;
 601 end;
 602
 603
 604 begin
 605   sfsDiskDirs := '<exedir>/data'; //FIXME
 606 end.