src/shared/wadreader.pas

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