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