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