home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TOOL-INC.ZIP / LOCFILE.INC < prev    next >
Encoding:
Text File  |  1989-06-02  |  2.7 KB  |  123 lines
  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13.  
  14. (*
  15.  * get the value of an environment variable
  16.  *
  17.  *)
  18. type
  19.    gestring = string[255];
  20.  
  21.  
  22. function get_environment_var(id: gestring): gestring;
  23. var
  24.    envseg:  integer;
  25.    i:       integer;
  26.    env:     gestring;
  27.  
  28. begin
  29.    envseg := memw[PrefixSeg:$2c];
  30.  
  31.    i := 0;
  32.    repeat
  33.       env := '';
  34.       while mem[envseg:i] <> 0 do
  35.       begin
  36.          env := env + chr(mem[envseg:i]);
  37.          i := i + 1;
  38.       end;
  39.  
  40.       if copy(env,1,length(id)) = id then
  41.       begin
  42.          get_environment_var := copy(env,length(id)+1,255);
  43.          exit;
  44.       end;
  45.  
  46.       i := i + 1;
  47.    until mem[envseg:i] = 0;
  48.  
  49. (* not found *)
  50.    get_environment_var := '';
  51. end;
  52.  
  53.  
  54. (*
  55.  * locate a file with search rules from specified environment variable.
  56.  * returns the full pathname of the located file.
  57.  * returns only the original name if not found.
  58.  *
  59.  *)
  60.  
  61. function locate_file_env(name:    gestring;
  62.                          environ: gestring): gestring;
  63. var
  64.    paths:  gestring;
  65.    dir:    gestring;
  66.    i:      integer;
  67.    fd:     file;
  68.  
  69. begin
  70.  
  71. (* get the paths and start searching them.  arrange for current directory
  72.    to be scanned first.  add trailing ; to handle special case for last path *)
  73.  
  74.    paths := environ + ';';
  75.    dir := '';
  76.  
  77.    for i := 1 to length(paths) do
  78.    begin
  79.  
  80. (* if a full directory has been collected, then try this path *)
  81.       if (paths[i] = ';') or (i = length(paths)) then
  82.       begin
  83.          if (length(dir) > 1) and (dir[length(dir)] <> '\') then
  84.             dir := dir + '\';
  85.  
  86. {$I-}
  87.          assign(fd,dir + name);
  88.          reset(fd);
  89. {$I+}
  90.          if ioresult = 0 then
  91. {! 7. IOResu^lt now returns different values corresponding to DOS error codes.}
  92.          begin
  93.            close(fd);
  94.            locate_file_env := dir + name;
  95.            exit;
  96.          end;
  97.  
  98.          dir := '';
  99.       end
  100.       else
  101.          dir := dir + paths[i];
  102.    end;
  103.  
  104. (* couldn't find it.  return the original name *)
  105.    locate_file_env := name;
  106. end;
  107.  
  108.  
  109. (*
  110.  * locate a file.  search PATH= paths if needed.  returns
  111.  * the full pathname of the located file.
  112.  * returns only the original name if not found.
  113.  *
  114.  *)
  115.  
  116. function locate_file(name: gestring): gestring;
  117. begin
  118.  
  119.    locate_file := locate_file_env(name,';' + get_environment_var('PATH='));
  120.  
  121. end;
  122.  
  123.