home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / FILEFND2.ZIP / FILEFND2.PAS
Encoding:
Pascal/Delphi Source File  |  1985-09-18  |  6.4 KB  |  242 lines
  1. (************************************************************
  2.      The original version of this program was supplied by
  3.   Wolfgang Siebeck, Aachen, W.Germany (72446,415), written
  4.   for Turbo Version 3.
  5.  
  6.       It can be used to find any file using the set
  7.    PATH, so you can open and use your TURBO *.COM
  8.    programs together with their data files from any
  9.    subdirectory, if they are located in a PATH-directory.
  10. -------------------------------------------------------------
  11.                    MODIFICATION LOG
  12.  DATE    AUTHOR                CONTACT INFO
  13. 09/15/85 Roy J. Collins   P.O.B. 1192, Leesburg, Va 22075
  14.                     or    TechMail BBS (703) 430-2535
  15.  
  16.          I modified the program for use under Turbo Version 2,
  17.       by adding Turbo routines to retrieve and modify the current
  18.       drive and directory.
  19.          I also added a routine to take the file name to search for
  20.       from the command line.
  21.  
  22. *************************************************************)
  23.  
  24. type
  25.   filename_type = string[64];
  26.   regpack = record
  27.               ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  28.             end;
  29.   line     = string[255];
  30. var
  31.   regs : regpack;
  32.   input    : line;
  33.  
  34. function current_drive:char;
  35. var
  36.   reg   : regpack;
  37. begin
  38.   reg.ax := $19 shl 8;
  39.   MSDOS(reg);
  40.   current_drive := chr((reg.ax and $00FF) + 65);
  41. end; (* func current_drive *)
  42.  
  43. procedure change_drive(drive:char);
  44. var
  45.   reg : regpack;
  46. begin
  47.   reg.ax := $E shl 8;
  48.   reg.dx := ord(upcase(drive)) - 65;
  49.   MSDOS(reg);
  50. end; (* proc change_drive *)
  51.  
  52. function current_directory(drive:char; var error:byte):filename_type;
  53. var
  54.   reg : regpack;
  55.   dir : filename_type;
  56. begin
  57.   with reg do begin
  58.     DX := ord(UpCase(drive))-64;
  59.     DS := seg(dir);
  60.     SI := ofs(dir)+1;
  61.     AX := $47 shl 8;
  62.     MSDOS(reg);
  63.     if Flags and 1 = 1 then begin
  64.       error := AX and $00FF;
  65.       current_directory := '';
  66.       end
  67.     else begin
  68.       error := 0;
  69.       current_directory := drive + ':\' + copy(dir,1,pos(#0,dir)-1);
  70.       end;
  71.     end;  {with}
  72. end; (* proc current_directory *)
  73.  
  74. procedure change_directory(drive:char; dir:filename_type; var error:byte);
  75. var
  76.   reg : regpack;
  77. begin
  78.   with reg do begin
  79.     dir[length(dir)+1] := #0;
  80.     DS := seg(dir);
  81.     DX := ofs(dir)+1;
  82.     AX := $3B shl 8;
  83.     MSDOS(reg);
  84.     if Flags and 1 = 1 then
  85.       error := AX and $00FF
  86.     else
  87.       error := 0;
  88.     end;  {with}
  89. end; (* proc change_directory *)
  90.  
  91. (****************************************************************************)
  92.  
  93. Procedure getparm(Var s:line);  { Get command line parameter }
  94. Var
  95.    parms : line Absolute Cseg:$80;
  96.    p : Integer;
  97. Begin
  98.   While (parms <> '') And (parms[1]=' ') Do
  99.     Delete(parms,1,1);
  100.   p := pos(' ',parms);
  101.   if p = 0 then
  102.     p := length(parms)+1;
  103.   s := copy(parms,1,p-1);
  104. End;
  105.  
  106. function exist (filename : line) : boolean;
  107. const
  108.   new_drive:char = ' ';
  109.   old_drive:char = ' ';
  110.   new_dir:filename_type = '';
  111.   old_dir:filename_type = '';
  112.   filex:filename_type = '';
  113. var
  114.   found    : boolean;
  115.   testfile : file;
  116.   err : byte;
  117.   i : integer;
  118. begin
  119.   {writeln;}
  120.   {writeln('file=',filename);}
  121.   i := length(filename);
  122.   while ((filename[i] <> '\') and (i>=1)) do
  123.     i := i - 1;
  124.   if i = 3 then
  125.     new_dir := copy(filename,1,i)
  126.   else
  127.   if i > 0 then
  128.     new_dir := copy(filename,1,i-1);
  129.   filex := copy(filename,i+1,99);
  130.   old_drive := current_drive;
  131.   if pos(':',filename)=2 then begin
  132.     new_drive := filename[1];
  133.     change_drive(new_drive);
  134.     end
  135.   else
  136.     new_drive := old_drive;
  137.   {writeln('old: drive=',old_drive,'  dir=',old_dir);}
  138.   {writeln('new: drive=',new_drive,'  dir=',new_dir);}
  139.   old_dir := current_directory(new_drive,err);
  140.   change_directory(new_drive, new_dir, err);
  141.   found := FALSE;
  142.   assign (testfile,filex);
  143.   {$I-} reset (testfile); {$I+}
  144.   found := (IOResult = 0);
  145.   if found then
  146.     close (testfile);
  147.   exist := found;
  148.   change_directory(new_drive, old_dir, err);
  149.   if new_drive <> old_drive then
  150.     change_drive(old_drive);
  151. end; (* exist *)
  152.  
  153. function path_finder : line;
  154. const
  155.   name = 'PATH';
  156. type
  157.   carray = array[1..1024] of char;
  158. var
  159.   found          : boolean;
  160.   environ_string : string[255];
  161.   environ        : ^carray;
  162.   len,
  163.   start,
  164.   equal_pos,
  165.   null_pos       : integer;
  166. begin
  167.   found          := false;
  168.   environ        := ptr(memw[cseg:$2C],$0);
  169.   start := 1;
  170.   repeat
  171.     null_pos := start;
  172.     while environ^[null_pos]<>#0 do
  173.       null_pos := null_pos + 1;
  174.     len := null_pos - start;
  175.     environ_string[0] := chr(len);
  176.     move(environ^[start],environ_string[1],len);
  177.     equal_pos := pos('=',environ_string);
  178.     if equal_pos > 0 then
  179.       if name = copy(environ_string,1,equal_pos-1) then begin
  180.         path_finder := copy(environ_string,equal_pos+1,999);
  181.         found := true;
  182.         end;
  183.     start := null_pos + 1;
  184.   until ((found) or (environ^[start]=#0));
  185. end; (* func path_finder *)
  186.  
  187. function suche_file (var filename: line) : boolean;
  188. var
  189.   delim_pos       : byte;
  190.   sub_path,full_path    : line;
  191.   ok       : boolean;
  192.   drive : char;
  193.   dir : filename_type;
  194. begin
  195.   ok   := FALSE;
  196.   delim_pos   := 0;
  197.   sub_path   := '';
  198.   drive := current_drive;
  199.   dir := current_directory(drive,delim_pos);
  200.   if exist (dir+filename) then begin
  201.     ok := TRUE;
  202.     filename := dir+filename;
  203.     end
  204.   else begin
  205.     full_path   := path_finder;
  206.     delim_pos   := pos (';',full_path);
  207.     repeat
  208.       sub_path := '';
  209.       if (delim_pos>0) then begin
  210.         sub_path := copy (full_path,1,delim_pos-1);
  211.         delete (full_path,1,delim_pos);
  212.         end
  213.       else begin
  214.         sub_path := full_path;
  215.         full_path := '';
  216.         end;
  217.       if (copy (sub_path,length(sub_path),1) <> '\') then
  218.         sub_path := sub_path + '\';
  219.       delim_pos := 0;
  220.       delim_pos := pos (';',full_path);
  221.       ok := exist (sub_path+filename);
  222.     until ok or (full_path='');
  223.     if ok then
  224.       filename := sub_path + filename;
  225.     suche_file := ok;
  226.     end;
  227. end; (* suche_file *)
  228.  
  229. (********************** A little demonstration ... **************************)
  230. begin
  231.   getparm(input);
  232.   write('file? ');
  233.   readln(input);
  234.   if (input <> '') then
  235.     if suche_file (input) then
  236.       writeln ('Your file was found as "',input,'"')
  237.     else
  238.       writeln ('The file "',input,'" cannot be found on PATH.');
  239.   halt;
  240.   intr($20,regs);
  241. end.
  242.