Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB08.ZIP/CLIMB.PAS

Pascal/Delphi Source File | 1986-03-09 | 21.5 KB | 558 lines

{.PL66}
{ $B-,C-,I-,R-,V-,U-,K- }
program climb; { Version V01.03 06/10/84 13:37 }

{ This routine allows you to climb directory trees using TURBO Pascal.    }
{                                                                         }
{Syntax: CLIMB (-|?)UP    (d:)    Examples:   CLIMB UP A:                 }
{                   DOWN                      CLIMB -DOWN C:              }
{                   LEFT                      CLIMB LEFT                  }
{                   RIGHT                     CLIMB -RIGHT                }
{                                             CLIMB ?L                    }
{                                             CLIMB -?RI                  }
{                                                                         }
{ All paramters may be in upper or lower case and abbreviated.  If the    }
{ "do quietly" hyphen or the "query" question mark is specified, there    }
{ must be no interleaving space between it and the subcommand.            }
{                                                                         }
{ When specified, the "do quietly" indicates that messages should be      }
{ suppressed.  This is useful in .BATs.                                   }
{                                                                         }
{ When the "query" question mark is specified, instead of moving in the   }
{ indicated direction, the command simply indicates what action would be  }
{ taken.  It may be useful in .BAT programs to see if you can descend in  }
{ a given direction, but not have the path indicated.  CLIMB allows you to}
{ specify both "do quietly" and "query" in either order as long as they   }
{ are the first two characters.  It is also possible to specify -- or ??  }
{ in which case the second - or ? is ignored.                             }
{                                                                         }
{ If a drive is not specified, the default drive is assumed.              }
{                                                                         }
{Up is obvious.  Down is the next lower path.  If there are multiple      }
{lower paths, the first alphabetically is choosen.  Left goes up a path,  }
{choses the next lower (alphabetically) path and descends to that.  Right }
{is the opposite of right: it goes up a path, choses the next higher path }
{alphabetically, and descends to that.                                    }
{                                                                         }
{If you can't climb in any direction, a nonzero return code is generated. }
{                                                                         }
{ Return code   Meaning                                                   }
{ 0..........   Successful climb                                          }
{ 1-18 ......   DOS error codes, see DOS Manual page D-14                 }
{ 20.........   No paths in that direction.                               }
{ 255........   Invalid parameter                                         }
{                                                                         }
{Note that messages generated are written to the DOS standard output      }
{device so you can pipe the messages to another file or device.           }
{                                                                         }
{ The following is a batch file that illustrates how CLIMB will allow you }
{ to examine every directory on a disk. The name of this file is          }
{ typically called TOUR.BAT in that is allows you to tour the directories }
{ on a disk.                                                              }
{                                                                         }
{echo off                                                                 }
{rem  This file "tours" all of the subdirectories using CLIMB             }
{chdir \                                                                  }
{:cmd_down                                                                }
{REM ********** Insert commands below*******************                  }
{REM ... First, display the directory ...                                 }
{cd                                                                       }
{REM ... Next, use your favorite directory command to list the contents   }
{REM ... This is a good place to use the public domain SDIR command.      }
{dir                                                                      }
{REM ********** Insert commands above*******************                  }
{climb -down                                                              }
{if errorlevel 1 goto right                                               }
{goto cmd_down                                                            }
{:right                                                                   }
{climb -right                                                             }
{if errorlevel 1 goto up                                                  }
{goto cmd_down                                                            }
{:up                                                                      }
{climb -up                                                                }
{if errorlevel 1 goto exit                                                }
{goto right                                                               }
{exit:                                                                    }
{Echo Tour is complete.                                                   }
{ .... End of TOUR.BAT ....                                               }
{                                                                         }
{ If you are compiling this program using TURBO Pascal Version 2.0,       }
{ you can eliminate the annoying clear screen everytime this program      }
{ runs.  This procedure can be applied to all Turbo Pascal programs for   }
{ which you wish to eliminate the clear screen during initialization,     }
{ provided they have been compiled using version 2.0 of the Turbo Pascal  }
{ compiler...                                                             }
{                                                                         }
{ DEBUG CLIMB.COM       <- Or any or compiled Turbo Pascal Program        }
{ -U 2FC                <- Make sure this is the right version            }
{ ssss:02FC INT 10      <- ssss will vary, first instruction listed       }
{                          must be the INT 10.  Others will follow.       }
{ -A 2FC                                                                  }
{ ssss:02FC NOP         <- type in NOP                                    }
{ ssss:02FD NOP         <- twice                                          }
{ ssss:02FE             <- press enter                                    }
{ -W                    <- this replaces the program                      }
{ Writing hhhh bytes                                                      }
{ -Q                    <- quit debug                                     }
{                                                                         }
{;                                                                        }
{; Copyright (c) 1984 Thomas J. Foth                                      }
{; All Rights Reserved                                                    }
{;                                                                        }
{; Permission is granted to freely distribute this code, but not for      }
{; profit and provided that the following address and disclaimer are      }
{; included.                                                              }
{;                                                                         }
{; Portions of this program may be used freely, in other works, provided   }
{; that credit to the author and this work appear with the portions used.  }
{;                                                                         }
{; The author's address:                                                   }
{;                                                                         }
{; Thomas J. Foth                                                          }
{; 260 Sunset Ave.                                                         }
{; Fairfield, CT 06880                                                     }
{; [phone]                                                          }
{;                                                                         }
{; Disclaimer:                                                             }
{;                                                                         }
{; This program is provided "as-is" without warranty of any kind, either   }
{; expressed or implied, including, but not limited to the implied         }
{; warranties of merchantability and fitness for a particular purpose.     }
{;                                                                         }
const
     readonly = $01;   { DOS 2.0 Attribute byte definitions }
     hidden   = $02;
     system   = $03;
     vollabel = $08;
     directory= $10;
     archive  = $20;
     mkdir    = $39;
     rmdir    = $3A;
     chdir    = $3B;
     del      = $41;
     chmod    = $43;
     find_1st = $4E;
     find_nxt = $4F;

type pathchar   = array[1..64] of char; { Used to communicate w/DOS }
     asciiz     = array[1..255] of char;{ This array is an ASCIIZ string }
     pathstring = string[255];          { For procedural calls }
     anystring  = string[255];

     DTAptr     = ^DTA;

     DTA    = record                    { The Disk Transfer Area mapped out }
               dos_usage: array[1..21] of char; { DOS internal usage        }
               attribute: byte;         { File attribute, see constants     }
               ftime    : integer;      { See page C-5 for explanation      }
               fdate    : integer;      { Ditto                             }
               fsize_lo : integer;      { See page C-6 for explanation      }
               fsize_hi : integer;      { Ditto                             }
               fname    : asciiz;       { filename.ext terminate by null byte}
              end;
var
   i, rc           : integer;

   lookup_pattern,
   current_path,
   new_path,
   low_path,
   upper_path,
   this_branch     : pathstring;

   parm            : string[11];
   parm1_drive     : char absolute CSeg:$5C;
   cparm1          : array[1..11] of char absolute CSeg:$5D;
   drive           : byte absolute CSeg:$6C;
   cparm2          : array[1..11] of char absolute CSeg:$6D;

   quietly,
   query           : boolean;

   current_DTA     : DTAptr;

function asz2str(to_be_fixed: asciiz): pathstring;
var
   i               : integer;
   tmp_str         : string[255];
begin;
 i:=1;
 tmp_str:='';
 while (to_be_fixed[i] <> chr(0)) and
       (i<=255) do
  begin;
   tmp_str := tmp_str+to_be_fixed[i];
   i:=i+1;
  end;
 asz2str := tmp_str;
end;

procedure get_current_path(drive: byte;
                           var the_path: pathstring;
                           var rc:integer);

{ Returns the current path in the form \path1\path2... for drive in
  the path.  If drive = 0, use current drive.  rc is dos return code. }
var
   regs            : record
                      ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
                     end;
   temp_chars      : asciiz;
   i               : integer;

begin
 regs.dx:=drive;
 regs.ds:=seg(temp_chars);
 regs.si:=ofs(temp_chars);
 regs.ax:=$4700;              { Get the current path }
 MsDos(regs);

 regs.flags := regs.flags and $0001;
 if  regs.flags = 1 then
 rc := regs.ax
 else
      begin;
       the_path:='\'+asz2str(temp_chars);
       rc := 0;
       for i:=1 to length(the_path) do
        if ord(copy(the_path,i,1)) > $60 then
         the_path:=copy(the_path,1,i-1)+
                   Upcase(copy(the_path,i,1))+
                   copy(the_path,i+1,255);
      end;
end;
function trunc_path(the_path: pathstring): pathstring;
{ This truncates the_path to an "upper" level path }

Var i              : integer;

begin;
   i:=length(the_path);
   while (i > 0) and (copy(the_path,i,1) <> '\') do i:=i-1;
   i := i - 1;
   if i <> 0 then
    trunc_path := copy(the_path,1,i)
    else trunc_path := '\';
end;
function this_path(the_path: pathstring): pathstring;
{ This truncates the_path to the current level path }

Var
   i               : integer;

begin;
   i:=length(the_path);
   while (i > 0) and (copy(the_path,i,1) <> '\') do i:=i-1;
    this_path := copy(the_path,i+1,255)
end;

procedure fscall(func_code: integer;
                 drive: byte;
                 the_path: pathstring;
                 mode: integer;
                 var rc:integer);

{ Perform a DOS2.0 file system call.  the_path must be in the
  form \path1\path2... If drive is 0, the current drive is specified.
  Specify drive=0 also allows the_path to take the form d:\path1\path2...}
var
   regs            : record
                      ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
                     end;
   full_path       : pathstring;

begin
 if drive = 0
  then full_path := concat(the_path,chr(0))
  else full_path := concat(CHR(64+drive),':',the_path,chr(0));
 regs.ds:=seg(full_path);
 regs.dx:=ofs(full_path)+1;
 regs.cx:=mode;
 regs.ax:=swap(func_code);
 MsDos(regs);


 regs.flags := regs.flags and $0001;
 if  regs.flags = 1 then
  rc := regs.ax
 else rc := 0;
end;

procedure stwrite(out_string:anystring);

{
Allows you to write a string to the standard output device, thus
allowing piping to take place
}
var
   regs            : record
                      ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
                     end;

begin
 regs.bx:=1;                  { Standard output device handle }
 regs.cx:=length(out_string);
 regs.ds:=seg(out_string);
 regs.dx:=ofs(out_string)+1;
 regs.ax:=$4000;
 MsDos(regs);

end;

procedure stwriteln(out_string:anystring);

{
Allows you to write a string to the standard output device, thus
allowing piping to take place
}
begin

 stwrite(out_string+chr(13)+chr(10));

end;

function GetDTA: DTAptr;
var
   regs            : record
                      ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
                     end;
begin;

 regs.ax:=$2F00;
 MsDos(regs);                    {Get the current DTA}
 GetDTA := Ptr(regs.es,regs.bx);
end;

procedure leave(rc:integer);
{Return to Dos with a return code }
var
   regs            : record
                      ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
                     end;
begin;

 regs.ax:=$4C00+rc;
 MsDos(regs);                    {Get the current DTA}
end;
procedure errmsg(rc:integer);
{write the error message associated with an error number}
var
   str_rc          : string[255];
begin;
Case rc of
 0: stwriteln('No error encountered');
 1: stwriteln('Invalid function number');
 2: stwriteln('File not found');
 3: stwriteln('Path not found');
 4: stwriteln('Too many files open');
 5: stwriteln('Access denied');
 6: stwriteln('Invalid handle');
 7: stwriteln('Memory control block destroyed');
 8: stwriteln('Insufficent memory');
 9: stwriteln('Invalid memory block address');
10: stwriteln('Invalid environment');
11: stwriteln('Invalid format');
12: stwriteln('Invalid access code');
13: stwriteln('Invalid data');
15: stwriteln('Invalid drive specified');
16: stwriteln('Attempt to remove the current directory');
17: stwriteln('Not same device');
18: stwriteln('No more files');
{ Non DOS error codes unique to this program }
20: stwriteln('No more paths in that direction');
255: stwriteln('Invalid parameters');
else str(rc,str_rc);
     stwriteln('Unknown error code: '+str_rc);
end;
end;

{
  Mainline begins here...
}

Begin;

 if (parm1_drive <> chr(0)    ) or      { Can't specify drive in 1st parm }
    (copy(cparm1,9,3) <> '   ') or      { nor an extension }
    (cparm2 <> '           '  ) then    { nor a second filename }
  begin;
   errmsg(255);
   leave(255);
  end;

 quietly := false;
 query   := false;

 parm:=''; { Convert PSP FCB1 to a string }
 for i:=1 to 8 do if cparm1[i]<>' ' then parm:=concat(parm,cparm1[i]);

 for i:= 1 to 2 do { see if do quietly or query were specified }
  begin;
   if copy(parm,1,1)='-' then
    begin;
     quietly := true;
     delete(parm,1,1);
    end
   else if copy(parm,1,1)='?' then
    begin;
     query := true;
     delete(parm,1,1);
    end;
  end;

 if parm = '' then  { User doesn't understand the syntax, so they them }
  begin;
   stwriteln('Climb syntax:');
   stwriteln(' ');
   stwriteln('CLIMB (-|?)UP      (d:)');
   stwriteln('CLIMB      DOWN');
   stwriteln('CLIMB      LEFT');
   stwriteln('CLIMB      RIGHT');
   leave(255);
 end;

 if Pos(parm,'UP') = 1 then parm:='UP'
    else if Pos(parm,'DOWN') = 1 then parm := 'DOWN'
    else if Pos(parm,'LEFT') = 1 then parm := 'LEFT'
    else if Pos(parm,'RIGHT') = 1 then parm := 'RIGHT' else
  begin;
   if not quietly then errmsg(255); { Bad syntax, so abort }
   leave(255);
  end;

 get_current_path(drive,current_path,rc); { Where are we now? }

 if rc<>0 then                            { If we get an error here     }
  begin;                                  { DOS is having REAL problems }
   if not quietly then errmsg(rc);
   leave(rc);
  end;

  if (current_path = '\') and             { Only valid direction from   }
    ((Pos(parm,'LEFT')=1) or              { root is down...             }
     (Pos(parm,'UP')=1) or
     (Pos(parm,'RIGHT')=1)) then
   begin;
    if not quietly then
     begin;
      errmsg(20);
      stwrite('Current path: ');
      if drive <> 0 then stwriteln(chr(64+drive)+':\')
                  else stwriteln('\');
     end;
    leave(20);
   end;

 if Pos(parm,'UP') = 1 then             { All going up is truncating the }
   new_path := trunc_path(current_path) { lowest branch...               }
  else
  begin;

   low_path:='';
   if Pos(parm,'LEFT') = 1 then
   for i:=1 to 8 do low_path:=low_path+chr(0) { low_path is now at low value }
   else for i:=1 to 8 do low_path:=low_path+chr(255); { or high value        }

   current_DTA:=GetDTA;                 { DOS leaves info in the DTA so we'd }
                                        { better find it...                  }

   this_branch:=this_path(current_path);{ Isolate the name of this branch    }

   if Pos(parm,'DOWN') = 1 then
    upper_path:=current_path            { look in this directory for DOWN    }
    else upper_path:=trunc_path(current_path); { else, we have to look above }

   if upper_path <> '\' then            { Specify the search string          }
    lookup_pattern:=upper_path+'\*.*'+chr(0)
    else lookup_pattern:='\*.*'+chr(0);

   fscall(find_1st,drive,lookup_pattern,directory,rc); { Go a'hunting        }

   while rc = 0 do
    begin;                               { Got one... (maybe)                }
     if ((current_DTA^.attribute and directory) = directory) and
         (current_DTA^.fname[1] <> '.') then  { Real directory?              }
      begin;
       if Pos(parm,'LEFT') = 1 then
        begin;
         if (asz2str(current_DTA^.fname) > low_path) and
            (asz2str(current_DTA^.fname) < this_branch)
          then low_path := asz2str(current_DTA^.fname);
        end
 {
  If we are going left, we want a directory that is lower than the current
  branch, yet higher than anything else...
 }
        else if Pos(parm,'RIGHT') = 1 then
         begin;
          if (asz2str(current_DTA^.fname) < low_path) and
             (asz2str(current_DTA^.fname) > this_branch)
           then low_path := asz2str(current_DTA^.fname);
         end
 {
  Right directories, on the other hand, are higher than this directory, but
  lower than everything else.
 }
         else
          begin;
            if (asz2str(current_DTA^.fname) < low_path)
             then low_path := asz2str(current_DTA^.fname);
          end;
 {
  And finally down directories are the lowest directory in the current
  directory.
 }
      end;
     fscall(find_nxt,drive,lookup_pattern,directory,rc); { Do it again... }
    end;

  if (copy(low_path,1,1)=chr(255))
     or (copy(low_path,1,1)=chr(0)) then  {If not set, we didn't find anything}
   begin;                                 {that qualified                     }
    if not quietly then
     begin;
      errmsg(20);
      stwrite('Current path: ');
      if drive=0 then stwriteln(current_path)
                  else stwriteln(chr(64+drive)+':'+current_path);
     end;
    leave(20);
   end;

  if upper_path <> '\' then               { Make the string for chdir }
   new_path := upper_path+'\'+low_path
  else new_path := '\'+low_path;

 end;

 if query then                            { If only a query, just show it }
  begin;
   if not quietly then
    begin;
     stwriteln('Current path: '+current_path);
     stwrite('Next path '+parm+': ');
     if drive = 0 then stwriteln(new_path)
        else stwriteln(chr(64+drive)+':'+new_path);
    end;
   leave(0)
  end
 else
  begin;

   fscall(chdir,drive,new_path,0,rc);     { else, chnage to it }

   if not quietly then
    begin;
     if  rc = 0  then
      begin;
       stwrite('Climbed '+parm+' to ');
       if drive = 0 then stwriteln(new_path)
        else stwriteln(chr(64+drive)+':'+new_path);
      end
      else errmsg(rc);
    end;

   Leave(rc);
  end;
end.