mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-26 09:54:20 +00:00
1674 lines
45 KiB
Plaintext
1674 lines
45 KiB
Plaintext
$ TITLE('SET: Sets BDOS/XFCB options for MP/M & CCP/M')
|
|
$ COMPACT
|
|
|
|
/* Revised:
|
|
9/4/81 changes in upper case
|
|
23 Jun 82 by Bill Fitler
|
|
1/26/83 for CCPM 2.0 by F.Borda
|
|
*/
|
|
|
|
$include (:f2:copyrt.lit)
|
|
|
|
$include (:f2:vaxcmd.lit)
|
|
|
|
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
|
|
* * * SET * * *
|
|
|
|
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
|
set:
|
|
do;
|
|
|
|
$include (:f2:vermpm.lit)
|
|
|
|
declare copyright (*) byte data (
|
|
' Copyright (c) 1983, Digital Research ');
|
|
|
|
declare versiondate (*) byte data ('02/15/83');
|
|
declare version (*) byte data ('SET 2.1',0);
|
|
|
|
|
|
|
|
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';
|
|
$ 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),
|
|
errATTRIB (*) byte data (' Attribute.',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),
|
|
fail (*) byte data ('Invalid drive attribute.',0),
|
|
failed (*) byte data ('Could not reset an open drive.',0),
|
|
label$name (*) byte data ('Label'),
|
|
errRDLBL (*) byte data ('Directory Label does not exist.',0),
|
|
errNOPASS (*) byte data ('Assign a password to this file.',0),
|
|
errENAB (*) byte data
|
|
('Enable password protection first: SET d: [PROTECT=ON].',0),
|
|
errCRAC (*) byte data
|
|
('Cannot have both create and access time stamps.',0),
|
|
errFORMAT (*) byte data
|
|
('Directory needs to be reformatted for time/date stamping.',0),
|
|
errFORM2 (*) byte data (' Use "INITDIR d:"',0),
|
|
err$nofile (*) byte data ('Option requires a file reference.',0);
|
|
|
|
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
|
|
|
|
|
* * * CP/M INTERFACE * * *
|
|
|
|
|
|
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
|
|
|
$include (:f2:proces.lit)
|
|
|
|
$include (:f2:uda.lit)
|
|
|
|
|
|
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 */
|
|
|
|
|
|
/* 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 );
|
|
|
|
|
|
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;
|
|
|
|
MON4: PROCEDURE (F,A) POINTER EXTERNAL;
|
|
DECLARE F BYTE, A ADDRESS;
|
|
END MON4;
|
|
|
|
|
|
|
|
|
|
/********** SYSTEM FUNCTION CALLS *********************/
|
|
|
|
BOOT: PROCEDURE;
|
|
CAll MON1(0,0);
|
|
/* reboot */
|
|
END BOOT;
|
|
|
|
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);
|
|
|
|
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
|
|
DPBPTR POINTER,
|
|
dpb based DPBPTR 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 */
|
|
DPBPTR = MON4(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
|
|
PD$POINTER POINTER,
|
|
PD$PTR STRUCTURE (
|
|
OFF ADDRESS,
|
|
SEGMENT ADDRESS) AT (@PD$POINTER),
|
|
pd based PD$POINTER PD$STRUCTURE,
|
|
|
|
PD$PARENT$POINTER POINTER,
|
|
PD$PARENT$PTR STRUCTURE (
|
|
OFF ADDRESS,
|
|
SEGMENT ADDRESS) AT (@PD$PARENT$POINTER),
|
|
PD$PARENT based PD$PARENT$POINTER PD$STRUCTURE;
|
|
|
|
DECLARE
|
|
|
|
UDA$POINTER POINTER,
|
|
UDA$PTR STRUCTURE (
|
|
OFF ADDRESS,
|
|
SEGMENT ADDRESS) AT (@UDA$POINTER),
|
|
UDA BASED UDA$POINTER UDA$STRUCTURE,
|
|
|
|
UDA$PARENT$POINTER POINTER,
|
|
UDA$PARENT$PTR STRUCTURE (
|
|
OFF ADDRESS,
|
|
SEGMENT ADDRESS) AT (@UDA$PARENT$POINTER),
|
|
UDA$PARENT BASED UDA$PARENT$POINTER UDA$STRUCTURE;
|
|
|
|
|
|
GET$PD$UDA: PROCEDURE;
|
|
|
|
PDPOINTER = MON4(156,0);
|
|
UDA$PTR.OFF = 0;
|
|
UDA$PTR.SEGMENT = PD.UDA;
|
|
END GET$PD$UDA;
|
|
|
|
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 */
|
|
mxstamp byte initial(false);/* separates create,update*/
|
|
|
|
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
|
|
('REWRDENO',0),
|
|
boolean (*) byte data
|
|
('OFONValue, Use ON or OFF',0);
|
|
|
|
/* VALUES FILE ATTRIBUTES
|
|
mode keyword scase attribute
|
|
0 READ 0 RW
|
|
1 WRITE 1 RO
|
|
2 DELETE 2 DIR
|
|
3 NONE 3 SYS
|
|
4 ARCHIVE
|
|
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 [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 [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 = UDA.DCNT;
|
|
sav$searchl = UDA.SEARCHL;
|
|
sav$searcha = UDA.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(.errATTRIB);
|
|
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
|
|
if ((cmd(1) = 'R') and (cmd(2) = 'W'))then
|
|
code = reset$drv(cdisk); /* RW */
|
|
else do; /* Invalid drive option */
|
|
call print(.fail);
|
|
call terminate;
|
|
end;
|
|
|
|
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;
|
|
|
|
if (getlbl(cdisk) and 80h) <> 80h then /* Is drive password enabled? */
|
|
do; /* If not, print and leave. */
|
|
call print(.errENAB);
|
|
call terminate;
|
|
end;
|
|
|
|
call fill(.cmd(1),' ',8);
|
|
ibp = parse; /* get password */
|
|
call mon1(106,.cmd(1)); /* set default password */
|
|
call print(.('Default Password ',0));
|
|
call printcmd;
|
|
|
|
CALL GET$PD$UDA;
|
|
PD$PARENT$PTR.SEGMENT = PD$PTR.SEGMENT;
|
|
PD$PARENT$PTR.OFF = PD.PARENT;
|
|
UDA$PARENT$PTR.SEGMENT = PD$PARENT.UDA;
|
|
UDA$PARENT$PTR.OFF = 0;
|
|
CALL MOVW(@UDA.DF$PASSWORD,@UDA$PARENT.DF$PASSWORD,4);
|
|
|
|
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(.errRDLBL);
|
|
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 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 (getlbl(cdisk) and 80h) <> 80h then /* Is the drive passwd enabled? */
|
|
do; /* If not, print and leave */
|
|
call print(.errENAB);
|
|
call terminate;
|
|
end;
|
|
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 = true;
|
|
end zeropass;
|
|
|
|
|
|
call parse$value; /* protection value */
|
|
if fileref then do;
|
|
if ((getlbl(cdisk) and 80h) <> 80h) then
|
|
do; /* Must set protect=on first */
|
|
call print(.errENAB);
|
|
call terminate;
|
|
end;
|
|
call set$up$xfcb;
|
|
if xfcbmode then /* lsb */
|
|
new$password = true; /* save */
|
|
else
|
|
new$password = false;
|
|
|
|
|
|
do case match(.values,3);
|
|
xfcbmode = 80h; /* READ */
|
|
xfcbmode = 40h; /* WRITE */
|
|
xfcbmode = 20h; /* DELETE */
|
|
call zeropass; /* NONE */
|
|
end;
|
|
|
|
if new$password then /* restore */
|
|
xfcbmode = xfcbmode or 1;
|
|
|
|
|
|
end;
|
|
else do; /* Not a file ref, do the label */
|
|
call readlabel;
|
|
if bool then
|
|
fext = fext or 80h; /* turn on passwords */
|
|
else
|
|
fext = fext and 01111111b; /* turn off passwords */
|
|
end;
|
|
end ;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
|
|
|
|
/*******************************************************
|
|
|
|
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;
|
|
if mxstamp then /* Create has also been chosen */
|
|
do;
|
|
call print(.errCRAC);
|
|
call terminate;
|
|
end;
|
|
else
|
|
do;
|
|
fext = fext or 40h; /* turn on access ts */
|
|
fext = fext and 11101111b; /* turn off create ts */
|
|
mxstamp = true; /* Mark 1 of 2 as chosen */
|
|
end;
|
|
end;
|
|
end access;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
|
|
/* set update time stamping */
|
|
update: procedure;
|
|
|
|
call getbool;
|
|
if not bool then
|
|
fext = fext and 11011111b; /* turn off update ts */
|
|
else
|
|
fext = fext or 20h; /* turn on update ts */
|
|
end update;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
|
|
/* set create time stamping */
|
|
create: procedure;
|
|
|
|
call getbool;
|
|
if not bool then
|
|
fext = fext and 11101111b; /* turn off create ts*/
|
|
else
|
|
do;
|
|
if mxstamp then /* Access has also been chosen */
|
|
do;
|
|
call print(.errCRAC);
|
|
call terminate;
|
|
end;
|
|
else
|
|
do;
|
|
fext = fext or 10h; /* turn on create ts */
|
|
fext = fext and 10111111b; /* turn off access ts*/
|
|
mxstamp = true; /* Mark 1 of 2 mx stamps */
|
|
end; /* as being chosen */
|
|
end;
|
|
end create;
|
|
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
|
|
|
|
|
|
|
/*******************************************************
|
|
|
|
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 Stamp Stamp Stamp',cr,lf,
|
|
'Label Reqd 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);
|
|
|
|
/* STAMP CREATE */
|
|
if (fext and 10h) = 10h then
|
|
call printx(.on);
|
|
else
|
|
call printx(.off);
|
|
|
|
/* STAMP ACCESS */
|
|
if (fext and 40h) = 40h 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; /* xfcbmode = true status of file */
|
|
if not(password) then do;/* must first have a password */
|
|
call printx(.error$msg);
|
|
call printx(.errNOPASS);
|
|
return; /* error condition */
|
|
end;
|
|
else do; /* No protection at all. This = default */
|
|
call printx(.('Protection = ',0));
|
|
call printx(.nopasswd);
|
|
end;
|
|
end;
|
|
else do;
|
|
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 xfcbmode then
|
|
do;
|
|
call printx(.comma);
|
|
call show$passwd;
|
|
end;*/
|
|
end;
|
|
|
|
end ;
|
|
|
|
|
|
/*******************************************************
|
|
|
|
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;
|
|
if (not fileref) then do;
|
|
call print(.err$nofile);
|
|
call terminate;
|
|
end;
|
|
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(.errFORMAT);
|
|
call print(.errFORM2);
|
|
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;
|
|
UDA.DCNT = sav$dcnt;
|
|
UDA.SEARCHL = sav$searchl;
|
|
UDA.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) = '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) = 'U' then /* U */
|
|
call update;
|
|
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 print(.error$msg);
|
|
call printx(.('Invalid Command Parameter, 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);
|
|
|
|
|
|
PLMSTART:
|
|
procedure public;
|
|
/* process request */
|
|
ver = get$version;
|
|
if low(ver) < Ver$BDOS or (high(ver) and Ver$Mask) <> Ver$OS then
|
|
call print(.(Ver$Needs$OS,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 GET$PD$UDA; /* 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 PLMSTART;
|
|
|
|
end set;
|
|
|
|
|