home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frostbyte's 1980s DOS Shareware Collection
/
floppyshareware.zip
/
floppyshareware
/
USCX
/
TURBO-06.ZIP
/
CLIMB.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-02-23
|
22KB
|
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 }
{; (203) 334-6401 }
{; }
{; 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.