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