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   sfs, xstreams, Classes;
  26
  27
  28 type
  29   SArray = array of ShortString;
  30
  31   TWADFile = class
  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 (): SArray;
  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 // return fixed AnsiString or empty AnsiString
  68 function findDiskWad (fname: AnsiString): AnsiString;
  69
  70
  71 var
  72   wadoptDebug: Boolean = false;
  73   wadoptFast: Boolean = false;
  74
  75
  76 implementation
  77
  78 uses
  79   SysUtils, e_log, utils, MAPDEF;
  80
  81
  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;
 107
 108
 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;
 116
 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;
 134
 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;
 149
 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;
 171
 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;
 189
 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;
 207
 208
 209
 210 { TWADFile }
 211 constructor TWADFile.Create();
 212 begin
 213   fFileName := '';
 214 end;
 215
 216
 217 destructor TWADFile.Destroy();
 218 begin
 219   FreeWAD();
 220   inherited;
 221 end;
 222
 223
 224 function TWADFile.getIsOpen (): Boolean;
 225 begin
 226   result := (fFileName <> '');
 227 end;
 228
 229
 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;
 236
 237
 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;
 258
 259
 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;
 283
 284
 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;
 298
 299
 300 function TWADFile.GetResourceEx (name: AnsiString; wantMap: Boolean; var pData: Pointer; var Len: Integer; logError: Boolean=true): 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         if logError then 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   if logError then e_WriteLog(Format('DFWAD: file [%s] not found in [%s]', [name, fFileName]), MSG_WARNING);
 435 end;
 436
 437 function TWADFile.GetResource (name: AnsiString; var pData: Pointer; var Len: Integer; logError: Boolean=true): Boolean;
 438 begin
 439   result := GetResourceEx(name, false, pData, Len, logError);
 440 end;
 441
 442 function TWADFile.GetMapResource (name: AnsiString; var pData: Pointer; var Len: Integer; logError: Boolean=true): Boolean;
 443 begin
 444   result := GetResourceEx(name, true, pData, Len, logError);
 445 end;
 446
 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;
 480
 481
 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;
 521
 522
 523 var
 524   uniqueCounter: Integer = 0;
 525
 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;
 540
 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}
 546
 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;
 558
 559   fIter := SFSFileList(fn);
 560   if fIter = nil then Exit;
 561
 562   fFileName := fn;
 563   {$IFDEF SFS_DFWAD_DEBUG}
 564   if wadoptDebug then e_WriteLog(Format('TWADFile.ReadMemory: [%s] opened', [fFileName]), MSG_NOTIFY);
 565   {$ENDIF}
 566
 567   {
 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);
 584   }
 585
 586   Result := True;
 587 end;
 588
 589
 590 begin
 591   sfsDiskDirs := '<exedir>/data'; //FIXME
 592 end.