mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-26 18:04:07 +00:00
Upload
Digital Research
This commit is contained in:
571
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/DSH.PLM
Normal file
571
MPM OPERATING SYSTEMS/MPM II/MPM II SOURCE/UTIL7/DSH.PLM
Normal file
@@ -0,0 +1,571 @@
|
||||
$title ('SDIR - Show')
|
||||
|
||||
/*
|
||||
Copyright (C) 1981
|
||||
Digital Research
|
||||
P.O. Box 579
|
||||
Pacific Grove, CA 93950
|
||||
|
||||
Revised:
|
||||
14 Sept 81 by Danny Horovitz
|
||||
*/
|
||||
|
||||
dshow:
|
||||
do;
|
||||
/* display module for extended directory */
|
||||
|
||||
/* commonly used macros */
|
||||
|
||||
declare dcl literally 'declare',
|
||||
lit literally 'literally',
|
||||
true literally '1',
|
||||
false literally '0',
|
||||
boolean literally 'byte',
|
||||
cr literally '13',
|
||||
lf literally '10',
|
||||
ff literally '12';
|
||||
|
||||
dcl buff(128) byte external,
|
||||
fcb (35) byte external;
|
||||
|
||||
dcl (cur$drv, cur$usr) byte external;
|
||||
|
||||
dcl (os,bdos) byte external,
|
||||
bdos20 lit '20H',
|
||||
bdos30 lit '30H',
|
||||
mpm lit '10H';
|
||||
|
||||
dcl used$de address external; /* number of used directory entries */
|
||||
|
||||
dcl sorted boolean external;
|
||||
dcl filesfound address external;
|
||||
|
||||
dcl search$ops address external, /* search options */
|
||||
s$dir lit '1',
|
||||
s$sys lit '2',
|
||||
s$ro lit '4',
|
||||
s$rw lit '8',
|
||||
s$xfcb lit '32', /* show files with xfcbs */
|
||||
s$nonxfcb lit '64', /* " " without xfcbs */
|
||||
s$exclude lit '128';
|
||||
|
||||
dcl format byte external, /* format is one of the following */
|
||||
page$len address external, /* page size before printing new headers */
|
||||
message boolean external, /* print titles and msg when no file found */
|
||||
formfeeds boolean external, /* use form feeds to separate headers */
|
||||
form$short lit '0',
|
||||
form$size lit '1',
|
||||
form$full lit '2';
|
||||
|
||||
dcl file$displayed boolean public initial (false);
|
||||
|
||||
declare /* directory label: special case of XFCB */
|
||||
dirlabel byte external,
|
||||
dirlabeltype lit '20', /* identifier on disk */
|
||||
dl$databyte lit '12', /* data byte */
|
||||
dl$password lit '128', /* masks on data byte */
|
||||
dl$access lit '64',
|
||||
dl$update lit '32',
|
||||
dl$makexfcb lit '16',
|
||||
dl$exists lit '1';
|
||||
|
||||
dcl
|
||||
buf$fcb$adr address external, /* index into directory buffer */
|
||||
buf$fcb based buf$fcb$adr (32) byte,
|
||||
/* fcb template for dir */
|
||||
|
||||
(f$i$adr,last$f$i$adr,end$adr) address external,
|
||||
cur$file address, /* number of file currently */
|
||||
/* being displayed */
|
||||
|
||||
/* structure of file info */
|
||||
file$info based f$i$adr structure(
|
||||
usr byte,
|
||||
name (8) byte,
|
||||
type (3) byte,
|
||||
bytes address, /* byte count (mod kilobyte) */
|
||||
kbytes address, /* kilobyte count */
|
||||
recs$lword address, /* record count is 3 byte value */
|
||||
recs$hbyte byte, /* low word, high byte */
|
||||
hash$link address,
|
||||
x$i$adr address), /* index into time stamp array for */
|
||||
/* this file */
|
||||
|
||||
x$i$adr address external,
|
||||
xfcb$info based x$i$adr structure (
|
||||
create (4) byte,
|
||||
update (4) byte,
|
||||
passmode byte);
|
||||
|
||||
dcl f$i$indices$base address external, /* if sorted then f$i$indices */
|
||||
f$i$indices based f$i$indices$base (1) address; /* are here */
|
||||
|
||||
dcl dpb$adr address external, /* disk parameter block address */
|
||||
dpb based dpb$adr structure
|
||||
(spt address, blkshf byte, blkmsk byte, extmsk byte, blkmax address,
|
||||
dirmax address, dirblk address, chksiz address, offset address);
|
||||
|
||||
printchar: procedure (char) external;
|
||||
dcl char byte;
|
||||
end printchar;
|
||||
|
||||
print: procedure (string$adr) external; /* BDOS call # 9 */
|
||||
dcl string$adr address;
|
||||
end print;
|
||||
|
||||
search$first: procedure(fcb$adr) byte external;
|
||||
dcl fcb$adr address;
|
||||
end search$first;
|
||||
|
||||
search$next: procedure byte external;
|
||||
end search$next;
|
||||
|
||||
break: procedure external;
|
||||
end break;
|
||||
|
||||
display$time$stamp: procedure (ts$adr) external; /* in dts.plm */
|
||||
dcl ts$adr address;
|
||||
end display$time$stamp;
|
||||
|
||||
printb: procedure external;
|
||||
end printb;
|
||||
|
||||
crlf: procedure external;
|
||||
end crlf;
|
||||
|
||||
printfn: procedure(fname$adr) external;
|
||||
dcl fname$adr address;
|
||||
end printfn;
|
||||
|
||||
pdecimal: procedure(v,prec,zerosup) external;
|
||||
/* print value val, field size = (log10 prec) + 1 */
|
||||
/* with leading zero suppression if zerosup = true */
|
||||
declare v address, /* value to print */
|
||||
prec address, /* precision */
|
||||
zerosup boolean; /* zero suppression flag */
|
||||
end pdecimal;
|
||||
|
||||
p3byte: procedure(byte3adr,prec)external;
|
||||
/* print 3 byte value with 0 suppression */
|
||||
dcl (byte3adr,prec) address; /* assume high order bit is < 10 */
|
||||
end p3byte;
|
||||
|
||||
terminate: procedure external;
|
||||
end terminate;
|
||||
|
||||
match: procedure boolean external;
|
||||
dcl fcb$adr address;
|
||||
end match;
|
||||
|
||||
add3byte: procedure (byte3$adr,word$amt) external;
|
||||
dcl (byte3$adr, word$amt) address;
|
||||
end add3byte; /* add word to 3 byte structure */
|
||||
|
||||
add3byte3: procedure (byte3$adr,byte3) external;
|
||||
dcl (byte3$adr, byte3) address;
|
||||
end add3byte3; /* add 3 byte quantity to 3 byte total */
|
||||
|
||||
shr3byte: procedure (byte3$adr) external;
|
||||
dcl byte3$adr address;
|
||||
end shr3byte;
|
||||
|
||||
set$drive: procedure external;
|
||||
end set$drive;
|
||||
|
||||
/* routines local to this module */
|
||||
|
||||
dcl total$kbytes structure ( /* grand total k bytes of files matched */
|
||||
lword address,
|
||||
hbyte byte),
|
||||
total$recs structure ( /* grand total records of files matched */
|
||||
lword address,
|
||||
hbyte byte),
|
||||
total$1k$blocks structure( /* how many 1k blocks are allocated */
|
||||
lword address,
|
||||
hbyte byte);
|
||||
|
||||
add$totals: procedure;
|
||||
dcl temp structure (lword address, hbyte byte);
|
||||
|
||||
call add3byte(.total$kbytes,file$info.kbytes);
|
||||
if file$info.bytes > 0 then /* round up to nearest k */
|
||||
call add3byte(.total$kbytes,1); /* actual disk space allocated */
|
||||
|
||||
call add3byte3(.total$recs,.file$info.recs$lword); /* records in file */
|
||||
temp.lword = file$info.recs$lword;
|
||||
temp.hbyte = file$info.recs$hbyte;
|
||||
call shr3byte(.temp); /* disk space if 1k blksiz */
|
||||
call add3byte3(.total$1k$blocks,.temp);
|
||||
if (file$info.recs$lword and 07h) <> 0 then
|
||||
call add3byte(.total$1k$blocks,1); /* round up */
|
||||
|
||||
end add$totals;
|
||||
|
||||
mult23: procedure(index) address external;
|
||||
dcl index address;
|
||||
end mult23;
|
||||
|
||||
/* fcb and dma buffer constants */
|
||||
declare
|
||||
f$drvusr lit '0', /* drive and user field */
|
||||
f$name lit '1', /* file name */
|
||||
f$rw lit '9', /* high bit is R/W attribute */
|
||||
f$dirsys lit '10', /* high bit is dir/sys attribute */
|
||||
f$arc lit '11', /* high bit is archive attribute */
|
||||
f$ex lit '12';
|
||||
|
||||
declare /* XFCB */
|
||||
xfcb$type lit '10', /* identifier on disk */
|
||||
xf$passmode lit '12', /* pass word protection mode */
|
||||
xf$pass lit '16', /* XFCB password */
|
||||
passlen lit '8', /* password length */
|
||||
xf$create lit '25', /* creation/access time stamp */
|
||||
xf$update lit '29'; /* update time stamp */
|
||||
|
||||
declare /* password mode of xfcb */
|
||||
pm$read lit '80h',
|
||||
pm$write lit '40h',
|
||||
pm$delete lit '20h';
|
||||
|
||||
dcl files$per$line byte;
|
||||
dcl cur$line address;
|
||||
|
||||
dcl hdr (*) byte data (' Name Bytes Recs Attributes $');
|
||||
dcl hdr$bars (*) byte data ('------------ ------ ------ ------------$');
|
||||
dcl hdr$pu (*) byte data (' Prot Update $');
|
||||
dcl hdr$xfcb$bars (*) byte data (' ------ -------------- --------------$');
|
||||
dcl hdr$access (*) byte data (' Access $');
|
||||
dcl hdr$create (*) byte data (' Create $');
|
||||
/* example date 04/02/55 00:34 */
|
||||
|
||||
display$file$info: procedure;
|
||||
/* print filename.typ */
|
||||
call printfn(.file$info.name(0));
|
||||
call printb;
|
||||
call pdecimal(file$info.kbytes,10000,true);
|
||||
cal<61> printchar('k')<29> /<2F> u<> t<> 3<> Me<4D> - Byte<74> */
|
||||
/* or 32,000k */
|
||||
call printb;
|
||||
call p3byte(.file$info.recs$lword,1); /* records */
|
||||
call printb;
|
||||
if rol(file$info.name(f$dirsys-1),1) then /* Type */
|
||||
call print(.('Sys$'));
|
||||
else call print(.('Dir$'));
|
||||
call printb;
|
||||
if rol(file$info.name(f$rw-1),1) then
|
||||
call print(.('RO$'));
|
||||
else call print(.('RW$'));
|
||||
call printb;
|
||||
if rol(file$info.name(f$arc-1),1) then /* arc bit was on in all */
|
||||
call print$char('A'); /* dir entries */
|
||||
else call printb;
|
||||
if rol(file$info.name(0),1) then
|
||||
call print$char('1');
|
||||
else call printb;
|
||||
if rol(file$info.name(1),1) then
|
||||
call print$char('2');
|
||||
else call printb;
|
||||
if rol(file$info.name(2),1) then
|
||||
call print$char('3');
|
||||
else call printb;
|
||||
if rol(file$info.name(3),1) then
|
||||
call print$char('4');
|
||||
else call printb;
|
||||
end display$file$info;
|
||||
|
||||
display$xfcb$info: procedure;
|
||||
if file$info.x$i$adr <> 0 then
|
||||
do;
|
||||
call printb;
|
||||
x$i$adr = file$info.x$i$adr;
|
||||
if (xfcb$info.passmode and pm$read) <> 0 then
|
||||
call print(.('Read $'));
|
||||
else if (xfcb$info.passmode and pm$write) <> 0 then
|
||||
call print(.('Write $'));
|
||||
else if (xfcb$info.passmode and pm$delete) <> 0 then
|
||||
call print(.('Delete$'));
|
||||
else
|
||||
call print(.('None $'));
|
||||
call printb;
|
||||
if (xfcb$info.update(0) <> 0 or xfcb$info.update(1) <> 0) then
|
||||
call display$timestamp(.xfcb$info.update);
|
||||
else call print(.(' $'));
|
||||
call printb; call printb;
|
||||
if (xfcb$info.create(0) <> 0 or xfcb$info.create(1) <> 0) then
|
||||
call display$timestamp(.xfcb$info.create(0));
|
||||
/* Create/Access */
|
||||
end;
|
||||
end display$xfcb$info;
|
||||
|
||||
dcl first$title boolean initial (true);
|
||||
|
||||
display$title: procedure;
|
||||
|
||||
if formfeeds then
|
||||
call print$char(ff);
|
||||
else if not first$title then
|
||||
call crlf;
|
||||
call print(.('Directory For Drive $'));
|
||||
call printchar('A'+ cur$drv); call printchar(':');
|
||||
if bdos >= bdos20 then
|
||||
do;
|
||||
call print(.(' User $'));
|
||||
call pdecimal(cur$usr,10,true);
|
||||
end;
|
||||
call crlf;
|
||||
cur$line = 2;
|
||||
first$title = false;
|
||||
end display$title;
|
||||
|
||||
short$display: procedure (fname$adr);
|
||||
dcl fname$adr address;
|
||||
if cur$file mod files$per$line = 0 then
|
||||
do;
|
||||
if cur$line mod page$len = 0 then
|
||||
do; call crlf;
|
||||
call display$title;
|
||||
call crlf;
|
||||
end;
|
||||
else
|
||||
call crlf;
|
||||
cur$line = cur$line + 1;
|
||||
call printchar(cur$drv + 'A');
|
||||
end;
|
||||
else call printb;
|
||||
call print(.(': $'));
|
||||
call printfn(fname$adr);
|
||||
call break;
|
||||
cur$file = cur$file + 1;
|
||||
end short$display;
|
||||
|
||||
test$att: procedure(char,off,on) boolean;
|
||||
dcl (char,off,on) byte;
|
||||
if (80h and char) <> 80h and (off and search$ops) <> 0 then
|
||||
return(true);
|
||||
if (80h and char) = 80h and (on and search$ops) <> 0 then
|
||||
return(true);
|
||||
return(false);
|
||||
end test$att;
|
||||
|
||||
right$attributes: procedure(name$adr) boolean;
|
||||
dcl name$adr address,
|
||||
name based name$adr (1) byte;
|
||||
return
|
||||
test$att(name(f$rw-1),s$rw,s$ro) and
|
||||
test$att(name(f$dirsys-1),s$dir,s$sys);
|
||||
end right$attributes;
|
||||
|
||||
short$dir: procedure;
|
||||
dcl dcnt byte;
|
||||
fcb(f$drvusr) = '?';
|
||||
files$per$line = 4;
|
||||
dcnt = search$first(.fcb);
|
||||
call set$drive;
|
||||
do while dcnt <> 0ffh;
|
||||
buf$fcb$adr = shl(dcnt and 11b,5)+.buff; /* dcnt mod 4 * 32 */
|
||||
if (buf$fcb(f$drvusr) and 0f0h) = 0 and buf$fcb(f$ex)<= dpb.extmsk
|
||||
then /* no dir labels, xfcbs */
|
||||
if match then
|
||||
if right$attributes(.buf$fcb(f$name)) then
|
||||
call short$display(.buf$fcb(f$name));
|
||||
dcnt = search$next;
|
||||
end;
|
||||
end short$dir;
|
||||
|
||||
dcl index address;
|
||||
|
||||
getnxt$file$info: procedure;
|
||||
dcl right$usr boolean;
|
||||
right$usr = false;
|
||||
if sorted then
|
||||
do while not right$usr;
|
||||
if index < filesfound then
|
||||
do; f$i$adr = mult23(f$i$indices(index));
|
||||
index = index + 1;
|
||||
right$usr = file$info.usr = cur$usr;
|
||||
end;
|
||||
else
|
||||
do; f$i$adr = end$adr; /* no more file$info recs */
|
||||
right$usr = true;
|
||||
end;
|
||||
end;
|
||||
else
|
||||
do while not right$usr and f$i$adr <> end$adr;
|
||||
f$i$adr = f$i$adr - size(file$info);
|
||||
right$usr = file$info.usr = cur$usr;
|
||||
end;
|
||||
end getnxt$file$info;
|
||||
|
||||
size$display: procedure;
|
||||
if (format and form$size) <> 0 then
|
||||
files$per$line = 3;
|
||||
else files$per$line = 4;
|
||||
do while f$i$adr <> end$adr;
|
||||
if ((file$info.x$i$adr <> 0 and (search$ops and s$xfcb) <> 0) or
|
||||
(file$info.x$i$adr = 0 and (search$ops and s$nonxfcb) <> 0)) and
|
||||
right$attributes(.file$info.name(0)) then
|
||||
do;
|
||||
cal<61> add$totals;
|
||||
call short$display(.file$info.name(0));
|
||||
call pdecimal(file$info.kbytes,10000,true);
|
||||
call print(.('k$'));
|
||||
end;
|
||||
call getnxt$file$info;
|
||||
end;
|
||||
end size$display;
|
||||
|
||||
display$no$dirlabel: procedure;
|
||||
files$per$line = 2;
|
||||
do while f$i$adr <> end$adr;
|
||||
if right$attributes(.file$info.name(0)) then
|
||||
do;
|
||||
if cur$file mod files$per$line = 0 then /* need new line */
|
||||
do;
|
||||
if cur$line mod page$len = 0 then
|
||||
do; call crlf;
|
||||
call display$title;
|
||||
call crlf;
|
||||
call print(.hdr);
|
||||
if (not sorted and f$i$adr <> end$adr + size(file$info)) or
|
||||
(sorted and index < filesfound) then
|
||||
do; call printb; /* then two sets of hdrs */
|
||||
call print(.hdr); /* more than 1 file left */
|
||||
end;
|
||||
call crlf;
|
||||
call print(.hdr$bars);
|
||||
if (not sorted and f$i$adr <> end$adr + size(file$info)) or
|
||||
(sorted and index < filesfound) then
|
||||
do; call printb;
|
||||
call print(.hdr$bars);
|
||||
end;
|
||||
call crlf;
|
||||
cur$line = cur$line + 3;
|
||||
end;
|
||||
else
|
||||
do; call crlf;
|
||||
cur$line = cur$line + 1;
|
||||
end;
|
||||
end;
|
||||
else
|
||||
call printb; /* separate the files */
|
||||
|
||||
call display$file$info;
|
||||
cur$file = cur$file + 1;
|
||||
call add$totals;
|
||||
call break;
|
||||
end;
|
||||
call getnxt$file$info;
|
||||
end;
|
||||
end display$no$dirlabel;
|
||||
|
||||
display$with$dirlabel: procedure;
|
||||
files$per$line = 1;
|
||||
do while f$i$adr <> end$adr;
|
||||
if ((file$info.x$i$adr <> 0 and (search$ops and s$xfcb) <> 0) or
|
||||
(file$info.x$i$adr = 0 and (search$ops and s$nonxfcb) <> 0)) and
|
||||
right$attributes(.file$info.name(0)) then
|
||||
do;
|
||||
cur$file = cur$file + 1;
|
||||
if cur$line mod page$len = 0 then
|
||||
do; call crlf;
|
||||
call display$title;
|
||||
call crlf;
|
||||
call print(.hdr);
|
||||
call print(.hdr$pu);
|
||||
if (dirlabel and dl$access) <> 0 then
|
||||
call print(.hdr$access);
|
||||
else
|
||||
call print(.hdr$create);
|
||||
call crlf;
|
||||
call print(.hdr$bars);
|
||||
call print(.hdr$xfcb$bars);
|
||||
cur$line = cur$line + 2;
|
||||
end;
|
||||
call crlf;
|
||||
call display$file$info; /* display non bdos 3.0 file info */
|
||||
call display$xfcb$info;
|
||||
call break;
|
||||
cur$line = cur$line + 1;
|
||||
call add$totals;
|
||||
end;
|
||||
call getnxt$file$info;
|
||||
end;
|
||||
end display$with$dirlabel;
|
||||
|
||||
show$files: procedure public; /* MODULE ENTRY POINT */
|
||||
/* display the collected data */
|
||||
cur$line, cur$file = 0; /* force titles and new line */
|
||||
totalkbytes.lword, totalkbytes.hbyte, totalrecs.lword, totalrecs.hbyte =0;
|
||||
total$1k$blocks.lword, total$1k$blocks.hbyte = 0;
|
||||
f$i$adr = last$f$i$adr + size(file$info); /* initial if no sort */
|
||||
index = 0; /* initial if sorted */
|
||||
call getnxt$file$info; /* base file info record */
|
||||
|
||||
if format > 2 then
|
||||
do;
|
||||
call print(.('Illegal Format Value$'));
|
||||
call terminate;
|
||||
end;
|
||||
do case format; /* format = */
|
||||
call short$dir; /* form$short */
|
||||
call size$display; /* form$size */
|
||||
/* form = full */
|
||||
if (dir$label and dl$exists) = 0 or ((search$ops and s$xfcb) = 0 and
|
||||
(search$ops and s$nonxfcb) <> 0) then
|
||||
call display$no$dirlabel;
|
||||
else
|
||||
call display$with$dirlabel;
|
||||
end;
|
||||
|
||||
if cur$file > 1 and format <> form$short then /* print totals */
|
||||
do;
|
||||
if (page$len <> 0) and (cur$line + 4 > page$len) and formfeeds then
|
||||
do;
|
||||
call printchar(cr);
|
||||
call printchar(ff); /* need a new page ? */
|
||||
end;
|
||||
else
|
||||
do;
|
||||
call crlf;
|
||||
call crlf;
|
||||
end;
|
||||
call print(.( 'Total Bytes = $'));
|
||||
call p3byte(.total$kbytes,1); /* 6 digit max */
|
||||
call printchar('k');
|
||||
call print(.(' Total Records = $'));
|
||||
call p3byte(.total$recs,10); /* 7 digit max */
|
||||
call print(.(' Files Found = $'));
|
||||
call pdecimal(cur$file,1000,true); /* 4 digit max */
|
||||
call print(.(cr,lf,'Total 1k Blocks = $'));
|
||||
call p3byte(.total$1k$blocks,1); /* 6 digit max */
|
||||
call print(.(' Used/Max Dir Entries For Drive $'));
|
||||
call print$char('A' + cur$drv);
|
||||
call print$char(':'); call printb;
|
||||
call pdecimal(used$de,1000,true);
|
||||
call print$char('/');
|
||||
call pdecimal(dpb.dirmax + 1,1000,true);
|
||||
end;
|
||||
|
||||
if cur$file = 0 then
|
||||
do;
|
||||
if message then
|
||||
do; call crlf;
|
||||
call display$title;
|
||||
call print(.('File Not Found.',cr,lf,'$'));
|
||||
end;
|
||||
call break;
|
||||
end;
|
||||
else
|
||||
do; file$displayed = true;
|
||||
if not formfeeds then
|
||||
call print(.(cr,lf,'$'));
|
||||
end;
|
||||
|
||||
end show$files;
|
||||
|
||||
end dshow;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user