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