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 implementation
  67
  68   uses WadReader, e_log, hashtable;
  69
  70   type
  71     SpawnProc = function (pathname: AnsiString): Tstream;
  72
  73   var
  74     writeableDirs: THashStrCIStr = nil;
  75
  76
  77   function e_UpperDir (path: AnsiString): AnsiString;
  78     var i: Integer;
  79   begin
  80     i := High(path);
  81     while (i >= 1) and (path[i] <> '/') and (path[i] <> '\') do Dec(i);
  82     result := Copy(path, 1, i)
  83   end;
  84
  85   function HasRelativeDirs (name: AnsiString): Boolean;
  86     var i: Integer; ch: Char;
  87   begin
  88     i := 1;
  89     result := false;
  90     while (result = false) and (name[i] <> #0) do
  91     begin
  92       ch := name[i];
  93       if (ch = '/') or (ch = '\') then
  94       begin
  95         Inc(i);
  96         if name[i] = '.' then
  97         begin
  98           Inc(i);
  99           if name[i] = '.' then
 100           begin
 101             Inc(i);
 102             ch := name[i];
 103             result := (ch = #0) or (ch = '/') or (ch = '\')
 104           end
 105         end
 106       end
 107       else
 108       begin
 109         Inc(i)
 110       end
 111     end
 112   end;
 113
 114   function HasAbsoluteDirs (name: AnsiString): Boolean;
 115   begin
 116     result := (name = '') or (name[1] = '/') or (name[1] = '\')
 117   end;
 118
 119   function e_IsValidResourceName (name: AnsiString): Boolean;
 120   begin
 121     result := (HasAbsoluteDirs(name) = false) and (HasRelativeDirs(name) = false)
 122   end;
 123
 124   function SpawnStream (dirs: SSArray; name: AnsiString; p: SpawnProc; createNewDir: Boolean): TStream;
 125     var i: Integer;
 126   begin
 127     result := nil;
 128     assert(dirs <> nil);
 129     assert(e_IsValidResourceName(name));
 130     i := High(dirs);
 131     while (i >= 0) and (result = nil) do
 132     begin
 133       try
 134         if debug_e_res then
 135           e_LogWritefln('  %s', [dirs[i]]);
 136         if (createNewDir = false) or (ForceDirectories(dirs[i]) = true) then
 137           result := p(e_CatPath(dirs[i], name))
 138       finally
 139         Dec(i)
 140       end
 141     end
 142   end;
 143
 144   function e_CreateResource (dirs: SSArray; name: AnsiString): TStream;
 145   begin
 146     if debug_e_res then
 147       e_LogWritefln('e_CreateResource %s', [name]);
 148     result := SpawnStream(dirs, name, @createDiskFile, true);
 149     if result = nil then
 150       raise Exception.Create('can''t create resource "' + name + '"');
 151   end;
 152
 153   function e_OpenResourceRO (dirs: SSArray; name: AnsiString): TStream;
 154   begin
 155     if debug_e_res then
 156       e_LogWritefln('e_OpenResourceRO %s', [name]);
 157     result := SpawnStream(dirs, name, @openDiskFileRO, false);
 158     if result = nil then
 159       raise EFileNotFoundException.Create('can''t open resource "' + name + '"')
 160   end;
 161
 162   function e_OpenResourceRW (dirs: SSArray; name: AnsiString): TStream;
 163   begin
 164     if debug_e_res then
 165       e_LogWritefln('e_OpenResourceRW %s', [name]);
 166     result := SpawnStream(dirs, name, @openDiskFileRW, true);
 167     if result = nil then
 168       raise Exception.Create('can''t create resource "' + name + '"')
 169   end;
 170
 171   function e_CatPath (a, b: AnsiString): AnsiString;
 172   begin
 173     if a = '' then
 174       result := b
 175     else if b = '' then
 176       result := a
 177     else
 178       result := a + '/' + b
 179   end;
 180
 181   function e_FindResource (dirs: SSArray; var name: AnsiString; nameIsDir: Boolean = false): Boolean;
 182     var i: Integer; dir: AnsiString;
 183   begin
 184     if debug_e_res then
 185       e_LogWritefln('e_FindResource %s (%s)', [name, nameIsDir]);
 186     result := false;
 187     assert(dirs <> nil);
 188     assert(e_IsValidResourceName(name));
 189     i := High(dirs); dir := name;
 190     while (i >= 0) and (result = false) do
 191     begin
 192       dir := e_CatPath(dirs[i], name);
 193       result := findFileCI(dir, nameIsDir);
 194       if debug_e_res then
 195         e_LogWritefln('  %s -> %s', [dir, result]);
 196       Dec(i)
 197     end;
 198     if result = true then
 199       name := dir;
 200     if debug_e_res then
 201       e_LogWritefln('  result = %s (%s)', [name, result]);
 202   end;
 203
 204   function e_FindWad (dirs: SSArray; name: AnsiString): AnsiString;
 205     var i: Integer;
 206   begin
 207     if debug_e_res then
 208       e_LogWritefln('e_FindWad "%s"', [name]);
 209     result := '';
 210     assert(dirs <> nil);
 211     assert(e_IsValidResourceName(name));
 212     i := High(dirs);
 213     while (i >= 0) and (result = '') do
 214     begin
 215       result := findDiskWad(dirs[i] + DirectorySeparator + name);
 216       if debug_e_res then
 217         e_LogWritefln('  %s -> %s', [dirs[i] + DirectorySeparator + name, result]);
 218       Dec(i)
 219     end
 220   end;
 221
 222   function e_FindWadRel (dirs: SSArray; name: AnsiString): AnsiString;
 223   var
 224     s: AnsiString;
 225     maxpfx: AnsiString = '';
 226     pfx: AnsiString;
 227   begin
 228     result := name;
 229     if not findFileCI(name) then exit;
 230     for s in dirs do
 231     begin
 232       if (length(s) = 0) then continue;
 233       if (length(name) <= length(s)) then continue;
 234       if (length(s) < length(maxpfx)) then continue;
 235       pfx := s;
 236       if not findFileCI(pfx, true) then continue;
 237       if (pfx[length(pfx)] <> '/') and (pfx[length(pfx)] <> '\') then pfx := pfx+'/';
 238       if (length(pfx)+1 > length(name)) then continue;
 239       if (strEquCI1251(copy(name, 1, length(pfx)), pfx)) then maxpfx := pfx;
 240     end;
 241     if (length(maxpfx) > 0) then
 242     begin
 243       result := name;
 244       Delete(result, 1, length(maxpfx));
 245     end;
 246   end;
 247
 248   function e_GetResourcePath (dirs: SSArray; path: AnsiString; defWad: AnsiString): AnsiString;
 249     var diskName, fileName: AnsiString;
 250   begin
 251     if debug_e_res then
 252       e_LogWritefln('e_GetResourcePath %s (%s)', [path, defWad]);
 253     assert(length(dirs) > 0);
 254     assert(path <> '');
 255     assert(defWad <> '');
 256     diskName := g_ExtractWadName(path);
 257     fileName := g_ExtractFilePathName(path);
 258     if diskName = '' then diskName := defWad else diskName := e_FindWad(dirs, diskName);
 259     if diskName = '' then result := '' else result := diskName + ':\' + fileName;
 260     if debug_e_res then
 261       e_LogWritefln('  this>>> %s', [result]);
 262   end;
 263
 264   function e_FindFirst (dirs: SSArray; name: AnsiString; attr: LongInt; out Rslt: TSearchRec): LongInt;
 265     var i: Integer; dir: AnsiString;
 266   begin
 267     if debug_e_res then
 268       e_LogWritefln('e_FindFirst %s', [name]);
 269     assert(dirs <> nil);
 270     assert(e_IsValidResourceName(name));
 271     i := High(dirs); result := -1;
 272     while (i >= 0) and (result <> 0) do
 273     begin
 274       dir := dirs[i] + DirectorySeparator + name;
 275       result := FindFirst(dir, attr, Rslt);
 276       if debug_e_res then
 277         e_LogWritefln('  %s: %s -- %s', [i, dir, result]);
 278       Dec(i);
 279     end
 280   end;
 281
 282   // k8: sorry. i know that this sux, but checking directory access rights is unreliable (unportable).
 283   function canCreateFiles (dir: AnsiString): Boolean;
 284   var
 285     f: Integer;
 286     st: TStream = nil;
 287     sr: TSearchRec;
 288     fn: AnsiString;
 289   begin
 290     result := false;
 291     for f := 0 to $7fffffff do
 292     begin
 293       fn := Format('%s/$$$temptest$$$_%d.$$$%d$$$', [dir, f, f]);
 294       if (FindFirst(fn, faAnyFile, sr) = 0) then
 295       begin
 296         FindClose(sr);
 297         continue;
 298       end;
 299       FindClose(sr);
 300       try
 301         st := TFileStream.Create(fn, fmCreate);
 302       except // sorry
 303         st := nil; // just in case
 304       end;
 305       if assigned(st) then
 306       begin
 307         st.Free();
 308         try DeleteFile(fn); except end;
 309         result := true;
 310       end;
 311       exit;
 312     end;
 313   end;
 314
 315   function e_GetWriteableDir (dirs: SSArray; required: Boolean=true): AnsiString;
 316   var
 317     f: Integer;
 318   begin
 319     assert(length(dirs) > 0);
 320     result := '';
 321     if assigned(writeableDirs) then
 322     begin
 323       for f := High(dirs) downto Low(dirs) do
 324       begin
 325         if (writeableDirs.get(dirs[f], result)) then
 326         begin
 327           //writeln('*** KNOWN WRITEABLE DIR: "', result, '"');
 328           exit;
 329         end;
 330       end;
 331     end;
 332     for f := High(dirs) downto Low(dirs) do
 333     begin
 334       try
 335         if ForceDirectories(dirs[f]) then
 336         begin
 337           result := dirs[f];
 338           if (findFileCI(result, true)) then
 339           begin
 340             if canCreateFiles(result) then
 341             begin
 342               if not assigned(writeableDirs) then writeableDirs := THashStrCIStr.Create();
 343               writeableDirs.put(dirs[f], result);
 344               //writeln('*** NEW WRITEABLE DIR: "', result, '" ("', dirs[f], '"); rq=', required);
 345               exit;
 346             end;
 347           end;
 348         end;
 349       except // sorry
 350       end;
 351     end;
 352     if required then raise Exception.Create(Format('unable to create directory "%s"', [dirs[High(dirs)]]));
 353     result := '';
 354   end;
 355
 356 end.