Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FD.ZIP/FD.PAS

Pascal/Delphi Source File | 1988-05-01 | 5.6 KB | 174 lines

program find_directory;   { TP 3.0 }
{
  Searches for and takes a user to the directory specified on command line.
  User may specify 1 or more characters; program will change to first
  matching directory (wildcards are not permitted).

  In addition to being a useful utility, I would like this program to serve
  as an example of one of the more powerful and complex features of Pascal:
  recursion.

  JEP 4/88
}

{$p512}                       { Enable I/O redirection }

const
   dtalength = 43;
   filenamelength = 12;       { filename.ext -> 12 }
   pathlength = 64;           { max characters DOS allows in a path specifier }
   maxdirectories = 32;       { we'll allow this many directories per level }

type
   registers = record
                  case byte of
                     0 : (ax,bx,cx,dx,bp,si,di,ds,es,flags : integer);
                     1 : (al,ah,bl,bh,cl,ch,dl,dh : byte);
               end;
   filename = string[filenamelength];
   pathname = string[pathlength];
   disk_transfer_area = array[1..dtalength] of char;
   directory = record
                  numentries : integer;
                  fname : array[1..maxdirectories] of filename;
               end;

var
   thedir : pathname;
   destdir : filename;
   dta : disk_transfer_area;
   regs : registers;


procedure set_dta_address(segment,offset : integer);
begin
   regs.ah:=$1a;
   regs.ds:=segment;
   regs.dx:=offset;
   msdos(regs);
end;

procedure load_first(var specifier : pathname; var rc : integer);
begin
   specifier:=specifier+chr(0);             { path must be ASCIIZ string }
   regs.ah:=$4e;
   regs.ds:=seg(specifier[1]);
   regs.dx:=ofs(specifier[1]);
   regs.cx:=$0010;       { search attribute: $0010 -> search for subdirs }
   msdos(regs);
   rc:=regs.ax;
end;

procedure load_next(var rc : integer);
begin
   regs.ah:=$4f;
   msdos(regs);
   rc:=regs.ax;
end;

procedure parse_dta(var fname : filename; var attribute : integer);
var
   i : integer;
begin
   i:=31;                                 { filename at offset 31 in dta }
   repeat
      fname[i-30]:=dta[i];
      i:=i+1;
   until (dta[i]=chr(0));                 { filename terminated by hex 0 }
   fname[0]:=chr(i-31);                  { put string length in 0th byte }
   attribute:=ord(dta[22]);
end;

procedure get_directory(dirname : pathname; var dir : directory);
var
   rc,attribute : integer;
   fname : filename;
begin
   dir.numentries:=0;
   load_first(dirname,rc);
   while (rc = 0) and (dir.numentries < maxdirectories) do begin
      parse_dta(fname,attribute);
      { avoid regular files and the current and root listings }
      if ((attribute and $10)<>0) and (fname<>'.') and (fname<>'..') then begin
         dir.numentries:=dir.numentries+1;
         dir.fname[dir.numentries]:=fname;
      end;
      load_next(rc);
   end;
end;

procedure validate_parms(var parms : filename);
{ Returns parms capitalized if it is ok, '' otherwise }
var
   i : integer;
begin
   i:=1;
   while (i<=length(parms)) do begin
      { don't want illegal characters in the directory name }
      if (parms[i] in ['?','*','.','"','/','\','[',']',':','|','<','>','+','=',';',',']) then
         parms:='' { will terminate loop - crafty or kludgy, take your pick }
      else
         parms[i]:=upcase(parms[i]);
      i:=i+1;
   end;
end;

procedure help;
begin
   writeln;
   writeln('FD (Find Directory) - Subdirectory scan utility - JEP 4/88');
   writeln;
   writeln('Syntax: FD dest');
   writeln;
   writeln('        dest - 1 or more characters specifying the name of a directory ');
   writeln('               for FD to locate and change to.  dest may not contain');
   writeln('               multiple levels (or the "\" character), or an extension.');
   writeln('               If more than one directory is a match, FD will change to');
   writeln('               the first match it finds.  Wildcards may NOT be used.');
   writeln;
end;

procedure trace_directory(startdir,destdir : pathname; var thedir : pathname);
{
   Recursive procedure to check the immediate children of a directory.
   Parameters are: startdir - a path specifying the directory to begin the
                              search in (initial call passes '', signifying
                              the root)
                   destdir - the directory we are searching for; input
                             from command line and passed in initial call;
                             carried to all levels solely for comparison.
                   thedir - the path specifier for the destination directory;
                            has value of '' if no match found.
}
var
   dir_list : directory;
   i : integer;
   curdir : pathname;
begin
   get_directory(startdir+'\*.',dir_list);   { get all children of startdir }
   i:=1;
   thedir:='';
   while (i<=dir_list.numentries) and (thedir='') do begin
      curdir:=startdir+'\'+dir_list.fname[i];
      clreol;                                     { do the fancy output }
      write('Tracing: ',curdir,chr(13));
      if pos(destdir,dir_list.fname[i]) = 1 then { if it matches destdir }
         thedir:=curdir                           { save it, ending the loop }
      else                                        { otherwise }
         trace_directory(curdir,destdir,thedir);  { search its children }
      i:=i+1;
   end;
end;

begin { main }
   destdir:=paramstr(1);
   validate_parms(destdir);
   if destdir<>'' then begin
      set_dta_address(seg(dta),ofs(dta));
      trace_directory('',destdir,thedir);
      chdir(thedir);
   end
   else
      help;
end.