mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-25 01:14:21 +00:00
1854 lines
53 KiB
Plaintext
1854 lines
53 KiB
Plaintext
$ TITLE('CPM 3.0 --- SET 1.3')
|
||
|
||
/* MULTI FILE INPUT VERSION 11/11/82 */
|
||
/* took out call passwd in readlabel */
|
||
/* added test for NONBANK in password, protect and default 11/19/82 */
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * SET * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
set:
|
||
do;
|
||
|
||
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',
|
||
tab literally '9',
|
||
cr literally '13',
|
||
lf literally '10',
|
||
ctrlc literally '3h',
|
||
ctrlx literally '18h',
|
||
ctrlh literally '8h';
|
||
|
||
declare
|
||
opt$access literally '0',
|
||
opt$archive literally '1',
|
||
opt$create literally '2',
|
||
opt$default literally '3',
|
||
opt$dir literally '4',
|
||
opt$f1 literally '5',
|
||
opt$f2 literally '6',
|
||
opt$f3 literally '7',
|
||
opt$f4 literally '8',
|
||
opt$name literally '9',
|
||
opt$pass literally '10',
|
||
opt$prot literally '11',
|
||
opt$ro literally '12',
|
||
opt$rw literally '13',
|
||
opt$sys literally '14',
|
||
opt$update literally '15',
|
||
opt$page literally '16',
|
||
opt$nopage literally '17',
|
||
|
||
PERIOD literally '02eh',
|
||
PAGE byte initial(false);
|
||
|
||
declare plm label public;
|
||
|
||
declare copyright (*) byte data (
|
||
' Copyright (c) 1982 Digital Research ');
|
||
|
||
/*
|
||
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 file name.',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),
|
||
on (*) byte data (' on ',0),
|
||
off (*) byte data (' off ',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 */
|
||
user$code byte; /* current user code */
|
||
|
||
|
||
/* Routines used in SET for CPM 3.0 */
|
||
|
||
/* 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;
|
||
|
||
|
||
crlf2: procedure;
|
||
|
||
call printchar(cr);
|
||
call printchar(lf);
|
||
|
||
end crlf2;
|
||
|
||
|
||
terminate: procedure;
|
||
call crlf2;
|
||
call mon1 (0,0);
|
||
end terminate;
|
||
|
||
|
||
crlf: procedure;
|
||
declare charin byte;
|
||
|
||
if PAGE then do;
|
||
line$out = line$out + 1; /* output > page size ? */
|
||
if line$out + 2 > line$page then do;
|
||
call crlf2;
|
||
call crlf2;
|
||
call printx(.('Press RETURN to continue.',0));
|
||
|
||
do while not check$con$stat;
|
||
end;
|
||
|
||
charin = mon2(1,0); /* read character */
|
||
if charin = ctrlc then call terminate;
|
||
line$out = 1;
|
||
call crlf2;
|
||
end;
|
||
end;
|
||
|
||
call crlf2;
|
||
|
||
end crlf;
|
||
|
||
print: procedure(a); /* print the string starting at address a until the
|
||
next 0 is encountered */
|
||
declare a address;
|
||
|
||
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;
|
||
|
||
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;
|
||
|
||
return$errors: procedure(mode); /* 0ff => return BDOS errors */
|
||
declare mode byte;
|
||
|
||
call mon1 (45,mode);
|
||
|
||
end return$errors;
|
||
|
||
setind: procedure(fcb) address; /* SFA for current fcb */
|
||
dcl fcb addr;
|
||
|
||
call setdma(.passwd);
|
||
return mon3(30,fcb);
|
||
|
||
end setind;
|
||
|
||
/********** DISK PARAMETER BLOCK **********************/
|
||
|
||
declare
|
||
dpba address,
|
||
dpb based dpba structure(
|
||
scptrk address,
|
||
blkshf byte,
|
||
blkmsk byte,
|
||
extmsk byte,
|
||
maxall address,
|
||
dirmax address,
|
||
dirblk address,
|
||
chksiz address,
|
||
offset address,
|
||
physhf byte,
|
||
phymsk byte);
|
||
|
||
|
||
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) address;
|
||
declare fcb address;
|
||
|
||
call setdma(.passwd); /* set dma=password */
|
||
return mon3(102,fcb);
|
||
|
||
end readxfcb;
|
||
|
||
wrxfcb: procedure(fcb) address;
|
||
declare fcb address;
|
||
|
||
call setdma(.passwd);
|
||
return mon3(103,fcb);
|
||
|
||
end wrxfcb;
|
||
|
||
|
||
reset$drv: procedure(drv) byte;
|
||
dcl drv byte;
|
||
|
||
return mon2(37,reset$mask(drv));
|
||
end reset$drv;
|
||
|
||
parse: procedure(pfcb) address external;
|
||
declare pfcb address;
|
||
|
||
end parse;
|
||
|
||
delete: procedure(fcb) byte;
|
||
declare fcb address;
|
||
|
||
return mon2(19,fcb);
|
||
|
||
end delete;
|
||
|
||
$ eject
|
||
|
||
|
||
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * GLOBAL DATA * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
declare
|
||
fnam literally '11',
|
||
ftyp literally '9',
|
||
rofile literally '9', /* read/only file */
|
||
sysfile literally '10', /* system 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
|
||
pwmask$on literally '80h',
|
||
pwmask$off literally '7fh',
|
||
acmask$on literally '40h',
|
||
acmask$off literally '0bfh',
|
||
upmask$on literally '20h',
|
||
upmask$off literally '0dfh',
|
||
crmask$on literally '10h',
|
||
crmask$off literally '0efh',
|
||
dlmask$on literally '1h',
|
||
dlmask$off literally '0feh';
|
||
|
||
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,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
|
||
passwd (17) byte; /* password buffer */
|
||
|
||
declare
|
||
sfacmd byte initial(false), /* 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 */
|
||
multi byte initial(false),
|
||
newpass byte initial(false),
|
||
passmsg byte initial(false),
|
||
NONBANK byte initial(false),
|
||
passmode byte,
|
||
password byte initial(false); /* file has password */
|
||
|
||
declare /* parsing */
|
||
more byte initial(true), /* more to parse */
|
||
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
|
||
err$nofile(*) byte data('Option requires a file reference',0),
|
||
|
||
err$driveonly(*) byte data('Option only for drives.',0),
|
||
errWASSPASS(*) byte data('Assign passwords to input files.',0),
|
||
|
||
errASSPASS(*) byte data('Assign a password to this file.',0),
|
||
errFORMAT(*) byte data(
|
||
'Directory needs to be re-formatted for time/date stamps.',cr,
|
||
lf,' Please see INITDIR.',0),
|
||
errNOPROT(*) byte data('Protection not enabled for disk.',0),
|
||
|
||
errUNREC(*) byte data('Unrecognized option.',0),
|
||
errNOMOD(*) byte data
|
||
('There are no modifiers for this option.',0),
|
||
errUNRECM(*) byte data
|
||
('Modifier missing or unrecognizable.',0),
|
||
errVALM(*) byte data
|
||
('Not a valid modifier for this option.',0),
|
||
errOPTMOD(*) byte data('This option needs a modifier.',0),
|
||
errBIGDEF(*) byte data
|
||
('Only first 8 characters of default password used.',0),
|
||
errBIGNAME(*) byte data
|
||
('Only first 11 characters of label name used.',0),
|
||
errBIGPASS(*) byte data
|
||
('Only first 8 characters of password used.',0),
|
||
errCRAC(*) byte data
|
||
('Cannot have both create and access time stamps.',0),
|
||
errSYSDIR(*) byte data('Cannot set both sys and dir.',0),
|
||
errRORW(*) byte data('Cannot set RO and RW.',0),
|
||
errNOPT(*) byte data('No options specified.',0),
|
||
errPAGE(*) byte data('Page and nopage option selected.',
|
||
' Nopage in effect.',0),
|
||
errGLOBAL(*) byte data
|
||
('Cannot set local options for file.',0),
|
||
errDrvProt(*) byte data
|
||
('Protection modifier is only ON/OFF for drives.',0),
|
||
errNBANK(*) byte data
|
||
('Password protection is not supported in NON-BANKED SYS.',0),
|
||
errVERS(*) byte data('Requires CP/M 3 or higher.',0);
|
||
|
||
$include (sopt.dcl)
|
||
|
||
declare
|
||
scbpd structure(
|
||
offs byte,
|
||
set byte,
|
||
value address);
|
||
|
||
declare
|
||
line$page byte,
|
||
line$out byte,
|
||
savefcb(16) byte,
|
||
save$dcnt address,
|
||
save$searcha address,
|
||
save$searchl address,
|
||
save$hash1 address,
|
||
save$hash2 address,
|
||
save$hash3 address,
|
||
|
||
COMbase literally '05dh',
|
||
page$off literally '01ch',
|
||
searcha$off literally '47h',
|
||
searchl$off literally '49h',
|
||
dcnt$off literally '45h',
|
||
hash1$off literally '00h',
|
||
hash2$off literally '02h',
|
||
hash3$off literally '04h';
|
||
|
||
/* get the scb word */
|
||
getscbword: procedure(off) address;
|
||
declare off byte;
|
||
|
||
scbpd.offs = off;
|
||
scbpd.set = 0;
|
||
return mon3(49,.scbpd);
|
||
|
||
end getscbword;
|
||
|
||
setscb: procedure(off,value);
|
||
declare off byte,
|
||
value address;
|
||
|
||
scbpd.offs = off;
|
||
scbpd.set = 0feh;
|
||
scbpd.value = value;
|
||
call mon1(49,.scbpd);
|
||
|
||
end setscb;
|
||
|
||
getpage: procedure byte;
|
||
|
||
scbpd.offs = page$off;
|
||
scbpd.set = 0;
|
||
return mon2(49,.scbpd);
|
||
|
||
end getpage;
|
||
|
||
$eject
|
||
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * BASIC ROUTINES * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
|
||
/* invalid command error */
|
||
perror: proc;
|
||
|
||
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 terminate;
|
||
end perror;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* parse the next lexical item in the command line
|
||
parse$fn must filled in with input parameters */
|
||
parser: procedure address;
|
||
declare p address;
|
||
declare c based p byte;
|
||
|
||
p = parse(.parse$fn);
|
||
if p = 0FFFFh then call perror;
|
||
else if p <> 0 then do;
|
||
if c = '[' then optdel = true;
|
||
else if c = ']' then optdel = false;
|
||
p = p + 1;
|
||
end;
|
||
else optdel = false;
|
||
|
||
return p;
|
||
|
||
end parser;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
fill: proc(s,f,c); /* fill string @ s for c bytes with f */
|
||
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: proc(s,d,c); /* copy c bytes from s to d */
|
||
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;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
ucase: proc byte; /* upper case character from console */
|
||
dcl c byte;
|
||
|
||
if (c:=conin) >= 'a' then
|
||
if c < '{' then
|
||
return(c-20h);
|
||
return c;
|
||
end ucase;
|
||
|
||
errprint: procedure(msg);
|
||
declare msg address;
|
||
|
||
call print(.errormsg);
|
||
call printx(msg);
|
||
call crlf;
|
||
|
||
end errprint;
|
||
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* 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;
|
||
else
|
||
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;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
bdos$error: procedure; /* error message routine */
|
||
declare
|
||
code byte;
|
||
|
||
call print(.error$msg);
|
||
if (code:=high(error$code)) < 3 then do;
|
||
call print(.error$msg);
|
||
call printdrv;
|
||
call printb;
|
||
|
||
if code = 1 then call printx(.('Disk I/O',0));
|
||
if code=2 then do;
|
||
call printx(.('Drive ',0));
|
||
call printx(.read$only);
|
||
end;
|
||
call terminate;
|
||
end;
|
||
|
||
if code = 3 then call printx(.read$only);
|
||
if code = 4 then call printx(.('Invalid Drive.',0));
|
||
if code = 7 then call printx(.('Wrong Password',0));
|
||
if code = 9 then call printx(.('? in filespec.',0));
|
||
|
||
end bdos$error;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
set$search: procedure(dcnt);
|
||
declare dcnt byte;
|
||
|
||
call setdma(.dirbuf);
|
||
dcnt = search$first(.('?'));
|
||
|
||
end set$search;
|
||
|
||
|
||
/* get address of FCB in dirbuf */
|
||
set$up$file: procedure(dir$index);
|
||
dcl dir$index byte;
|
||
|
||
if dir$index <> 0ffh then do;
|
||
fcbp = shl(dir$index,5) + .dirbuf;
|
||
fcbv(0) = fcb(0); /* set drive byte */
|
||
end;
|
||
|
||
end set$up$file;
|
||
|
||
getnext: procedure byte;
|
||
/* get the next fcb that matches fcb */
|
||
|
||
declare (dcnt,i) byte;
|
||
|
||
xfcbcmd,sfacmd = false;
|
||
|
||
|
||
call setdma(.dirbuf);
|
||
|
||
/* restore saved search parameters */
|
||
call setscb(dcnt$off,save$dcnt);
|
||
call setscb(searcha$off,save$searcha);
|
||
call setscb(searchl$off,save$searchl);
|
||
call setscb(hash1$off,save$hash1);
|
||
call setscb(hash2$off,save$hash2);
|
||
call setscb(hash3$off,save$hash3);
|
||
call copy(.savefcb,save$searcha,16);
|
||
|
||
if (dcnt := search$next) = 0ffh then return(false);
|
||
call set$up$file(dcnt);
|
||
return(true);
|
||
|
||
end getnext;
|
||
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* 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;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/*******************************************************
|
||
|
||
F I L E A T T R I B U T E S
|
||
|
||
********************************************************/
|
||
|
||
|
||
|
||
printatt: procedure; /* print attribute set */
|
||
|
||
attribute: procedure(i) byte; /* test if attribute fcbv(i) is on */
|
||
declare i byte;
|
||
|
||
if rol(fcbv(i),1) then return true;
|
||
return false;
|
||
end attribute;
|
||
|
||
/* display attributes: sys,ro,a,f1-f4 */
|
||
|
||
call printx(.set$to);
|
||
if attribute(sysfile) 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);
|
||
if attribute(archiv) then call printchar('A');
|
||
if attribute( attrb1 ) then call printchar('1');
|
||
if attribute( attrb2 ) then call printchar('2');
|
||
if attribute( attrb3 ) then call printchar('3');
|
||
if attribute( attrb4 ) then call printchar('4');
|
||
|
||
end print$att;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/* read current file attributes */
|
||
rd$attributes: procedure;
|
||
|
||
if not sfacmd then /* have read the FCB yet? */
|
||
if not wild then do;
|
||
call setdma(.dirbuf);
|
||
call set$up$file(search$first(.fcb));
|
||
end;
|
||
|
||
end rd$attributes;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/*******************************************************
|
||
|
||
D R I V E A T T R I B U T E S
|
||
|
||
********************************************************/
|
||
|
||
|
||
setdrvstatus: procedure(func); /* set drive attributes */
|
||
|
||
declare
|
||
code byte,
|
||
func byte;
|
||
|
||
/* set the drive */
|
||
if func = opt$ro then code = writeprot; /* read only */
|
||
else
|
||
code = reset$drv(cdisk); /* read/write */
|
||
|
||
/* display */
|
||
if code <> 0ffh then do;
|
||
call print(.('Drive ',0));
|
||
call printdrv;
|
||
call printb;
|
||
call printx(.set$to);
|
||
if func = opt$ro then do;
|
||
call printx(.read$only);
|
||
call printx(.ro);
|
||
end;
|
||
else
|
||
call printx(.read$write);
|
||
end;
|
||
|
||
end setdrvstatus;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/*******************************************************
|
||
|
||
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); /* position to first dcnt in dir */
|
||
do while dcnt <> 0ffh; /* read entire directory */
|
||
/* is the user# a label = 20h */
|
||
if dirbuf(ror(dcnt,3) and 110$0000b)=20H then return;
|
||
dcnt = search$next;
|
||
end;
|
||
|
||
end readlbl;
|
||
|
||
/*---------------------------------------------------------------*/
|
||
|
||
if lblcmd then return;
|
||
|
||
mode = getlbl(cdisk); /* get the dir label data byte */
|
||
password = false;
|
||
if mode > 0 then do; /* if ok then ...*/
|
||
call readlbl; /* get label */
|
||
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; /* no dir label */
|
||
fcbp = .fcb;
|
||
call copy(.label$name,.fcb(1),length(label$name));
|
||
end;
|
||
|
||
/* if password then call getpasswd;*/ /* does the user have the password*/
|
||
lblcmd = true;
|
||
|
||
end readlabel;
|
||
|
||
|
||
/**************************************************************************/
|
||
|
||
|
||
put$file: procedure; /* display the file or xfcb */
|
||
|
||
call crlf;
|
||
call printfn;
|
||
call printb;
|
||
call printb;
|
||
|
||
end put$file;
|
||
|
||
|
||
/*******************************************************
|
||
|
||
S F C B A T T R I B U T E S
|
||
|
||
********************************************************/
|
||
|
||
|
||
|
||
set$up$xfcb: procedure; /* read xfcb into xfcb buffer */
|
||
|
||
if not xfcbcmd then do;
|
||
xfcbcmd = true;
|
||
call copy(.fcbv,.xfcb,12);
|
||
password,passmode = 0;
|
||
|
||
if low(errorcode := readxfcb(.xfcb)) = 0ffh then do;
|
||
if high(errorcode) <> 0 then call bdos$error;
|
||
else do;
|
||
call errprint(.not$found);
|
||
call put$file;
|
||
end;
|
||
return;
|
||
end;
|
||
|
||
passmode = xfcb(12);
|
||
if passmode <> 0 then password = true; /* must have a pass if
|
||
mode ~= NONE */
|
||
end;
|
||
|
||
end set$up$xfcb;
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/*******************************************************
|
||
|
||
PASSWORD AND PASSWORD MODE ROUTINES
|
||
|
||
********************************************************/
|
||
|
||
|
||
defaultpass: procedure;
|
||
|
||
if NONBANK then do;
|
||
call errprint(.errNBANK);
|
||
return;
|
||
end;
|
||
|
||
call fill(.passwd(0),' ',8);
|
||
call copy(defpass,.passwd(0),lendef);
|
||
call mon1(106,.passwd);
|
||
call print(.('Default password = ',0));
|
||
passwd(8) = 0;
|
||
call printx(.passwd);
|
||
|
||
end defaultpass;
|
||
|
||
|
||
set$password: procedure;
|
||
|
||
if fileref then do;
|
||
|
||
if NONBANK then do;
|
||
call errprint(.errNBANK);
|
||
return;
|
||
end;
|
||
|
||
call set$up$xfcb;
|
||
passmode = passmode or 1; /* turn on password bit */
|
||
end;
|
||
else do;
|
||
call readlabel;
|
||
fext = fext or 1;
|
||
end;
|
||
|
||
call fill(.passwd(8),' ',8); /* clear passwd */
|
||
|
||
if lenpass = 0 then do;
|
||
passmode = 1;
|
||
return;
|
||
end;
|
||
|
||
newpass = true;
|
||
call copy(passname,.passwd(8),lenpass); /* copy it to fcb */
|
||
|
||
end set$password;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
/*******************************************************
|
||
|
||
LABEL ATTRIBUTE ROUTINES
|
||
|
||
********************************************************/
|
||
|
||
lname: procedure; /* sets the label name */
|
||
declare i byte,
|
||
ln based labname (1) byte;
|
||
|
||
if drvmsg then return;
|
||
|
||
if fileref then do;
|
||
call errprint(.err$driveonly);
|
||
drvmsg = true;
|
||
return;
|
||
end;
|
||
|
||
call readlabel;
|
||
|
||
call fill(.fcbv(1),' ',11); /* clear name */
|
||
|
||
if lenlab > 0 then do;
|
||
do i = 0 to lenlab-1;
|
||
if ln(i) = PERIOD then do;
|
||
call copy(labname,.fcbv(1),i);
|
||
call copy(labname+i+1,.fcbv(9),3);
|
||
return;
|
||
end;
|
||
end;
|
||
|
||
call copy(labname,.fcbv(1),lenlab); /* copy label name */
|
||
|
||
end;
|
||
|
||
end lname;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
set$extent: procedure(function,maskon,maskoff);
|
||
declare
|
||
function byte,
|
||
maskon byte,
|
||
maskoff byte;
|
||
|
||
if drvmsg then return;
|
||
|
||
if fileref then do;
|
||
drvmsg = true;
|
||
call errprint(.err$driveonly);
|
||
return;
|
||
end;
|
||
|
||
call readlabel;
|
||
if mods$map(function) then fext = fext or maskon; /* turn stamp on */
|
||
else fext = fext and maskoff; /* turn stamp off */
|
||
|
||
return;
|
||
|
||
end set$extent;
|
||
|
||
|
||
protect: procedure; /* set drive protection mode */
|
||
declare pmode byte;
|
||
|
||
if fileref then do;
|
||
call set$up$xfcb;
|
||
pmode = mods$map(opt$prot);
|
||
|
||
if pmode = 2 then passmode = 80h; /* read only */
|
||
else
|
||
if pmode = 3 then passmode = 40h; /* write,read */
|
||
else
|
||
if pmode = 4 then passmode = 20h; /* r,w,delete */
|
||
else do ;
|
||
passmode = 1; /* turn off protection*/
|
||
|
||
call fill(.passwd(8),' ',8);
|
||
end;
|
||
if newpass then passmode = passmode or 1;
|
||
end;
|
||
else do;
|
||
|
||
if NONBANK then do;
|
||
call errprint(.errNBANK);
|
||
return;
|
||
end;
|
||
|
||
pmode = mods$map(opt$prot);
|
||
if pmode > 1 then do;
|
||
call errprint(.errDrvProt);
|
||
return;
|
||
end;
|
||
|
||
call set$extent(opt$prot,pwmask$on,pwmask$off);
|
||
call fill(.fcbv(16),' ',8); /* erase password */
|
||
end;
|
||
|
||
end protect;
|
||
|
||
/*------------------------------------------------------------*/
|
||
|
||
/* set attribute bits:
|
||
f1 --> f4 flags
|
||
t1 --> t3 flags or
|
||
RO
|
||
SYS
|
||
Archive */
|
||
|
||
setatt: procedure(func,bytes);
|
||
declare func byte,
|
||
bytes byte;
|
||
|
||
|
||
if sfamsg then return; /* printed msg before? */
|
||
if not fileref then do;
|
||
sfamsg = true;
|
||
call errprint(.err$nofile);
|
||
return;
|
||
end;
|
||
|
||
if mods$map(func) then fcbv(bytes) = fcbv(bytes) or 80h;
|
||
else fcbv(bytes) = fcbv(bytes) and 7fh;
|
||
|
||
sfacmd = true;
|
||
end setatt;
|
||
|
||
/*******************************************************
|
||
|
||
S H O W L A B E L & X F C B
|
||
|
||
********************************************************/
|
||
|
||
|
||
show$passwd: procedure; /* display the new password */
|
||
|
||
call printx(.('Password = ',0));
|
||
passwd(16) = 0;
|
||
call printx(.passwd(8));
|
||
|
||
end show$passwd;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
dcl label1 (*) byte data (
|
||
'Directory Passwds Stamp Stamp Stamp',cr,lf,
|
||
'Label Reqd Create Access Update',cr,lf,
|
||
'-------------- ------- ------- ------- -------',cr,lf,0);
|
||
|
||
showlbl: procedure; /* show the label options */
|
||
declare (make,access) byte;
|
||
|
||
call print(.('Label for drive ',0));
|
||
call printdrv;
|
||
call crlf;
|
||
call print(.label1);
|
||
call printfn;
|
||
|
||
if (fext and 80h) = 80h then /* PASSWORDS REQUIRED */
|
||
call printx(.on);
|
||
else
|
||
call printx(.off);
|
||
|
||
access = (fext and 40h) = 40h; /* STAMP CREATE */
|
||
if (fext and 10h) = 10h then
|
||
call printx(.on);
|
||
else
|
||
call printx(.off);
|
||
|
||
if access then /* STAMP ACCESS */
|
||
call printx(.on);
|
||
else
|
||
call printx(.off);
|
||
|
||
if (fext and 20h) = 20h then /* STAMP UPDATE */
|
||
call printx(.on);
|
||
else
|
||
call printx(.off);
|
||
|
||
call crlf;
|
||
if fext then do;
|
||
call crlf;
|
||
call show$passwd;
|
||
end;
|
||
|
||
end showlbl;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
show$xfcb: procedure; /* display xfcb attributes */
|
||
|
||
call printx(.('Protection = ',0));
|
||
|
||
if (passmode and 80h) = 80h then call printx(.readmode);
|
||
else
|
||
if (passmode and 40h) = 40h then call printx(.writemode);
|
||
else
|
||
if (passmode and 20h) = 20h then call printx(.deletemode);
|
||
else
|
||
if (not passmode) or (passwd(8) = ' ') then call printx(.nopasswd);
|
||
else
|
||
call printx(.readmode);
|
||
|
||
if passmode then do; /* lsb on */
|
||
call printx(.comma);
|
||
call show$passwd;
|
||
end;
|
||
|
||
end show$xfcb;
|
||
|
||
|
||
/*******************************************************
|
||
|
||
WRITE XFCB, LABEL AND FILE ATTRIBUTES
|
||
|
||
********************************************************/
|
||
|
||
pass$check: procedure(which) byte;
|
||
declare which byte;
|
||
/* did we fail because of password?
|
||
if so, then get it and re-try.
|
||
which = 1 <-- put$attribute
|
||
2 <-- write$label
|
||
3 <-- write$xfcb */
|
||
if high(error$code) = 7 then do;
|
||
call crlf;
|
||
if which <> 2 then call put$file;
|
||
else call print(.dirlabel);
|
||
call getpasswd;
|
||
if fileref then call crlf;
|
||
/* put attributes ? */
|
||
if which = 1 then error$code = setind(fcbp);
|
||
else /* write label ? */
|
||
if which = 2 then error$code = wrlbl(fcbp);
|
||
else /* update xfcb */
|
||
error$code = wrxfcb(.xfcb);
|
||
|
||
if high(error$code) <> 0 then do;
|
||
call bdos$error;
|
||
if which = 2 then call print(.dirlabel);
|
||
else call put$file;
|
||
return(false);
|
||
end;
|
||
end;
|
||
|
||
return(true);
|
||
|
||
end pass$check;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
put$attributes: procedure; /* write file attributes */
|
||
|
||
error$code = setind(fcbp);
|
||
|
||
if low(error$code) = 0ffh then
|
||
if high(error$code) <> 0 then do;
|
||
if not pass$check(1) then return;
|
||
if high(error$code) <> 0 then do;
|
||
call bdos$error;
|
||
call put$file;
|
||
return;
|
||
end;
|
||
end;
|
||
else do;
|
||
call errprint(.not$found);
|
||
call put$file;
|
||
end;
|
||
|
||
if low(error$code) <> 0ffh then
|
||
if fext <= dpb.extmsk then do;
|
||
call put$file;
|
||
call print$att;
|
||
end;
|
||
|
||
end put$attributes;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
write$label: procedure; /* write new label */
|
||
|
||
error$code = wrlbl(fcbp);
|
||
|
||
if low(error$code) = 0ffh then
|
||
if high(error$code) <> 0 then do;
|
||
if not pass$check(2) then return;
|
||
if high(error$code) <> 0 then do;
|
||
call bdos$error;
|
||
call print(.dirlabel);
|
||
return;
|
||
end;
|
||
call crlf;
|
||
end;
|
||
else do;
|
||
call errprint(.errFORMAT);
|
||
return;
|
||
end;
|
||
|
||
call showlbl;
|
||
|
||
end write$label;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
write$xfcb: procedure; /* write out new xfcb */
|
||
|
||
if passmode > 1 then do;
|
||
if password then go to wr0;
|
||
if newpass then go to wr0;
|
||
|
||
if passmsg then return;
|
||
|
||
if wild then
|
||
call errprint(.errWASSPASS);
|
||
else do;
|
||
call errprint(.errASSPASS);
|
||
call put$file;
|
||
end;
|
||
|
||
passmsg = true;
|
||
return;
|
||
end;
|
||
|
||
wr0: if passmode = 1 then
|
||
if newpass then passmode = passmode or 80h; /* read mode = def */
|
||
|
||
xfcbmode = passmode;
|
||
error$code = wrxfcb(.xfcb);
|
||
|
||
if low(error$code) = 0ffh then
|
||
if high(error$code) <> 0 then do;
|
||
if not pass$check(3) then return;
|
||
if high(error$code) <> 0 then do;
|
||
call bdos$error;
|
||
call put$file;
|
||
return;
|
||
end;
|
||
end;
|
||
else do;
|
||
call errprint(.not$found);
|
||
call print(.(' or protection not enabled for disk.',0));
|
||
return;
|
||
end;
|
||
|
||
if passmode = 1 then do; /* delete xfcb */
|
||
wr1: xfcb(5) = xfcb(5) or 80h;
|
||
error$code = delete(.xfcb); /* no need to check for error*/
|
||
end; /* previous write-> failed!*/
|
||
|
||
|
||
call put$file;
|
||
call show$xfcb; /* errcode is good if we are here */
|
||
|
||
end write$xfcb;
|
||
|
||
|
||
|
||
|
||
/*******************************************************
|
||
|
||
C O M M A N D P R O C E S S I N G
|
||
|
||
********************************************************/
|
||
|
||
|
||
|
||
setdisk: procedure; /* select the disk specified in cmd line */
|
||
|
||
if cmd(0) <> 0 then do;
|
||
cdisk = cmd(0)-1;
|
||
call select(cdisk);
|
||
call set$dpb;
|
||
end;
|
||
|
||
end setdisk;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
wildcard: procedure byte; /* test if the file is a wildcard */
|
||
declare
|
||
i byte;
|
||
|
||
do i=1 to fnam;
|
||
if fcb(i) = '?' then return true;
|
||
end;
|
||
return false;
|
||
end wildcard;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
|
||
setup$fcb: procedure; /* set up the next file or drive reference */
|
||
declare dcnt byte;
|
||
|
||
call setdisk;
|
||
call copy(.cmd,.fcb,12); /* name */
|
||
call copy(.cmd(16),.passwd,8); /* password */
|
||
|
||
if fcb(1) <> ' ' or fcb(ftyp) <> ' ' then do;
|
||
fileref = true;
|
||
call setdma(.dirbuf);
|
||
if (dcnt := search$first(.fcb)) = 0ffh then do;
|
||
fcbp = .fcb;
|
||
call errprint(.not$found);
|
||
call put$file;
|
||
call terminate;
|
||
end;
|
||
call set$up$file(dcnt);
|
||
end;
|
||
else fileref = false;
|
||
|
||
end setup$fcb;
|
||
|
||
$include (sopt.inc)
|
||
|
||
parse$options: procedure;
|
||
|
||
declare
|
||
charac based buf$ptr byte,
|
||
l byte;
|
||
|
||
delimiter = 1;
|
||
index = 0;
|
||
mindex = 0;
|
||
|
||
loop:
|
||
if delimiter = 0 then return;
|
||
if delimiter = RBRACKET then return;
|
||
if delimiter = ENDFF then return;
|
||
|
||
/* get the index into list */
|
||
if (index := opt$scanner(.options,.off$opt)) = 0 then go to error1;
|
||
|
||
/* if we have more to parse,
|
||
check for valid modifiers */
|
||
if (delimiter <> RBRACKET and delimiter <> ENDFF) then do;
|
||
|
||
/* is this a mod delimiter?
|
||
test for equal sign. */
|
||
if delimiter = EQUAL then do;
|
||
/* does option have a modifier?*/
|
||
|
||
if not opt$mod(index-1).modifier(0) then go to error2;
|
||
|
||
/* is this a string modifier, ie.,
|
||
password,default,name option */
|
||
|
||
if not opt$mod(index-1).modifier(7) then do;
|
||
|
||
if (mindex := opt$scanner(.mods,.off$mods)) = 0
|
||
then go to error3;
|
||
|
||
/* invalid option-modifier pair */
|
||
|
||
if not opt$mod(index-1).modifier(mindex) then
|
||
go to error4;
|
||
|
||
end; /* ends getting non-string mod */
|
||
|
||
else do;
|
||
/* get string */
|
||
string$ptr = buf$ptr;
|
||
mindex = 8;
|
||
delimiter = 0;
|
||
l = 0;
|
||
do while delimiter = 0;
|
||
delimiter = separator(charac);
|
||
buf$ptr = buf$ptr + 1;
|
||
l = l + 1;
|
||
end;
|
||
|
||
if delimiter = SPACE then do;
|
||
delimiter = separator(charac);
|
||
buf$ptr = buf$ptr + 1;
|
||
end;
|
||
|
||
l = l - 1;
|
||
if l > 0 then do;
|
||
if (index -1) = opt$default then do;
|
||
defpass = string$ptr;
|
||
if (lendef := l) > 8 then do;
|
||
call errprint(.errBIGDEF);
|
||
lendef = 8;
|
||
end;
|
||
end;
|
||
else
|
||
if (index -1) = opt$name then do;
|
||
labname = string$ptr;
|
||
if (lenlab := l) > 11 then do;
|
||
lenlab = 11;
|
||
call errprint(.errBIGNAME);
|
||
end;
|
||
end;
|
||
else do;
|
||
passname = string$ptr;
|
||
if (lenpass := l) > 8 then do;
|
||
call errprint(.errBIGPASS);
|
||
lenpass= 8;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
end; /* ends mod delimiter? */
|
||
end; /* ends last delimiter */
|
||
|
||
/* option without modifier...
|
||
index must be > 0 */
|
||
if mindex = 0 and opt$mod(index-1).modifier(0) then go to error5;
|
||
|
||
option$map(index - 1) = true;
|
||
if mindex > 0 then mods$map(index - 1) = mindex - 1;
|
||
|
||
go to loop; /* skip error routine */
|
||
|
||
error1: call errprint(.errUNREC);
|
||
go to optprt;
|
||
error2: call errprint(.errNOMOD);
|
||
go to optprt;
|
||
error3: call errprint(.errUNRECM);
|
||
go to modprt;
|
||
error4: call errprint(.errVALM);
|
||
go to modprt;
|
||
error5: call errprint(.errOPTMOD);
|
||
go to optprt;
|
||
modprt: call print(.('Modifier: ',0));
|
||
go to errprt;
|
||
optprt: call print(.('Option: ',0));
|
||
errprt: call error$prt;
|
||
|
||
go to loop;
|
||
|
||
end parse$options;
|
||
|
||
do$options: procedure;
|
||
declare dump byte;
|
||
|
||
if option$map(opt$archive) then
|
||
call setatt(opt$archive,archiv);
|
||
|
||
if option$map(opt$f1) then call setatt(opt$f1,attrb1);
|
||
if option$map(opt$f2) then call setatt(opt$f2,attrb2);
|
||
if option$map(opt$f3) then call setatt(opt$f3,attrb3);
|
||
if option$map(opt$f4) then call setatt(opt$f4,attrb4);
|
||
|
||
if option$map(opt$name) then call lname; /*Dir name*/
|
||
if option$map(opt$pass) then call set$password;
|
||
if option$map(opt$prot) then call protect;
|
||
if option$map(opt$default) then call defaultpass;
|
||
|
||
if option$map(opt$access) and option$map(opt$create) then do;
|
||
if mods$map(opt$access) and mods$map(opt$create) then do;
|
||
if fileref then call errprint(.err$driveonly);
|
||
call errprint(.errCRAC);
|
||
call crlf;
|
||
go to do1;
|
||
end;
|
||
end;
|
||
|
||
if option$map(opt$access) then do;
|
||
if mods$map(opt$access) then do; /* turn off create */
|
||
mods$map(opt$create) = 0;
|
||
call set$extent(opt$create,crmask$on,crmask$off);
|
||
end;
|
||
call set$extent(opt$access,acmask$on,acmask$off);
|
||
end;
|
||
if option$map(opt$create) then do;
|
||
if mods$map(opt$create) then do; /* turn off access */
|
||
mods$map(opt$access) = 0;
|
||
call set$extent(opt$access,acmask$on,acmask$off);
|
||
end;
|
||
call set$extent(opt$create,crmask$on,crmask$off);
|
||
end;
|
||
|
||
/* Note that sys and dir do NOT have
|
||
modifiers; thus the option scanner
|
||
did not fill in the modifier map,
|
||
which setatt looks at to turn things
|
||
on/off. So we have to set the mod
|
||
map here. applies to archive too */
|
||
|
||
do1: if option$map(opt$dir) and option$map(opt$sys) then do;
|
||
if not fileref then call errprint(.err$nofile);
|
||
call errprint(.errSYSDIR);
|
||
call crlf;
|
||
end;
|
||
else do;
|
||
if option$map(opt$dir) then
|
||
/* do not turn sys on */
|
||
call setatt(opt$sys,sysfile);
|
||
|
||
else if option$map(opt$sys) then do;
|
||
mods$map(opt$sys) = true;
|
||
call setatt(opt$sys,sysfile);
|
||
end;
|
||
end;
|
||
|
||
if option$map(opt$update) then
|
||
call set$extent(opt$update,upmask$on,upmask$off);
|
||
|
||
if option$map(opt$ro) and option$map(opt$rw) then do;
|
||
call errprint(.errRORW);
|
||
call crlf;
|
||
end;
|
||
else do;
|
||
if option$map(opt$ro) then
|
||
if fileref then do;
|
||
mods$map(opt$ro) = 1;
|
||
call setatt(opt$ro,rofile);
|
||
end;
|
||
else call setdrvstatus(opt$ro);
|
||
else
|
||
if option$map(opt$rw) then
|
||
if fileref then do;
|
||
/* turn ro off */
|
||
mods$map(opt$ro) = 0;
|
||
call setatt(opt$ro,rofile);
|
||
end;
|
||
else call setdrvstatus(opt$rw);
|
||
end;
|
||
end do$options;
|
||
|
||
save: procedure;
|
||
|
||
/* save search parameters for later wild
|
||
card processing */
|
||
|
||
save$dcnt = getscbword(dcnt$off);
|
||
save$searcha = getscbword(searcha$off);
|
||
save$searchl = getscbword(searchl$off);
|
||
save$hash1 = getscbword(hash1$off);
|
||
save$hash2 = getscbword(hash2$off);
|
||
save$hash3 = getscbword(hash3$off);
|
||
|
||
end save;
|
||
|
||
|
||
savewild: procedure;
|
||
|
||
/* save wildcard name for later processing */
|
||
if (wild := wildcard) then call copy(.cmd,.savefcb,12);
|
||
call setup$fcb;
|
||
|
||
end savewild;
|
||
|
||
|
||
getfilename: procedure(buffadd);
|
||
declare buffadd address;
|
||
|
||
parse$fn.buff$adr = buffadd;
|
||
last$buff$adr = buffadd; /* used by perror routine */
|
||
parse$fn.fcb$adr = .cmd;
|
||
ibp = parser; /* parse file name */
|
||
|
||
end getfilename;
|
||
|
||
getfname: procedure;
|
||
|
||
call getfilename(bufptr);
|
||
|
||
if optdel then do; /* no local options */
|
||
call errprint(.errGLOBAL);
|
||
cmd(12) = 0;
|
||
call print(.('FILE: ',0));
|
||
call printx(.cmd(1));
|
||
call terminate;
|
||
end;
|
||
/* F152 returns ~= 0 if
|
||
another file name
|
||
follows in buffer */
|
||
if ibp <> 0 then multi = true;
|
||
else multi = false;
|
||
|
||
call copy(.cmd,.fcb,16); /* copy file name to
|
||
default buffer..*/
|
||
call savewild;
|
||
|
||
end getfname;
|
||
|
||
$eject
|
||
/*******************************************************
|
||
|
||
M A I N P R O G R A M
|
||
|
||
********************************************************/
|
||
|
||
declare
|
||
i byte initial (1),
|
||
last$dseg$byte byte initial (0),
|
||
(vlow,vhigh) byte;
|
||
|
||
/*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
|
||
|
||
exec: procedure;
|
||
|
||
|
||
do while more;
|
||
|
||
if wild then call save;
|
||
|
||
call do$options; /* perform options specified */
|
||
|
||
call return$errors(0FFh); /* Return mode */
|
||
|
||
if lblcmd then /* label options */
|
||
call write$label;
|
||
else do;
|
||
if sfacmd then /* file attributes*/
|
||
call put$attributes;
|
||
if xfcbcmd then /* xfcb attributes*/
|
||
call write$xfcb;
|
||
end;
|
||
|
||
call return$errors(0);
|
||
|
||
if not wild then more = false;
|
||
/*wild card expansion */
|
||
else
|
||
if not getnext then more = false;
|
||
|
||
end;
|
||
|
||
end exec;
|
||
|
||
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
|
||
|
||
plm:
|
||
ver = get$version;
|
||
vlow = low(ver);
|
||
vhigh = high(ver);
|
||
|
||
line$page = getpage; /* #lines per page */
|
||
line$out = 0;
|
||
|
||
if vlow < cpmversion then go to errver;
|
||
|
||
user$code = getuser;
|
||
call set$dpb; /* get disk parameter blk */
|
||
cdisk=cselect; /* get current disk */
|
||
|
||
do while buff(i)=' ';
|
||
i = i + 1;
|
||
end;
|
||
buf$ptr = .buff(i);
|
||
|
||
if buff(i) = '[' then do; /* first, options */
|
||
buf$ptr = buf$ptr + 1;
|
||
call parse$options; /* delimiter = ] or
|
||
null if end of cmd tail */
|
||
|
||
if delimiter = RBRACKET then call getfname;
|
||
else do;
|
||
call fill(.cmd(1),' ',26); /* blank out command line */
|
||
cmd(0) = 0;
|
||
end;
|
||
end;
|
||
else do; /* filename ? */
|
||
call getfilename(.buff(1)); /* will set multi */
|
||
|
||
if optdel then do;
|
||
buf$ptr = ibp;
|
||
call parseoptions;
|
||
end;
|
||
else do;
|
||
call errprint(.errNOPT);
|
||
call terminate;
|
||
end;
|
||
call savewild;
|
||
end;
|
||
|
||
if option$map(opt$page) and option$map(opt$nopage) then do;
|
||
call errprint(.errPAGE);
|
||
call crlf;
|
||
PAGE = false;
|
||
end;
|
||
else if option$map(opt$nopage) then PAGE = false;
|
||
else if option$map(opt$page) then PAGE = true;
|
||
|
||
if high(getscbword(COMbase)) = 0 then NONBANK = true;
|
||
|
||
call exec;
|
||
do while multi;
|
||
buf$ptr = ibp;
|
||
more = true;
|
||
call getfname;
|
||
call exec;
|
||
end;
|
||
|
||
call terminate;
|
||
|
||
errver: call errprint(.errVERS);
|
||
call terminate;
|
||
end;
|
||
|
||
|