mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-24 17:04:19 +00:00
1634 lines
43 KiB
Plaintext
1634 lines
43 KiB
Plaintext
$ TITLE('MP/M II --- SET 2.0')
|
||
|
||
|
||
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * SET * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
set:
|
||
do;
|
||
$include (copyrt.lit)
|
||
|
||
/*
|
||
Revised:
|
||
14 Sept 81 by Doug Huskey
|
||
*/
|
||
|
||
declare
|
||
mpmproduct literally '01h', /* requires mp/m */
|
||
cpmversion literally '30h'; /* requires 3.0 cp/m */
|
||
|
||
|
||
declare
|
||
true literally '1',
|
||
false literally '0',
|
||
dcl literally 'declare',
|
||
lit literally 'literally',
|
||
proc literally 'procedure',
|
||
addr literally 'address',
|
||
forever literally 'while true',
|
||
tab literally '9',
|
||
cr literally '13',
|
||
lf literally '10',
|
||
ctrlc literally '3h',
|
||
ctrlx literally '18h',
|
||
ctrlh literally '8h';
|
||
|
||
|
||
declare start label;
|
||
declare jump byte data(0c3h),
|
||
jadr address data (.start-3);
|
||
/* jump to status */
|
||
|
||
declare copyright (*) byte data (
|
||
' Copyright (c) 1981, Digital Research ');
|
||
|
||
declare versiondate (*) byte data ('08/09/81');
|
||
declare version (*) byte data ('SET 2.0',0);
|
||
|
||
|
||
/*
|
||
Digital Research
|
||
Box 579
|
||
Pacific Grove, Ca
|
||
93950
|
||
*/
|
||
$ eject
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * MESSAGES * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
|
||
declare
|
||
not$found (*) byte data (' File not found',0),
|
||
no$space (*) byte data (' or no directory space',0),
|
||
invalid (*) byte data ('Invalid ',0),
|
||
set$prot (*) byte data ('[protect=on]',0),
|
||
dirlabel (*) byte data ('Directory Label ',0),
|
||
option$set (*) byte data (' attribute set ',0),
|
||
read$only (*) byte data ('read only',0),
|
||
ro (*) byte data (' (RO)',0),
|
||
read$write (*) byte data ('read write (RW)',0),
|
||
comma (*) byte data (', ',0),
|
||
set$to (*) byte data ('set to ',0),
|
||
error$msg (*) byte data ('ERROR: ',0),
|
||
readmode (*) byte data ('READ',0),
|
||
writemode (*) byte data ('WRITE',0),
|
||
deletemode (*) byte data ('DELETE',0),
|
||
nopasswd (*) byte data ('NONE',0),
|
||
time$stamp (*) byte data ('Time Stamps ON',0),
|
||
on (*) byte data (' on ',0),
|
||
off (*) byte data (' off ',0),
|
||
failed (*) byte data ('Unsuccessful Function',0),
|
||
label$name (*) byte data ('Label');
|
||
|
||
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * CP/M INTERFACE * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
|
||
|
||
declare
|
||
maxb address external, /* addr field of jmp BDOS */
|
||
fcb (33) byte external, /* default file control block */
|
||
buff(128) byte external, /* default buffer */
|
||
buffa literally '.buff', /* default buffer */
|
||
fcba literally '.fcb', /* default file control block */
|
||
sectorlen literally '128', /* sector length */
|
||
user$code byte; /* current user code */
|
||
|
||
$include (proces.lit)
|
||
|
||
/* reset drive mask */
|
||
declare reset$mask (16) address data (
|
||
0000000000000001b,
|
||
0000000000000010b,
|
||
0000000000000100b,
|
||
0000000000001000b,
|
||
0000000000010000b,
|
||
0000000000100000b,
|
||
0000000001000000b,
|
||
0000000010000000b,
|
||
0000000100000000b,
|
||
0000001000000000b,
|
||
0000010000000000b,
|
||
0000100000000000b,
|
||
0001000000000000b,
|
||
0010000000000000b,
|
||
0100000000000000b,
|
||
1000000000000000b );
|
||
|
||
|
||
boot: procedure external;
|
||
/* reboot */
|
||
end boot;
|
||
|
||
mon1: procedure(f,a) external;
|
||
declare f byte, a address;
|
||
end mon1;
|
||
|
||
mon2: procedure(f,a) byte external;
|
||
declare f byte, a address;
|
||
end mon2;
|
||
|
||
declare mon3 literally 'mon2a';
|
||
|
||
mon3: procedure(f,a) address external;
|
||
declare f byte, a address;
|
||
end mon3;
|
||
|
||
/********** SYSTEM FUNCTION CALLS *********************/
|
||
|
||
printchar: procedure(char);
|
||
declare char byte;
|
||
call mon1(2,char);
|
||
end printchar;
|
||
|
||
printb: procedure;
|
||
/* print blank character */
|
||
call printchar(' ');
|
||
end printb;
|
||
|
||
printx: procedure(a);
|
||
declare a address;
|
||
declare s based a byte;
|
||
do while s <> 0;
|
||
call printchar(s);
|
||
a = a + 1;
|
||
end;
|
||
end printx;
|
||
|
||
check$con$stat: procedure byte;
|
||
return mon2(11,0); /* console ready */
|
||
end check$con$stat;
|
||
|
||
crlf: procedure;
|
||
call printchar(cr);
|
||
call printchar(lf);
|
||
if check$con$stat then
|
||
do;
|
||
call mon1 (1,0); /* read character */
|
||
call printx(.('Aborted',0));
|
||
call mon1 (0,0); /* system reset */
|
||
end;
|
||
end crlf;
|
||
|
||
print: procedure(a);
|
||
declare a address;
|
||
/* print the string starting at address a until the
|
||
next 0 is encountered */
|
||
call crlf;
|
||
call printx(a);
|
||
end print;
|
||
|
||
get$version: procedure addr;
|
||
/* returns current cp/m version # */
|
||
return mon3(12,0);
|
||
end get$version;
|
||
|
||
|
||
conin: procedure byte;
|
||
return mon2(6,0fdh);
|
||
end conin;
|
||
|
||
select: procedure(d);
|
||
declare d byte;
|
||
call mon1(14,d);
|
||
end select;
|
||
|
||
open: procedure(fcb) byte;
|
||
declare fcb address;
|
||
return mon2(15,fcb);
|
||
end open;
|
||
|
||
search$first: procedure(fcb) byte;
|
||
declare fcb address;
|
||
return mon2(17,fcb);
|
||
end search$first;
|
||
|
||
search$next: procedure byte;
|
||
return mon2(18,0);
|
||
end search$next;
|
||
|
||
cselect: procedure byte;
|
||
/* return current disk number */
|
||
return mon2(25,0);
|
||
end cselect;
|
||
|
||
setdma: procedure(dma);
|
||
declare dma address;
|
||
call mon1(26,dma);
|
||
end setdma;
|
||
|
||
writeprot: procedure byte;
|
||
/* write protect the current disk */
|
||
return mon2(28,0);
|
||
end writeprot;
|
||
|
||
getuser: procedure byte;
|
||
/* return current user number */
|
||
return mon2(32,0ffh);
|
||
end getuser;
|
||
|
||
setuser: procedure(user);
|
||
declare user byte;
|
||
call mon1(32,user);
|
||
end setuser;
|
||
|
||
getfilesize: procedure(fcb);
|
||
declare fcb address;
|
||
call mon1(35,fcb);
|
||
end getfilesize;
|
||
|
||
/* 0ff => return BDOS errors */
|
||
return$errors:
|
||
procedure(mode);
|
||
declare mode byte;
|
||
call mon1 (45,mode);
|
||
end return$errors;
|
||
|
||
setind: procedure(fcb) address;
|
||
dcl fcb addr;
|
||
call setdma(.passwd);
|
||
/* set file indicators for current fcb */
|
||
return mon3(30,fcb);
|
||
end setind;
|
||
|
||
/********** DISK PARAMETER BLOCK **********************/
|
||
|
||
declare
|
||
dpba address,
|
||
dpb based dpba structure
|
||
(spt address, bls byte, bms byte, exm byte, mxa address,
|
||
dmx address, dbl address, cks address, ofs address),
|
||
scptrk literally 'dpb.spt',
|
||
blkshf literally 'dpb.bls',
|
||
blkmsk literally 'dpb.bms',
|
||
extmsk literally 'dpb.exm',
|
||
maxall literally 'dpb.mxa',
|
||
dirmax literally 'dpb.dmx',
|
||
dirblk literally 'dpb.dbl',
|
||
chksiz literally 'dpb.cks',
|
||
offset literally 'dpb.ofs';
|
||
|
||
set$dpb: procedure;
|
||
/* set disk parameter block values */
|
||
dpba = mon3(31,0); /* base of dpb */
|
||
end set$dpb;
|
||
|
||
/******************************************************/
|
||
|
||
wrlbl: procedure(fcb) address;
|
||
declare fcb address;
|
||
call setdma(.passwd); /* set dma=password */
|
||
return mon3(100,fcb);
|
||
end wrlbl;
|
||
|
||
getlbl: procedure(d) byte;
|
||
declare d byte;
|
||
|
||
return mon2(101,d);
|
||
end getlbl;
|
||
|
||
readxfcb: procedure(fcb);
|
||
declare fcb address;
|
||
call setdma(.passwd); /* set dma=password */
|
||
call mon1(102,fcb);
|
||
end readxfcb;
|
||
|
||
wrxfcb: procedure(fcb) address;
|
||
declare fcb address;
|
||
|
||
call setdma(.passwd);
|
||
return mon3(103,fcb);
|
||
end wrxfcb;
|
||
|
||
declare
|
||
pdadr addr,
|
||
pd based pdadr process$descriptor;
|
||
|
||
getpd: procedure;
|
||
|
||
pdadr = mon3(156,0);
|
||
end getpd;
|
||
|
||
|
||
reset$drv: procedure(drv) byte;
|
||
dcl drv byte;
|
||
|
||
return mon2(37,reset$mask(drv));
|
||
end reset$drv;
|
||
|
||
terminate: procedure;
|
||
call crlf;
|
||
call mon1 (0,0);
|
||
end terminate;
|
||
$ eject
|
||
|
||
|
||
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * GLOBAL DATA * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
declare
|
||
fnam literally '11',
|
||
fmod literally '14',
|
||
frc literally '15',
|
||
fln literally '15',
|
||
fdm literally '16',
|
||
fdl literally '31',
|
||
ftyp literally '9',
|
||
rofile literally '9', /* read/only file */
|
||
infile literally '10', /* invisible file */
|
||
archiv literally '11', /* archived file */
|
||
attrb1 literally '1', /* attribute F1' */
|
||
attrb2 literally '2', /* attribute F2' */
|
||
attrb3 literally '3', /* attribute F3' */
|
||
attrb4 literally '4'; /* attribute F4' */
|
||
|
||
|
||
declare
|
||
fcbp address,
|
||
fcbv based fcbp (32) byte,
|
||
fext literally 'fcbv(12)';
|
||
|
||
declare
|
||
xfcb (32) byte,
|
||
xfcbmode byte at (.xfcb(12)); /* password mode */
|
||
|
||
declare /* command buffer */
|
||
cmd (27) byte initial(0,'HELP ',0),
|
||
passwd (17) byte; /* password buffer */
|
||
|
||
declare
|
||
scase byte initial(-1), /* file attributes */
|
||
fileref byte initial(false), /* file reference */
|
||
lblcmd byte initial(false), /* label attribute */
|
||
xfcbcmd byte initial(false), /* xfcb attribute */
|
||
wild byte initial(false), /* file = a wildcard */
|
||
optdel byte initial(false), /* delimiter = option */
|
||
option$found byte initial(false),/* options exist */
|
||
time$opt byte initial(false),/* option = [time] */
|
||
password byte initial(false), /* file has password */
|
||
option byte initial(false); /* cmd = a option */
|
||
|
||
declare /* parsing */
|
||
more byte initial(true), /* more to parse */
|
||
opt$adr addr, /* start of options */
|
||
ibp addr; /* input buffer ptr */
|
||
|
||
declare
|
||
(sav$dcnt, sav$searcha) addr,
|
||
sav$searchl byte,
|
||
dirbuf (128) byte; /* used for searches */
|
||
|
||
declare
|
||
cdisk byte, /* current disk */
|
||
ver addr; /* version checking */
|
||
|
||
declare
|
||
error$code addr; /* for bdos returned
|
||
errors */
|
||
declare
|
||
parse$fn structure (
|
||
buff$adr addr,
|
||
fcb$adr addr),
|
||
last$buff$adr addr; /* used for parsing */
|
||
|
||
declare /* file attribute bytes and values by scase */
|
||
attr$byte (14) byte
|
||
/* RW RO DIR SYS A F F F F A F F F F */
|
||
initial(9, 9, 10, 10,11,1,2,3,4,11,1,2,3,4),
|
||
attr$value (14) byte
|
||
/* RW RO DIR SYS A F F F F A F F F F */
|
||
initial(0, 1, 0, 1, 1,1,1,1,1, 0,0,0,0,0);
|
||
|
||
declare /* strings for match routine */
|
||
attributes (*) byte data
|
||
('RWRODISYARF1F2F3F4Attribute',0),
|
||
values (*) byte data
|
||
('OFONREWRDENOMode',0),
|
||
boolean (*) byte data
|
||
('OFONValue, Use ON or OFF',0);
|
||
|
||
/* VALUES FILE ATTRIBUTES
|
||
mode keyword scase attribute
|
||
0 OFF 0 RW
|
||
1 ON 1 RO
|
||
2 READ 2 DIR
|
||
3 WRITE 3 SYS
|
||
4 DELETE 4 ARCHIVE
|
||
5 NONE 5 F1
|
||
BOOLEAN 6 F2
|
||
0 OFF 7 F3
|
||
1 ON 8 F4 */
|
||
$ eject
|
||
|
||
|
||
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * BASIC ROUTINES * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
|
||
/* help message */
|
||
help: procedure;
|
||
call print(.(tab,tab,tab,'SET EXAMPLES',0));
|
||
call print(.(cr,lf,'FOR FILES',cr,lf,cr,lf,
|
||
'set *.asm [rw, dir] ',tab,tab,tab,'(File Attributes)',0));
|
||
call print(.(
|
||
'set *.prl [ro, sys]',0));
|
||
call print(.(
|
||
'set *.dat [archive=on,f1=off,f2=on,f3=on]',0));
|
||
call print(.(
|
||
'set *.asm [time] ',tab,tab,tab,'(Time Stamping on ASM files)',0));
|
||
call print(.(
|
||
'set *.asm [password = xyz]',
|
||
tab,tab,'(Password Protection)',0));
|
||
call print(.('set *.asm [protect = read]',
|
||
tab,tab,'(read, write, delete or none)',0));
|
||
call print(.(cr,lf,'FOR DRIVES',cr,lf,cr,lf,
|
||
'set [password = xyz]',tab,tab,tab,'(Label Password)',0));
|
||
call print(.('set [protect = on] ',tab,tab,tab,'(Password Protection)',0));
|
||
call print(.('set [update = on] ',tab,tab,tab,'(Update Time Stamps - on or off)',0));
|
||
call print(.('set [create = on] ',tab,tab,tab,'(Creation Time Stamps - on or off)',0));
|
||
call print(.('set [access = on] ',tab,tab,tab,'(Access Time Stamps - on or off)',0));
|
||
call print(.('set [make = on] ',tab,tab,tab,'(Make XFCBs - on or off)',0));
|
||
call print(.(
|
||
'set [default = xyz]',tab,tab,tab,'(Default Password)',0));
|
||
call print(.('set a:[rw], b:[ro]',tab,tab,tab,'(Drive Status)',0));
|
||
end help;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* invalid command error */
|
||
perror: proc(msg);
|
||
dcl msg addr;
|
||
|
||
call print(.error$msg);
|
||
if ibp = 0 then
|
||
call printx(parse$fn.buff$adr);
|
||
else
|
||
call printx(last$buff$adr);
|
||
call printx(.(' ?',0));
|
||
call print(.invalid);
|
||
call printx(msg);
|
||
call terminate;
|
||
end perror;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* parsing error */
|
||
parse$error: proc;
|
||
|
||
if option then
|
||
call perror(.('Parameter',0));
|
||
else
|
||
call perror(.('File',0));
|
||
end parse$error;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* parse the next lexical item in the command line
|
||
parse$fn must filled in with input parameters */
|
||
parse: procedure address;
|
||
declare p address;
|
||
declare c based p byte;
|
||
|
||
p = mon3(152,.parse$fn);
|
||
if p = 0FFFFh then
|
||
call parse$error;
|
||
else if p <> 0 then do;
|
||
if c = '[' then
|
||
optdel = true;
|
||
else if c = ']' then
|
||
optdel = false;
|
||
p = p + 1;
|
||
if c = ',' then
|
||
p = p + 1;
|
||
last$buff$adr = parse$fn.buff$adr - 1;
|
||
parse$fn.buff$adr = p;
|
||
end;
|
||
else
|
||
optdel = false;
|
||
return p;
|
||
end parse;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* parse a option value */
|
||
parse$value: proc;
|
||
|
||
/* test for end */
|
||
if ibp = 0 then
|
||
call parse$error;
|
||
|
||
/* more to go */
|
||
ibp = parse;
|
||
end parse$value;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* fill string @ s for c bytes with f */
|
||
fill: proc(s,f,c);
|
||
dcl s addr,
|
||
(f,c) byte,
|
||
a based s byte;
|
||
|
||
do while (c:=c-1)<>255;
|
||
a = f;
|
||
s = s+1;
|
||
end;
|
||
end fill;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* copy c bytes from s to d */
|
||
copy: proc(s,d,c);
|
||
dcl (s,d) addr, c byte;
|
||
dcl a based s byte, b based d byte;
|
||
|
||
do while (c:=c-1)<>255;
|
||
b=a; s=s+1; d=d+1;
|
||
end;
|
||
end copy;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* upper case character from console */
|
||
ucase: proc byte;
|
||
dcl c byte;
|
||
|
||
if (c:=conin) >= 'a' then
|
||
if c < '{' then
|
||
return(c-20h);
|
||
return c;
|
||
end ucase;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* get password and place in passwd */
|
||
getpasswd: proc;
|
||
dcl (i,c) byte;
|
||
|
||
call print(.('Password ? ',0));
|
||
retry:
|
||
call fill(.passwd,' ',8);
|
||
do i = 0 to 7;
|
||
nxtchr:
|
||
if (c:=ucase) >= ' ' then
|
||
passwd(i)=c;
|
||
if c = cr then
|
||
go to exit;
|
||
if c = ctrlx then
|
||
goto retry;
|
||
if c = ctrlh then do;
|
||
if i<1 then
|
||
goto retry;
|
||
else do;
|
||
passwd(i:=i-1)=' ';
|
||
goto nxtchr;
|
||
end;
|
||
end;
|
||
if c = ctrlc then
|
||
call terminate; /* end of program */
|
||
end;
|
||
exit:
|
||
c = check$con$stat; /* clear raw I/O mode */
|
||
end getpasswd;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* print drive name */
|
||
printdrv: procedure;
|
||
|
||
call printchar(cdisk+'A');
|
||
call printchar(':');
|
||
end printdrv;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* print file name */
|
||
printfn: procedure;
|
||
declare k byte;
|
||
|
||
call printdrv;
|
||
|
||
do k = 1 to fnam;
|
||
if k = ftyp then
|
||
call printchar('.');
|
||
call printchar(fcbv(k) and 7fh);
|
||
end;
|
||
end printfn;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* error message routine */
|
||
bdos$error: procedure;
|
||
declare
|
||
code byte;
|
||
|
||
if (code:=high(error$code)) < 3 then do;
|
||
call print(.error$msg);
|
||
call printdrv;
|
||
call printb;
|
||
if code = 1 then
|
||
call printx(.('BDOS Bad Sector',0));
|
||
if code=2 then do;
|
||
call printx(.('Drive ',0));
|
||
call printx(.read$only);
|
||
end;
|
||
call terminate;
|
||
end;
|
||
call printx(.error$msg);
|
||
if code = 3 then
|
||
call printx(.read$only);
|
||
if code = 5 then
|
||
call printx(.('Currently Opened',0));
|
||
if code = 7 then
|
||
call printx(.('Wrong Password',0));
|
||
end bdos$error;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* get address of FCB in dirbuf */
|
||
set$up$file: procedure(dir$index);
|
||
dcl dir$index byte;
|
||
|
||
if dir$index <> 0ffh then do;
|
||
sav$dcnt = pd.dcnt;
|
||
sav$searchl = pd.searchl;
|
||
sav$searcha = pd.searcha;
|
||
fcbp = shl(dir$index,5) + .dirbuf;
|
||
fcbv(0) = fcb(0); /* set drive byte */
|
||
end;
|
||
end set$up$file;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* match command from command string */
|
||
match: proc(commands$adr, last$cmd) byte;
|
||
dcl (i,j,matched,scase,last$cmd) byte;
|
||
dcl
|
||
commands$adr address,
|
||
commands based commands$adr (1) byte;
|
||
|
||
j = 0;
|
||
do scase = 0 to last$cmd;
|
||
matched = true;
|
||
do i = 1 to 2;
|
||
if commands(j) <> cmd(i) then
|
||
matched = false;
|
||
j = j + 1;
|
||
end;
|
||
if matched then
|
||
return scase;
|
||
end;
|
||
call perror(.commands(j));
|
||
end match;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* return boolean option value */
|
||
bool: procedure byte;
|
||
|
||
if match(.boolean,1) then
|
||
return true;
|
||
else
|
||
return false;
|
||
end bool;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* print boolean option value */
|
||
pbool: procedure(value);
|
||
declare
|
||
value byte;
|
||
|
||
call printx(.option$set);
|
||
if value then
|
||
call printx(.('ON',0));
|
||
else
|
||
call printx(.('OFF',0));
|
||
end pbool;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* print command */
|
||
printcmd: procedure;
|
||
|
||
call printx(.set$to);
|
||
cmd(12)=0;
|
||
call printx(.cmd(1));
|
||
end printcmd;
|
||
|
||
|
||
/*******************************************************
|
||
|
||
F I L E A T T R I B U T E S
|
||
|
||
********************************************************/
|
||
|
||
|
||
|
||
/* print attribute set */
|
||
printatt: procedure;
|
||
|
||
|
||
/* test if attribute fcbv(i) is on */
|
||
attribute: procedure(i) byte;
|
||
declare i byte;
|
||
|
||
if rol(fcbv(i),1) then
|
||
return true;
|
||
return false;
|
||
end attribute;
|
||
|
||
|
||
/* print character c if attribute(b) is true */
|
||
prnt$attrib: procedure(b,c);
|
||
declare (b,c) byte;
|
||
|
||
if attribute(b) then
|
||
call printchar(c);
|
||
end prnt$attrib;
|
||
|
||
/* display attributes: sys,ro,a,f1-f4 */
|
||
|
||
call printx(.set$to);
|
||
if attribute(infile) then
|
||
call printx(.('system (SYS)',0));
|
||
else
|
||
call printx(.('directory (DIR)',0));
|
||
call printx(.(', ',0));
|
||
if attribute(rofile) then do;
|
||
call printx(.read$only);
|
||
call printx(.ro);
|
||
end;
|
||
else
|
||
call printx(.read$write);
|
||
|
||
call printchar(tab);
|
||
call prnt$attrib(archiv,'A');
|
||
call prnt$attrib(attrb1,'1');
|
||
call prnt$attrib(attrb2,'2');
|
||
call prnt$attrib(attrb3,'3');
|
||
call prnt$attrib(attrb4,'4');
|
||
end print$att;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* read current file attributes */
|
||
rd$attributes: procedure;
|
||
|
||
if scase = -1 then
|
||
if not wild then do;
|
||
call setdma(.dirbuf);
|
||
call set$up$file(search$first(.fcb));
|
||
end;
|
||
end rd$attributes;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* set up file attributes */
|
||
set$attributes: procedure;
|
||
|
||
/*------------------------------------------------------------
|
||
|
||
scase ranges from 0 - 13 :
|
||
|
||
0 - RW 3 - SYS 6 - F2 (on) 9 - not Archived
|
||
1 - RO 4 - ARCHIVED 7 - F3 (on) 10 - F1 (off) 12 - F3 (off)
|
||
2 - DIR 5 - F1 (on) 8 - F4 (on) 11 - F2 (off) 13 - F4 (off)
|
||
|
||
-------------------------------------------------------------*/
|
||
|
||
call rd$attributes;
|
||
if (scase := match(.attributes,8)) > 3 then do;
|
||
call parse$value;
|
||
if not bool then
|
||
scase = scase + 5;
|
||
end;
|
||
if attr$value(scase) then
|
||
fcbv(attr$byte(scase)) = fcbv(attr$byte(scase)) or 80h;
|
||
else
|
||
fcbv(attr$byte(scase)) = fcbv(attr$byte(scase)) and 7fh;
|
||
|
||
end set$attributes;
|
||
|
||
|
||
|
||
/*******************************************************
|
||
|
||
D R I V E A T T R I B U T E S
|
||
|
||
********************************************************/
|
||
|
||
|
||
|
||
|
||
|
||
/* set drive attributes */
|
||
setdrvstatus: procedure;
|
||
dcl code byte;
|
||
|
||
/* set the drive */
|
||
if (scase:=match(.attributes,1)) then
|
||
code = writeprot; /* RO */
|
||
else
|
||
code = reset$drv(cdisk); /* RW */
|
||
|
||
/* display */
|
||
if code <> 0ffh then do;
|
||
call print(.('Drive ',0));
|
||
call printdrv;
|
||
call printb;
|
||
call printx(.set$to);
|
||
if scase then do;
|
||
call printx(.read$only);
|
||
call printx(.ro);
|
||
end;
|
||
else
|
||
call printx(.read$write);
|
||
end;
|
||
else
|
||
call print(.failed);
|
||
scase = -1;
|
||
end setdrvstatus;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* set default password */
|
||
defaultpass: procedure;
|
||
|
||
call fill(.cmd(1),' ',8);
|
||
ibp = parse; /* get password */
|
||
call mon1(106,.cmd(1)); /* set default password */
|
||
call print(.('Default Password ',0));
|
||
call printcmd;
|
||
end defaultpass;
|
||
|
||
|
||
/*******************************************************
|
||
|
||
L A B E L A T T R I B U T E S
|
||
|
||
********************************************************/
|
||
|
||
|
||
/* read the directory label before
|
||
writing the label to preserve the
|
||
name, type, and stamps */
|
||
readlabel: procedure;
|
||
dcl (mode, dcnt) byte;
|
||
|
||
|
||
readlbl: proc;
|
||
dcl d byte data('?');
|
||
|
||
call setdma(.dirbuf);
|
||
dcnt = search$first(.d);
|
||
do while dcnt <> 0ffh;
|
||
if dirbuf(ror(dcnt,3) and 110$0000b)=20H then
|
||
return;
|
||
dcnt = search$next;
|
||
end;
|
||
|
||
call print(.('lbl err',0));
|
||
call terminate;
|
||
end readlbl;
|
||
|
||
if lblcmd then
|
||
return;
|
||
mode = getlbl(cdisk);
|
||
password = false;
|
||
if mode > 0 then do;
|
||
call readlbl;
|
||
fcbp = shl(dcnt,5) + .dirbuf;
|
||
fext = fext and 11110000b; /* turn off set passwd */
|
||
if fcbv(16) <> ' ' then
|
||
if fcbv(16) <> 0 then
|
||
password = true;
|
||
end;
|
||
else do;
|
||
fcbp = .fcb;
|
||
call copy(.label$name,.fcb(1),length(label$name));
|
||
end;
|
||
if password then
|
||
call getpasswd;
|
||
lblcmd = true;
|
||
end readlabel;
|
||
|
||
|
||
/*******************************************************
|
||
|
||
X F C B A T T R I B U T E S
|
||
|
||
********************************************************/
|
||
|
||
|
||
/* read xfcb into xfcb buffer */
|
||
set$up$xfcb: procedure;
|
||
|
||
if not xfcbcmd then do;
|
||
call copy(.fcbv,.xfcb,12);
|
||
password,xfcbmode = 0;
|
||
call readxfcb(.xfcb); /* read xfcb */
|
||
if xfcbmode <> 0 then
|
||
password = true;
|
||
xfcbcmd = true;
|
||
end;
|
||
/* else
|
||
already done */
|
||
end set$up$xfcb;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* no directory label exists */
|
||
no$label: procedure(msg);
|
||
declare msg addr;
|
||
|
||
call crlf;
|
||
call print(.error$msg);
|
||
call printx(.(' First SET ',0));
|
||
call printdrv;
|
||
call printx(msg);
|
||
call terminate;
|
||
end no$label;
|
||
|
||
|
||
/*******************************************************
|
||
|
||
PASSWORD AND PASSWORD MODE ROUTINES
|
||
|
||
********************************************************/
|
||
|
||
|
||
/* set file or label password */
|
||
set$password: procedure;
|
||
dcl (p,q) address;
|
||
dcl c based p byte;
|
||
dcl d based q byte;
|
||
|
||
if fileref then do;
|
||
if getlbl(cdisk) = 0 then
|
||
call no$label(.set$prot);
|
||
call set$up$xfcb; /* read xfcb */
|
||
xfcbmode = xfcbmode or 1; /* set passwd */
|
||
end;
|
||
else do;
|
||
call readlabel;
|
||
fext = fext or 1;
|
||
end;
|
||
p = (q:=parse$fn.buff$adr) - 1;
|
||
if c = ',' or d = ']' then /* null password */
|
||
call fill(.passwd(8),' ',8);
|
||
else do;
|
||
ibp = parse; /* parse password */
|
||
call copy(.cmd(1),.passwd(8),8); /* copy it to fcb */
|
||
password = true;
|
||
end;
|
||
end set$password;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* set file or drive protection mode */
|
||
protect: procedure;
|
||
declare new$password byte;
|
||
|
||
zeropass: proc;
|
||
xfcbmode = 1;
|
||
call fill(.passwd(8),' ',8);
|
||
password = false;
|
||
end zeropass;
|
||
|
||
rmode: proc;
|
||
xfcbmode = 80h;
|
||
end rmode;
|
||
|
||
call parse$value; /* protection value */
|
||
if fileref then do;
|
||
if getlbl(cdisk) = 0 then
|
||
call no$label(.set$prot);
|
||
call set$up$xfcb;
|
||
if xfcbmode then /* lsb */
|
||
new$password = true; /* save */
|
||
else
|
||
new$password = false;
|
||
|
||
do case match(.values,5);
|
||
call zeropass; /* OFF */
|
||
call rmode; /* ON */
|
||
call rmode; /* READ */
|
||
xfcbmode = 40h; /* WRITE */
|
||
xfcbmode = 20h; /* DELETE */
|
||
call zeropass; /* NONE */
|
||
end;
|
||
|
||
if new$password then /* restore */
|
||
xfcbmode = xfcbmode or 1;
|
||
end;
|
||
else do;
|
||
call readlabel;
|
||
if bool then
|
||
fext = fext or 80h; /* turn on passwords */
|
||
else
|
||
fext = fext and 01111111b; /* turn off passwords */
|
||
end;
|
||
end protect;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* set file time stamping */
|
||
time: procedure;
|
||
|
||
call set$up$xfcb;
|
||
if (getlbl(cdisk) and 0110$0000b) = 0 then
|
||
call no$label(.('[access=on, update=on]',0));
|
||
time$opt = true;
|
||
end time;
|
||
|
||
|
||
/*******************************************************
|
||
|
||
LABEL ATTRIBUTE ROUTINES
|
||
|
||
********************************************************/
|
||
|
||
|
||
/* gets the label option boolean value */
|
||
getbool: procedure;
|
||
|
||
if fileref then
|
||
call parse$error;
|
||
call readlabel; /* get label name */
|
||
call parse$value; /* option value */
|
||
end getbool;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* sets the label name */
|
||
lname: procedure;
|
||
|
||
call getbool;
|
||
call copy(.cmd(1),.fcbv(1),11); /* copy label name */
|
||
end lname;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* set access time stamping */
|
||
access: procedure;
|
||
|
||
call getbool;
|
||
if not bool then
|
||
fext = fext and 10111111b; /* turn off access ts */
|
||
else do;
|
||
fext = fext or 40h; /* turn on access ts */
|
||
fext = fext or 10h; /* turn on make xfcb */
|
||
end;
|
||
end access;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* set update time stamping */
|
||
update: procedure;
|
||
|
||
call getbool;
|
||
if not bool then
|
||
fext = fext and 11011111b; /* turn off update ts */
|
||
else do;
|
||
fext = fext or 20h; /* turn on update ts */
|
||
fext = fext or 10h; /* turn on make xfcb */
|
||
end;
|
||
end update;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* set create time stamping */
|
||
create: procedure;
|
||
|
||
call getbool;
|
||
if not bool then
|
||
fext = fext or 40h; /* turn on access ts */
|
||
else do;
|
||
fext = fext and 10111111b; /* turn off access ts */
|
||
fext = fext or 10h; /* turn on make xfcb */
|
||
end;
|
||
end create;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* set make xfcbs option */
|
||
makestamp: procedure;
|
||
|
||
call getbool;
|
||
if not bool then
|
||
fext = fext and 11101111b; /* turn off make xfcb */
|
||
else
|
||
fext = fext or 10h; /* turn on make xfcb */
|
||
end makestamp;
|
||
|
||
|
||
|
||
/*******************************************************
|
||
|
||
S H O W L A B E L & X F C B
|
||
|
||
********************************************************/
|
||
|
||
|
||
|
||
|
||
|
||
/* display the new password */
|
||
show$passwd: procedure;
|
||
|
||
call printx(.('Password = ',0));
|
||
passwd(16) = 0;
|
||
call printx(.passwd(8));
|
||
end show$passwd;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* HEADER for showlbl procedure */
|
||
|
||
dcl label1 (*) byte data (
|
||
'Directory Passwds Make Stamp Stamp Stamp',cr,lf,
|
||
'Label Reqd XFCBs Create Access Update',cr,lf,
|
||
'-------------- ------- ------- ------- ------- -------',cr,lf,0);
|
||
|
||
/* show the label options */
|
||
showlbl: procedure;
|
||
declare (make,access) byte;
|
||
|
||
call print(.('Label for drive ',0));
|
||
call printdrv;
|
||
call crlf;
|
||
call print(.label1);
|
||
call printfn;
|
||
|
||
/* PASSWORDS REQUIRED */
|
||
if (fext and 80h) = 80h then
|
||
call printx(.on);
|
||
else
|
||
call printx(.off);
|
||
|
||
/* MAKE XFCBS */
|
||
if (make:=(fext and 10h) = 10h) then
|
||
call printx(.on);
|
||
else
|
||
call printx(.off);
|
||
|
||
/* STAMP CREATE */
|
||
access = (fext and 40h) = 40h;
|
||
if make and not access then
|
||
call printx(.on);
|
||
else
|
||
call printx(.off);
|
||
|
||
/* STAMP ACCESS */
|
||
if access then
|
||
call printx(.on);
|
||
else
|
||
call printx(.off);
|
||
|
||
/* STAMP UPDATE */
|
||
if (fext and 20h) = 20h then
|
||
call printx(.on);
|
||
else
|
||
call printx(.off);
|
||
|
||
call crlf;
|
||
if fext then do;
|
||
call crlf;
|
||
call show$passwd;
|
||
end;
|
||
end showlbl;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* display xfcb attributes */
|
||
show$xfcb: procedure;
|
||
|
||
if xfcbmode <> 0 then do;
|
||
if xfcbmode > 1 then
|
||
if not password then do;
|
||
call printx(.error$msg);
|
||
call printx(.(' Assign a password to this file.',0));
|
||
return; /* error condition */
|
||
end;
|
||
call printx(.('Protection = ',0));
|
||
if (xfcbmode and 80h) = 80h then
|
||
call printx(.readmode);
|
||
else if (xfcbmode and 40h) = 40h then
|
||
call printx(.writemode);
|
||
else if (xfcbmode and 20h) = 20h then
|
||
call printx(.deletemode);
|
||
else if (not xfcbmode) or (passwd(8) = ' ') then
|
||
call printx(.nopasswd);
|
||
else
|
||
call printx(.readmode);
|
||
if time$opt then
|
||
call printx(.comma);
|
||
end;
|
||
if time$opt then
|
||
call printx(.time$stamp);
|
||
if xfcbmode then do; /* lsb on */
|
||
call printx(.comma);
|
||
call show$passwd;
|
||
end;
|
||
end show$xfcb;
|
||
|
||
|
||
/*******************************************************
|
||
|
||
WRITE XFCB, LABEL AND FILE ATTRIBUTES
|
||
|
||
********************************************************/
|
||
|
||
|
||
|
||
|
||
|
||
/* display the file or xfcb */
|
||
put$file: procedure;
|
||
|
||
call crlf;
|
||
call printfn;
|
||
call printb;
|
||
call printb;
|
||
end put$file;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* write file attributes */
|
||
put$attributes: procedure;
|
||
|
||
error$code = setind(fcbp);
|
||
if low(error$code) = 0ffh then
|
||
if high(error$code) <> 0 then do;
|
||
call put$file;
|
||
call bdos$error;
|
||
if high(error$code) = 7 then do;
|
||
call crlf;
|
||
call getpasswd;
|
||
call crlf;
|
||
error$code = setind(fcbp);
|
||
if high(error$code) <> 0 then do;
|
||
call put$file;
|
||
call bdos$error;
|
||
end;
|
||
end;
|
||
end;
|
||
else
|
||
call printx(.not$found);
|
||
if low(error$code) <> 0ffh then
|
||
if fext <= extmsk then do;
|
||
call put$file;
|
||
call print$att;
|
||
end;
|
||
scase = -1;
|
||
end put$attributes;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* write new label */
|
||
write$label: procedure;
|
||
err: proc;
|
||
call print(.dirlabel);
|
||
call bdos$error;
|
||
end err;
|
||
|
||
error$code = wrlbl(fcbp);
|
||
if low(error$code) = 0ffh then
|
||
if high(error$code) <> 0 then do;
|
||
call err;
|
||
if high(error$code) = 7 then do;
|
||
call crlf;
|
||
call getpasswd;
|
||
error$code = wrlbl(fcbp);
|
||
if high(error$code) <> 0 then do;
|
||
call err;
|
||
call terminate;
|
||
end;
|
||
call crlf;
|
||
end;
|
||
end;
|
||
else do;
|
||
call print(.failed);
|
||
call terminate;
|
||
end;
|
||
|
||
/* successful */
|
||
call showlbl;
|
||
lblcmd = false;
|
||
end write$label;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* write out new xfcb */
|
||
write$xfcb: procedure;
|
||
|
||
call put$file;
|
||
error$code = wrxfcb(.xfcb);
|
||
if low(error$code) = 0ffh then
|
||
if high(error$code) <> 0 then do;
|
||
call bdos$error;
|
||
if high(error$code) = 7 then do;
|
||
call crlf;
|
||
call getpasswd;
|
||
call crlf;
|
||
call put$file;
|
||
error$code = wrxfcb(.xfcb);
|
||
if high(error$code) <> 0 then
|
||
call bdos$error;
|
||
end;
|
||
end;
|
||
else do;
|
||
call printx(.not$found);
|
||
call printx(.no$space);
|
||
end;
|
||
if low(error$code) <> 0ffh then
|
||
call show$xfcb;
|
||
xfcbcmd = false;
|
||
end write$xfcb;
|
||
|
||
|
||
|
||
|
||
/*******************************************************
|
||
|
||
C O M M A N D P R O C E S S I N G
|
||
|
||
********************************************************/
|
||
|
||
|
||
|
||
/* select the disk specified in cmd line */
|
||
setdisk: procedure;
|
||
if cmd(0) <> 0 then do;
|
||
cdisk = cmd(0)-1;
|
||
call select(cdisk);
|
||
call set$dpb;
|
||
end;
|
||
end setdisk;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* find the next file matching the wildcard */
|
||
getfile: procedure byte;
|
||
declare
|
||
dir$index byte;
|
||
|
||
call setdma(.dirbuf);
|
||
if wild then do;
|
||
pd.dcnt = sav$dcnt;
|
||
pd.searchl = sav$searchl;
|
||
pd.searcha = sav$searcha;
|
||
dir$index = search$next;
|
||
end;
|
||
else
|
||
dir$index = search$first(.fcb);
|
||
if dir$index <> 0ffh then do;
|
||
call set$up$file(dir$index);
|
||
return true;
|
||
end;
|
||
/* else */
|
||
return false;
|
||
end getfile;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* test if the file is a wildcard */
|
||
wildcard: procedure byte;
|
||
declare
|
||
i byte;
|
||
|
||
do i=1 to fnam;
|
||
if fcb(i) = '?' then
|
||
return true;
|
||
end;
|
||
return false;
|
||
end wildcard;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* set up the next file or drive reference */
|
||
setup$fcb: procedure;
|
||
|
||
call setdisk;
|
||
call copy(.cmd,.fcb,12); /* name */
|
||
call copy(.cmd(16),.passwd,8); /* password */
|
||
time$opt, option$found = false;
|
||
if fcb(1) <> ' ' or fcb(ftyp) <> ' ' then do;
|
||
fileref = true;
|
||
if wildcard then
|
||
if getfile then do;
|
||
wild = true;
|
||
opt$adr = parse$fn.buff$adr;
|
||
end;
|
||
else do;
|
||
call print(.not$found);
|
||
call terminate;
|
||
end;
|
||
else
|
||
fcbp = .fcb;
|
||
end;
|
||
else
|
||
fileref = false;
|
||
end setup$fcb;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* parse next option */
|
||
parse$option: procedure;
|
||
|
||
if cmd(1) = 'A' then do; /* A */
|
||
if cmd(2) = 'C' then
|
||
call access;
|
||
else if fileref then
|
||
call set$attributes;
|
||
else
|
||
call parse$error;
|
||
end;
|
||
else if cmd(1) = 'C' then /* C */
|
||
call create;
|
||
else if cmd(1) = 'D' then do; /* D */
|
||
if fileref then
|
||
call set$attributes;
|
||
else if cmd(2) = 'E' then
|
||
call defaultpass;
|
||
else
|
||
call parse$error;
|
||
end;
|
||
else if cmd(1) = 'F' then /* F */
|
||
call set$attributes;
|
||
else if cmd(1) = 'H' then /* H */
|
||
call help;
|
||
else if cmd(1) = 'M' then /* M */
|
||
call makestamp;
|
||
else if cmd(1) = 'N' then /* N */
|
||
call lname;
|
||
else if cmd(1) = 'P' then do; /* P */
|
||
if cmd(2) = 'R' then
|
||
call protect;
|
||
else if cmd(2) = 'A' then
|
||
call set$password;
|
||
else
|
||
call parse$error;
|
||
end;
|
||
else if cmd(1) = 'R' then do; /* R */
|
||
if fileref then
|
||
call set$attributes;
|
||
else
|
||
call setdrvstatus;
|
||
end;
|
||
else if cmd(1) = 'S' and fileref then /* S */
|
||
call set$attributes;
|
||
else if cmd(1) = 'T' and fileref then /* T */
|
||
call time;
|
||
else if cmd(1) = 'U' then /* U */
|
||
call update;
|
||
else if cmd(1) = 'V' then /* V */
|
||
call print(.version);
|
||
else if cmd(1) = 'X' and fileref then /* X */
|
||
call time;
|
||
else
|
||
call parse$error;
|
||
end parse$option;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* check for more to parse */
|
||
is$there$more: proc;
|
||
|
||
if ibp = 0 then do;
|
||
if not option$found then do;
|
||
call printx(.version);
|
||
call print(.error$msg);
|
||
call printx(.('Parameter Required, try SET [HELP]',0));
|
||
call terminate;
|
||
end;
|
||
if not wild then
|
||
more = false;
|
||
end;
|
||
end is$there$more;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* check for SET HELP */
|
||
/* REMOVED FOR CONSISTANCY WITH SDIR
|
||
help$check: proc;
|
||
declare i byte;
|
||
|
||
do i=1 to 11;
|
||
if fcb(i) <> cmd(i) then
|
||
return;
|
||
end;
|
||
call help;
|
||
call terminate;
|
||
end help$check;
|
||
*/
|
||
|
||
/*******************************************************
|
||
|
||
M A I N P R O G R A M
|
||
|
||
********************************************************/
|
||
|
||
|
||
|
||
declare
|
||
i byte initial (1),
|
||
last$dseg$byte byte initial (0);
|
||
|
||
|
||
start:
|
||
/* process request */
|
||
ver = get$version;
|
||
if low(ver) < cpmversion or (high(ver) and 0fh) <> mpmproduct then
|
||
call print(.('Requires MP/M 2.0',0));
|
||
else
|
||
do;
|
||
/* call help$check; */
|
||
/* scan for global option */
|
||
do while buff(i)=' ';
|
||
i = i + 1;
|
||
end;
|
||
if buff(i) = '[' then do;
|
||
option, optdel, option$found = true;
|
||
parse$fn.buff$adr = .buff(i+1);
|
||
end;
|
||
else
|
||
parse$fn.buff$adr = .buff(1);
|
||
last$buff$adr = .buff(1); /* used by perror routine */
|
||
parse$fn.fcb$adr = .cmd;
|
||
user$code = getuser;
|
||
call getpd; /* get process descriptor */
|
||
call set$dpb; /* get disk parameter blk */
|
||
cdisk=cselect; /* get current disk */
|
||
ibp = parse;
|
||
do while more;
|
||
call is$there$more;
|
||
if option then
|
||
call parse$option;
|
||
else if more then
|
||
call setup$fcb; /* file or drive reference */
|
||
|
||
if optdel then
|
||
option, option$found = true;
|
||
else do;
|
||
option = false;
|
||
call return$errors(0FFh); /* bdos return errors */
|
||
if lblcmd then /* label options */
|
||
call write$label;
|
||
if scase <> -1 then /* file attributes */
|
||
call put$attributes;
|
||
if xfcbcmd then /* xfcb attributes */
|
||
call write$xfcb;
|
||
call return$errors(0);
|
||
if wild then
|
||
if getfile then do;
|
||
parse$fn.buff$adr = opt$adr;
|
||
option, optdel = true;
|
||
end;
|
||
else
|
||
wild = false;
|
||
end;
|
||
call is$there$more;
|
||
ibp = parse;
|
||
end;
|
||
end;
|
||
call terminate;
|
||
end;
|
||
|
||
|
||
|