src/engine/e_res.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, version 3 of the License ONLY.
   6  *
   7  * This program is distributed in the hope that it will be useful,
   8  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  10  * GNU General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU General Public License
  13  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  14  *)
  15 {$I ../shared/a_modes.inc}
  16 unit e_res;
  17
  18 interface
  19
  20   uses SysUtils, Utils, Classes;
  21
  22   var
  23     debug_e_res: Boolean;
  24
  25   {--- remove last entry from path ---}
  26   function e_UpperDir (path: AnsiString): AnsiString;
  27
  28   {--- not absolute and have no relative dirs ---}
  29   function e_IsValidResourceName (name: AnsiString): Boolean;
  30
  31   {-----------------------------------------------------------------------}
  32   {--- try to open/create file in one dir from `dirs` in reverse order ---}
  33   {--- e_OpenResourceRW tries to create if not exists                  ---}
  34   {--- create dirs if not exists                                       ---}
  35   {--- result <> nil, throws exceptions on errors                      ---}
  36   {--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ---}
  37   function e_CreateResource (dirs: SSArray; name: AnsiString): TStream;
  38   function e_OpenResourceRO (dirs: SSArray; name: AnsiString): TStream;
  39   function e_OpenResourceRW (dirs: SSArray; name: AnsiString): TStream;
  40
  41   {--- same as shared/utils ---}
  42   function e_FindResource (dirs: SSArray; var name: AnsiString; nameIsDir: Boolean = false): Boolean;
  43   function e_FindWad (dirs: SSArray; name: AnsiString): AnsiString;
  44
  45   {--- returns relative wad name; never empty string ---}
  46   function e_FindWadRel (dirs: SSArray; name: AnsiString): AnsiString;
  47
  48   {--- prepend dirs to 'disk.wad:\file'. if empty disk string then prepend defWad  ---}
  49   {--- return empty string if error occured or 'path/to/disk.wad:\file' on success ---}
  50   function e_GetResourcePath (dirs: SSArray; path: AnsiString; defWad: AnsiString): AnsiString;
  51
  52   {--- same as SysUtils.FinFirst ---}
  53   function e_FindFirst (dirs: SSArray; name: AnsiString; attr: LongInt; out Rslt: TSearchRec): LongInt;
  54
  55   {--- try to get a writeable directory from list, throws if no one directory created ---}
  56   {--- (unless `required` is `false`: in this case, returns empty string) ---}
  57   {--- creates all necessary subdirs, if it can ---}
  58   function e_GetWriteableDir (dirs: SSArray; required: Boolean=true): AnsiString;
  59
  60   function e_CanCreateFilesAt (dir: AnsiString): Boolean;
  61
  62 implementation
  63
  64   uses WadReader, e_log, hashtable;
  65
  66   type
  67     SpawnProc = function (pathname: AnsiString): Tstream;
  68
  69   var
  70     writeableDirs: THashStrCIStr;
  71
  72
  73   function e_UpperDir (path: AnsiString): AnsiString;
  74     var i: Integer;
  75   begin
  76     i := High(path);  // consider possible cases: '\a\', '\a', '\abc\'
  77     while (i >= 1) and (path[i] <> '/') and (path[i] <> '\') do Dec(i);
  78     result := Copy(path, 1, i-1)  // exclude the trailing separator
  79   end;
  80
  81   function IsRelativePath (name: AnsiString): Boolean;
  82   begin
  83     result := (copy(name, 1, 3) = '../') or (pos('/../', name) <> 0) or (copy(name, Length(name) - 2) = '/..') or
  84               (copy(name, 1, 3) = '..\') or (pos('\..\', name) <> 0) or (copy(name, Length(name) - 2) = '\..') or
  85               (name = '..');
  86   end;
  87
  88   function IsAbsolutePath (name: AnsiString): Boolean;
  89   begin
  90     result := ExpandFileName(name) = name;
  91   end;
  92
  93   function e_IsValidResourceName (name: AnsiString): Boolean;
  94   begin
  95     result := (IsAbsolutePath(name) = false) and (IsRelativePath(name) = false)
  96   end;
  97
  98   function SpawnStream (dirs: SSArray; name: AnsiString; p: SpawnProc; createNewDir: Boolean): TStream;
  99     var i: Integer;
 100   begin
 101     result := nil;
 102     assert(dirs <> nil);
 103     assert(e_IsValidResourceName(name));
 104     i := High(dirs);
 105     while (i >= 0) and (result = nil) do
 106     begin
 107       try
 108         if debug_e_res then
 109           e_LogWritefln('  %s', [dirs[i]]);
 110         if (createNewDir = false) or (ForceDirectories(dirs[i]) = true) then
 111           result := p(ConcatPaths([AnsiString(dirs[i]), name]))
 112       finally
 113         Dec(i)
 114       end
 115     end
 116   end;
 117
 118   function e_CreateResource (dirs: SSArray; name: AnsiString): TStream;
 119   begin
 120     if debug_e_res then
 121       e_LogWritefln('e_CreateResource %s', [name]);
 122     result := SpawnStream(dirs, name, @createDiskFile, true);
 123     if result = nil then
 124       raise Exception.Create('can''t create resource "' + name + '"');
 125   end;
 126
 127   function e_OpenResourceRO (dirs: SSArray; name: AnsiString): TStream;
 128   begin
 129     if debug_e_res then
 130       e_LogWritefln('e_OpenResourceRO %s', [name]);
 131     result := SpawnStream(dirs, name, @openDiskFileRO, false);
 132     if result = nil then
 133       raise EFileNotFoundException.Create('can''t open resource "' + name + '"')
 134   end;
 135
 136   function e_OpenResourceRW (dirs: SSArray; name: AnsiString): TStream;
 137   begin
 138     if debug_e_res then
 139       e_LogWritefln('e_OpenResourceRW %s', [name]);
 140     result := SpawnStream(dirs, name, @openDiskFileRW, true);
 141     if result = nil then
 142       raise Exception.Create('can''t create resource "' + name + '"')
 143   end;
 144
 145   function e_FindResource (dirs: SSArray; var name: AnsiString; nameIsDir: Boolean = false): Boolean;
 146     var i: Integer; dir: AnsiString;
 147   begin
 148     if debug_e_res then
 149       e_LogWritefln('e_FindResource %s (%s)', [name, nameIsDir]);
 150     result := false;
 151     assert(dirs <> nil);
 152     assert(e_IsValidResourceName(name));
 153     i := High(dirs); dir := name;
 154     while (i >= 0) and (result = false) do
 155     begin
 156       dir := ConcatPaths([AnsiString(dirs[i]), name]);
 157       result := findFileCI(dir, nameIsDir);
 158       if debug_e_res then
 159         e_LogWritefln('  %s -> %s', [dir, result]);
 160       Dec(i)
 161     end;
 162     if result = true then
 163       name := dir;
 164     if debug_e_res then
 165       e_LogWritefln('  result = %s (%s)', [name, result]);
 166   end;
 167
 168   function e_FindWad (dirs: SSArray; name: AnsiString): AnsiString;
 169     var i: Integer;
 170   begin
 171     if debug_e_res then
 172       e_LogWritefln('e_FindWad "%s"', [name]);
 173     result := '';
 174     assert(dirs <> nil);
 175     assert(e_IsValidResourceName(name));
 176     i := High(dirs);
 177     while (i >= 0) and (result = '') do
 178     begin
 179       result := findDiskWad(dirs[i] + DirectorySeparator + name);
 180       if debug_e_res then
 181         e_LogWritefln('  %s -> %s', [dirs[i] + DirectorySeparator + name, result]);
 182       Dec(i)
 183     end
 184   end;
 185
 186   function e_FindWadRel (dirs: SSArray; name: AnsiString): AnsiString;
 187   var
 188     s: AnsiString;
 189     maxpfx: AnsiString = '';
 190     pfx: AnsiString;
 191   begin
 192     result := name;
 193     if not findFileCI(name) then exit;
 194     for s in dirs do
 195     begin
 196       if (length(s) = 0) then continue;
 197       if (length(name) <= length(s)) then continue;
 198       if (length(s) < length(maxpfx)) then continue;
 199       pfx := s;
 200       if not findFileCI(pfx, true) then continue;
 201       if (pfx[length(pfx)] <> '/') and (pfx[length(pfx)] <> '\') then pfx := pfx+'/';
 202       if (length(pfx)+1 > length(name)) then continue;
 203       if (strEquCI1251(copy(name, 1, length(pfx)), pfx)) then maxpfx := pfx;
 204     end;
 205     if (length(maxpfx) > 0) then
 206     begin
 207       result := name;
 208       Delete(result, 1, length(maxpfx));
 209     end;
 210   end;
 211
 212   function e_GetResourcePath (dirs: SSArray; path: AnsiString; defWad: AnsiString): AnsiString;
 213     var diskName, fileName: AnsiString;
 214   begin
 215     if debug_e_res then
 216       e_LogWritefln('e_GetResourcePath %s (%s)', [path, defWad]);
 217     assert(length(dirs) > 0);
 218     assert(path <> '');
 219     assert(defWad <> '');
 220     diskName := g_ExtractWadName(path);
 221     fileName := g_ExtractFilePathName(path);
 222     if diskName = '' then diskName := defWad else diskName := e_FindWad(dirs, diskName);
 223     if diskName = '' then result := '' else result := diskName + ':\' + fileName;
 224     if debug_e_res then
 225       e_LogWritefln('  this>>> %s', [result]);
 226   end;
 227
 228   function e_FindFirst (dirs: SSArray; name: AnsiString; attr: LongInt; out Rslt: TSearchRec): LongInt;
 229     var i: Integer; dir: AnsiString;
 230   begin
 231     if debug_e_res then
 232       e_LogWritefln('e_FindFirst %s', [name]);
 233     assert(dirs <> nil);
 234     assert(e_IsValidResourceName(name));
 235     i := High(dirs); result := -1;
 236     while (i >= 0) and (result <> 0) do
 237     begin
 238       dir := dirs[i] + DirectorySeparator + name;
 239       result := FindFirst(dir, attr, Rslt);
 240       if debug_e_res then
 241         e_LogWritefln('  %s: %s -- %s', [i, dir, result]);
 242       Dec(i);
 243     end
 244   end;
 245
 246   // k8: sorry. i know that this sux, but checking directory access rights is unreliable (unportable).
 247   function e_CanCreateFilesAt (dir: AnsiString): Boolean;
 248   var
 249     f: Integer;
 250     st: TStream = nil;
 251     sr: TSearchRec;
 252     fn: AnsiString;
 253   begin
 254     result := false;
 255     for f := 0 to $7fffffff do
 256     begin
 257       fn := Format('%s/$$$temptest$$$_%d.$$$%d$$$', [dir, f, f]);
 258       if (FindFirst(fn, faAnyFile, sr) = 0) then
 259       begin
 260         FindClose(sr);
 261         continue;
 262       end;
 263       FindClose(sr);
 264       try
 265         st := TFileStream.Create(fn, fmCreate);
 266       except // sorry
 267         st := nil; // just in case
 268       end;
 269       if assigned(st) then
 270       begin
 271         st.Free();
 272         try DeleteFile(fn); except end;
 273         result := true;
 274       end;
 275       exit;
 276     end;
 277   end;
 278
 279   function e_GetWriteableDir (dirs: SSArray; required: Boolean=true): AnsiString;
 280   var
 281     f: Integer;
 282   begin
 283     assert(length(dirs) > 0);
 284     result := '';
 285     if assigned(writeableDirs) then
 286     begin
 287       for f := High(dirs) downto Low(dirs) do
 288       begin
 289         if (writeableDirs.get(dirs[f], result)) then
 290         begin
 291           //writeln('*** KNOWN WRITEABLE DIR: "', result, '"');
 292           exit;
 293         end;
 294       end;
 295     end;
 296     for f := High(dirs) downto Low(dirs) do
 297     begin
 298       try
 299         if ForceDirectories(dirs[f]) then
 300         begin
 301           result := dirs[f];
 302           if (findFileCI(result, true)) then
 303           begin
 304             if e_CanCreateFilesAt(result) then
 305             begin
 306               if not assigned(writeableDirs) then writeableDirs := THashStrCIStr.Create();
 307               writeableDirs.put(dirs[f], result);
 308               //writeln('*** NEW WRITEABLE DIR: "', result, '" ("', dirs[f], '"); rq=', required);
 309               exit;
 310             end;
 311           end;
 312         end;
 313       except // sorry
 314       end;
 315     end;
 316     if required then raise Exception.Create(Format('unable to create directory "%s"', [dirs[High(dirs)]]));
 317     result := '';
 318   end;
 319
 320 finalization
 321   writeableDirs.Free();
 322 end.