mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-23 00:14:25 +00:00
548 lines
18 KiB
Plaintext
548 lines
18 KiB
Plaintext
|
||
/* C P / M - M P / M D I R E C T O R Y C O M M O N (SDIR) */
|
||
|
||
/* B E G I N N I N G O F C O M M O N M A I N M O D U L E */
|
||
|
||
|
||
/* This module is included in main80.plm or main86.plm. */
|
||
/* The differences between 8080 and 8086 versions are */
|
||
/* contained in the modules main80.plm, main86.plm and */
|
||
/* dpb80.plm, dpb86.plm and the submit files showing */
|
||
/* the different link and location addresses. */
|
||
|
||
|
||
$include (comlit.lit)
|
||
$include (mon.plm)
|
||
|
||
dcl patch (128) address;
|
||
|
||
/* Scanner Entry Points in scan.plm */
|
||
|
||
scan: procedure(pcb$adr) external;
|
||
declare pcb$adr address;
|
||
end scan;
|
||
|
||
scan$init: procedure(pcb$adr) external;
|
||
declare pcb$adr address;
|
||
end scan$init;
|
||
|
||
/* -------- Routines in other modules -------- */
|
||
|
||
search$init: procedure external; /* initialization of search.plm */
|
||
end search$init;
|
||
|
||
get$files: procedure external; /* entry to search.plm */
|
||
end get$files;
|
||
|
||
sort: procedure external; /* entry to sort.plm */
|
||
end sort;
|
||
|
||
mult23: procedure (num) address external; /* in sort.plm */
|
||
dcl num address;
|
||
end mult23;
|
||
|
||
display$files: procedure external; /* entry to disp.plm */
|
||
end display$files;
|
||
|
||
/* -------- Routines in util.plm -------- */
|
||
|
||
printb: procedure external;
|
||
end printb;
|
||
|
||
print$char: procedure(c) external;
|
||
dcl c byte;
|
||
end print$char;
|
||
|
||
print: procedure(string$adr) external;
|
||
dcl string$adr address;
|
||
end print;
|
||
|
||
crlf: procedure external;
|
||
end crlf;
|
||
|
||
p$decimal: procedure(value,fieldsize,zsup) external;
|
||
dcl value address,
|
||
fieldsize address,
|
||
zsup boolean;
|
||
end p$decimal;
|
||
|
||
|
||
/* ------------------------------------- */
|
||
|
||
dcl debug boolean public initial (false);
|
||
|
||
/* -------- version information -------- */
|
||
|
||
dcl (os,bdos) byte public;
|
||
$include (vers.lit)
|
||
|
||
$include (fcb.lit)
|
||
|
||
$include(search.lit)
|
||
|
||
dcl find find$structure public initial
|
||
(false,false,false,false, false,false,false,false);
|
||
|
||
dcl
|
||
num$search$files byte public initial(0),
|
||
search (max$search$files) search$structure public;
|
||
|
||
dcl first$f$i$adr address external;
|
||
dcl get$all$dir$entries boolean public;
|
||
dcl first$pass boolean public;
|
||
|
||
dcl usr$vector address public initial(0), /* bits for user #s to scan */
|
||
active$usr$vector address public, /* active users on curdrv */
|
||
drv$vector address initial (0); /* bits for drives to scan */
|
||
|
||
$include (format.lit)
|
||
|
||
dcl format byte public initial (form$full),
|
||
page$len address public initial (0ffffh),
|
||
/* lines on a page before printing new headers, 0 forces initial hdrs */
|
||
message boolean public initial(false),/* show titles when no files found*/
|
||
formfeeds boolean public initial(false);/* use form feeds */
|
||
|
||
dcl file$displayed boolean external;
|
||
/* true if 1 or more files displayed by dsh.plm */
|
||
|
||
dcl sort$op boolean initial (true); /* default is to do sorting */
|
||
dcl sorted boolean external; /* if successful sort */
|
||
|
||
|
||
dcl cur$usr byte public, /* current user being searched */
|
||
cur$drv byte public; /* current drive " " */
|
||
|
||
/* -------- BDOS calls --------- */
|
||
|
||
get$version: procedure address; /* returns current version information */
|
||
return mon2(12,0);
|
||
end get$version;
|
||
|
||
select$drive: procedure(d);
|
||
declare d byte;
|
||
call mon1(14,d);
|
||
end select$drive;
|
||
|
||
search$first: procedure(d) byte external;
|
||
dcl d address;
|
||
end search$first;
|
||
|
||
search$next: procedure byte external;
|
||
end search$next;
|
||
|
||
get$cur$drv: procedure byte; /* return current drive number */
|
||
return mon2(25,0);
|
||
end get$cur$drv;
|
||
|
||
getlogin: procedure address; /* get the login vector */
|
||
return mon3(24,0);
|
||
end getlogin;
|
||
|
||
getusr: procedure byte; /* return current user number */
|
||
return mon2(32,0ffh);
|
||
end getusr;
|
||
|
||
terminate: procedure public;
|
||
if os = mpm then
|
||
call mon1(0,143); /* MP/M */
|
||
else
|
||
call mon1 (0,0); /* CP/M */
|
||
end terminate;
|
||
|
||
|
||
/* -------- Utility routines -------- */
|
||
|
||
number: procedure (char) boolean;
|
||
dcl char byte;
|
||
return(char >= '0' and char <= '9');
|
||
end number;
|
||
|
||
make$numeric: procedure(char$adr,len,val$adr) boolean;
|
||
dcl (char$adr, val$adr, place) address,
|
||
chars based char$adr (1) byte,
|
||
value based val$adr address,
|
||
(i,len) byte;
|
||
|
||
value = 0;
|
||
place = 1;
|
||
do i = 1 to len;
|
||
if not number(chars(len - i)) then
|
||
return(false);
|
||
value = value + (chars(len - i) - '0') * place;
|
||
place = place * 10;
|
||
end;
|
||
return(true);
|
||
end make$numeric;
|
||
|
||
set$vec: procedure(v$adr,num) public;
|
||
dcl v$adr address, /* set bit number given by num */
|
||
vector based v$adr address, /* 0 <= num <= 15 */
|
||
num byte;
|
||
if num = 0 then
|
||
vector = vector or 1;
|
||
else
|
||
vector = vector or shl(double(1),num);
|
||
end set$vec;
|
||
|
||
bit$loc: procedure(vector) byte;
|
||
/* return location of right most on bit vector */
|
||
dcl vector address, /* 0 - 15 */
|
||
i byte;
|
||
i = 0;
|
||
do while i < 16 and (vector and double(1)) = 0;
|
||
vector = shr(vector,1);
|
||
i = i + 1;
|
||
end;
|
||
return(i);
|
||
end bit$loc;
|
||
|
||
get$nxt: procedure(vector$adr) byte;
|
||
dcl i byte,
|
||
(vector$adr,mask) address,
|
||
vector based vector$adr address;
|
||
/* if debug then
|
||
do; call print(.(cr,lf,'getnxt: vector = $'));
|
||
call pdecimal(vector,10000,false);
|
||
end; */
|
||
|
||
if (i := bit$loc(vector)) > 15 then
|
||
return(0ffh);
|
||
mask = 1;
|
||
if i > 0 then
|
||
mask = shl(mask,i);
|
||
vector = vector xor mask; /* turn off bit */
|
||
/* if debug then
|
||
do; call print(.(cr,lf,'getnxt: vector, i, mask $'));
|
||
call pdecimal(vector,10000,false);
|
||
call printb;
|
||
call pdecimal(i,10000,false);
|
||
call printb;
|
||
call pdecimal(mask,10000,false);
|
||
end; */
|
||
return(i);
|
||
end get$nxt; /* too bad plm rotates only work on byte values */
|
||
|
||
help: procedure; /* show options for this program */
|
||
|
||
call print(.(cr,lf,
|
||
tab,tab,tab,'SDIR EXAMPLES',cr,lf,lf,
|
||
'sdir file.one',tab,tab,tab,
|
||
'(find a file on current user and default drive)',cr,lf,
|
||
'sdir *.com d:*.pli',tab,tab,'(find matching files on default and d: drive)',
|
||
cr,lf,
|
||
'sdir [rw]',tab,tab,tab,'(find files that are read/write)',cr,lf,
|
||
'sdir [ro dir sys]',tab,tab,'(same for read/only, directory, system)',cr,lf,
|
||
'sdir [xfcb]',tab,tab,tab,'(find files with XFCB''s)',cr,lf,
|
||
'sdir [nonxfcb]',tab,tab,tab,'(find files without XFCB''s)',cr,lf,
|
||
'sdir [exclude] *.com',tab,tab,'(find files that don''t end in ''com'')',cr,lf,
|
||
'sdir [nosort]',tab,tab,tab,'(don''t sort the files)',cr,lf,
|
||
'sdir [full]',tab,tab,tab,'(show all file information)',cr,lf,
|
||
'sdir [size]',tab,tab,tab,'(show name and size in kilobytes)',cr,lf,
|
||
'sdir [short]',tab,tab,tab,'(show just the file names)',cr,lf,
|
||
'sdir [drive = all]',tab,tab,'(search all logged in drives)',cr,lf,
|
||
'sdir [drive = (a,b,p)]',tab,tab,
|
||
'(search specified drives, ''disk'' is synonym)',cr,lf,
|
||
'sdir [user = all]',tab,tab,'(find files with any user number)',cr,lf,
|
||
'sdir [user = (0,1,15)]',tab,tab,'(find files with specified user number)',
|
||
cr,lf,
|
||
'sdir [length = n]',tab,tab,'(print headers every n lines)',cr,lf,
|
||
'sdir [ff]',tab,tab,tab,'(print form feeds between headers)',cr,lf,
|
||
'sdir [message user=all]',tab,tab,'(show user/drive areas with no files)',
|
||
cr,lf,
|
||
'sdir [help]',tab,tab,tab,'(show this message)',cr,lf,
|
||
'sdir [dir sys rw ro sort xfcb nonxfcb full] d:*.*',tab,'(defaults)$'));
|
||
|
||
call terminate;
|
||
end help;
|
||
|
||
|
||
/* -------- Scanner Infor -------- */
|
||
|
||
$include (scan.lit)
|
||
|
||
dcl pcb pcb$structure
|
||
initial (0,.buff(0),.fcb,0,0,0,0) ;
|
||
|
||
dcl token based pcb.token$adr (12) byte;
|
||
dcl got$options boolean;
|
||
|
||
get$options: procedure;
|
||
dcl temp byte;
|
||
|
||
do while pcb.scan$adr <> 0ffffh and ((pcb.tok$typ and t$op) <> 0);
|
||
if pcb.nxt$token <> t$mod then
|
||
do; /* options with no modifiers */
|
||
if token(1) = 'D' and token(2) = 'I' then
|
||
find.dir = true;
|
||
/* else if token(1) = 'D' and token(2) = 'E' then
|
||
debug = true; */
|
||
else if token(1) = 'E' then
|
||
find.exclude = true;
|
||
else if token(1) = 'F'then
|
||
if token(2) = 'F' then
|
||
formfeeds = true;
|
||
else if token(2) = 'U' then
|
||
format = form$full;
|
||
else goto op$err;
|
||
else if token(1) = 'H' then
|
||
call help;
|
||
else if token(1) = 'M' then
|
||
message = true;
|
||
else if token(1) = 'N' then
|
||
if token(4) = 'X' then
|
||
find.nonxfcb = true;
|
||
else if token(3) = 'S' then
|
||
sort$op = false;
|
||
else goto op$err;
|
||
/* else if token(1) = 'P' then
|
||
find.pass = true; */
|
||
else if token(1) = 'S' then
|
||
if token(2) = 'Y' then
|
||
find.sys = true;
|
||
else if token(2) = 'H' then
|
||
format = form$short;
|
||
else if token(2) = 'I' then
|
||
format = form$size;
|
||
else if token(2) = 'O' then
|
||
sort$op = true;
|
||
else goto op$err;
|
||
else if token(1) = 'R' and token(2) = 'O' then
|
||
find.ro = true;
|
||
else if token(1) = 'R' and token(2) = 'W' then
|
||
find.rw = true;
|
||
else if token(1) = 'X' then
|
||
find.xfcb = true;
|
||
else goto op$err;
|
||
call scan(.pcb);
|
||
end;
|
||
else
|
||
do; /* options with modifiers */
|
||
if token(1) = 'L' then
|
||
do;
|
||
call scan(.pcb);
|
||
if (pcb.tok$typ and t$numeric) <> 0 then
|
||
if make$numeric(.token(1),pcb.token$len,.page$len) then
|
||
if page$len < 5 then
|
||
goto op$err;
|
||
else call scan(.pcb);
|
||
else goto op$err;
|
||
else goto op$err;
|
||
end;
|
||
else if token(1) = 'U' then
|
||
do;
|
||
/* if debug then
|
||
call print(.(cr,lf,'In User option$')); */
|
||
call scan(.pcb);
|
||
if ((pcb.tok$typ and t$mod) = 0) or bdos < bdos20 then
|
||
goto op$err;
|
||
do while (pcb.tok$typ and t$mod) <> 0 and
|
||
pcb.scan$adr <> 0ffffh;
|
||
if token(1) = 'A' and token(2) = 'L' then
|
||
usr$vector = 0ffffh;
|
||
else if (pcb.tok$typ and t$numeric) <> 0
|
||
and pcb.token$len < 3 then
|
||
do;
|
||
if pcb.token$len = 1 then
|
||
temp = token(1) - '0';
|
||
else
|
||
temp = (token(1) - '0') * 10 + (token(2) - '0');
|
||
if temp >= 0 and temp <= 15 then
|
||
call set$vec(.usr$vector,temp);
|
||
else goto op$err;
|
||
end;
|
||
else goto op$err;
|
||
call scan(.pcb);
|
||
end;
|
||
end;
|
||
else if token(1) = 'D' and (token(2) = 'R' or token(2) = 'I') then
|
||
do; /* allow DRIVE or DISK */
|
||
call scan(.pcb);
|
||
if (pcb.tok$typ and t$mod) = 0 then
|
||
goto op$err;
|
||
do while (pcb.tok$typ and t$mod ) <> 0 and
|
||
pcb.scan$adr <> 0ffffh;
|
||
if token(1) = 'A' and token(2) = 'L' then
|
||
do;
|
||
drv$vector = 0ffffh;
|
||
drv$vector = drv$vector and get$login;
|
||
end;
|
||
else if token(1) >= 'A' and token(1) <= 'P' then
|
||
call set$vec(.drv$vector,token(1) - 'A');
|
||
else goto op$err;
|
||
call scan(.pcb);
|
||
end;
|
||
end; /* drive option */
|
||
else goto op$err;
|
||
end; /* options with modifiers */
|
||
end; /* do while */
|
||
|
||
got$options = true;
|
||
return;
|
||
|
||
op$err:
|
||
call print(.('Illegal Option or Modifier$'));
|
||
call terminate;
|
||
end get$options;
|
||
|
||
get$file$spec: procedure;
|
||
dcl i byte;
|
||
if num$search$files < max$search$files then
|
||
do;
|
||
call move(f$namelen + f$typelen,.token(1),
|
||
.search(num$search$files).name(0));
|
||
|
||
if search(num$search$files).name(f$name - 1) = ' ' and
|
||
search(num$search$files).name(f$type - 1) = ' ' then
|
||
search(num$search$files).anyfile = true; /* match on any file */
|
||
else search(num$search$files).anyfile = false;/* speedier compare */
|
||
|
||
if token(0) = 0 then
|
||
search(num$search$files).drv = 0ffh; /* no drive letter with */
|
||
else /* file spec */
|
||
search(num$search$files).drv = token(0) - 1;
|
||
/* 0ffh in drv field indicates to look on all drives that will be */
|
||
/* scanned as set by the "drive =" option, see "match:" proc in */
|
||
/* search.plm module */
|
||
|
||
num$search$files = num$search$files + 1;
|
||
end;
|
||
else
|
||
do; call print(.('File Spec Limit is $'));
|
||
call p$decimal(max$search$files,100,true);
|
||
call crlf;
|
||
end;
|
||
call scan(.pcb);
|
||
end get$file$spec;
|
||
|
||
set$defaults: procedure;
|
||
/* set defaults if not explicitly set by user */
|
||
if not (find.dir or find.sys) then
|
||
find.dir, find.sys = true;
|
||
if not(find.ro or find.rw) then
|
||
find.rw, find.ro = true;
|
||
|
||
if find.xfcb or find.nonxfcb then
|
||
do; if format = form$short then
|
||
format = form$full;
|
||
end;
|
||
else /* both xfcb and nonxfcb are off */
|
||
find.nonxfcb, find.xfcb = true;
|
||
|
||
if num$search$files = 0 then
|
||
do;
|
||
search(num$search$files).anyfile = true;
|
||
search(num$search$files).drv = 0ffh;
|
||
num$search$files = 1;
|
||
end;
|
||
|
||
if drv$vector = 0 then
|
||
do i = 0 to num$search$files - 1;
|
||
if search(i).drv = 0ffh then search(i).drv = cur$drv;
|
||
call set$vec(.drv$vector,search(i).drv);
|
||
end;
|
||
else /* a "[drive =" option was found */
|
||
do i = 0 to num$search$files - 1;
|
||
if search(i).drv <> 0ffh and search(i).drv <> cur$drv then
|
||
do; call print(.('Illegal Global/Local Drive Spec Mixing$'));
|
||
call terminate;
|
||
end;
|
||
end;
|
||
if usr$vector = 0 then
|
||
call set$vec(.usr$vector,get$usr);
|
||
end set$defaults;
|
||
|
||
dcl (save$uvec,temp) address;
|
||
dcl i byte;
|
||
declare last$dseg$byte byte
|
||
initial (0);
|
||
|
||
plm$start: procedure public;
|
||
os = high(get$version);
|
||
bdos = low(get$version);
|
||
|
||
/* note - initialized declarations set defaults */
|
||
cur$drv = get$cur$drv;
|
||
call scan$init(.pcb);
|
||
call scan(.pcb);
|
||
got$options = false;
|
||
do while pcb.scan$adr <> 0ffffh;
|
||
if (pcb.tok$typ and t$op) <> 0 then
|
||
if got$options = false then
|
||
call get$options;
|
||
else
|
||
do;
|
||
call print (.('Group Options Together$'));
|
||
call terminate;
|
||
end;
|
||
else if (pcb.tok$typ and t$filespec) <> 0 then
|
||
call get$file$spec;
|
||
else
|
||
do;
|
||
call print(.('Illegal Command Tail$'));
|
||
call terminate;
|
||
end;
|
||
end;
|
||
|
||
call set$defaults;
|
||
|
||
/* main control loop */
|
||
|
||
call search$init; /* set up memory pointers for subsequent storage */
|
||
|
||
do while (cur$drv := get$nxt(.drv$vector)) <> 0ffh;
|
||
call select$drive(cur$drv);
|
||
save$uvec = usr$vector; /* user numbers to search on each drive */
|
||
active$usr$vector = 0; /* users active on cur$drv */
|
||
cur$usr = get$nxt(.usr$vector); /* get first user num and mask */
|
||
get$all$dir$entries = false; /* off it off */
|
||
if usr$vector <> 0 and format <> form$short then
|
||
/* find high water mark if */
|
||
do; /* more than one user requested */
|
||
fcb(f$drvusr) = '?';
|
||
i = search$first(.fcb); /* get first directory entry */
|
||
temp = 0;
|
||
do while i <> 255;
|
||
temp = temp + 1;
|
||
i = search$next;
|
||
end; /* is there enough space in the */
|
||
/* worst case ? */
|
||
if maxb > mult23(temp) + shl(temp,1) then
|
||
get$all$dir$entries = true; /* location of last possible */
|
||
end; /* file info record and add */
|
||
first$pass = true; /* room for sort indices */
|
||
active$usr$vector = 0ffffh;
|
||
do while cur$usr <> 0ffh;
|
||
/* if debug then
|
||
call print(.(cr,lf,'in user loop $')); */
|
||
call set$vec(.temp,cur$usr);
|
||
if (temp and active$usr$vector) <> 0 then
|
||
do;
|
||
if format <> form$short and
|
||
(first$pass or not get$all$dir$entries) then
|
||
do;
|
||
call getfiles; /* collect files in memory and */
|
||
first$pass = false; /* build the active usr vector */
|
||
sorted = false; /* sort module will set sorted */
|
||
if sort$op then /* to true, if successful sort */
|
||
call sort;
|
||
end;
|
||
call display$files;
|
||
end;
|
||
cur$usr = get$nxt(.usr$vector);
|
||
end;
|
||
usr$vector = save$uvec; /* restore user vector for nxt */
|
||
end; /* do while drv$usr drive scan */
|
||
|
||
|
||
if not file$displayed and not message then
|
||
call print(.('File Not Found.$'));
|
||
call terminate;
|
||
end plm$start;
|
||
|
||
error:
|
||
call terminate;
|
||
|
||
end sdir;
|
||
|
||
|