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