mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-24 17:04:19 +00:00
825 lines
21 KiB
Plaintext
825 lines
21 KiB
Plaintext
$ TITLE('CP/M 3.0 --- ERA ')
|
||
/* contains the confirm option */
|
||
|
||
era:
|
||
do;
|
||
|
||
/*
|
||
Copyright (C) 1982
|
||
Digital Research
|
||
P.O. Box 579
|
||
Pacific Grove, CA 93950
|
||
*/
|
||
|
||
/*
|
||
Revised:
|
||
19 Jan 80 by Thomas Rolander
|
||
14 Sept 81 by Doug Huskey
|
||
23 June 82 by John Knight
|
||
03 Dec 82 by Bruce Skidmore
|
||
*/
|
||
|
||
declare
|
||
true literally '1',
|
||
false literally '0',
|
||
forever literally 'while true',
|
||
lit literally 'literally',
|
||
proc literally 'procedure',
|
||
dcl literally 'declare',
|
||
addr literally 'address',
|
||
cr literally '13',
|
||
lf literally '10',
|
||
ctrlc literally '3',
|
||
ctrlx literally '18h',
|
||
tab literally '9',
|
||
bksp literally '8',
|
||
cpmversion literally '30h',
|
||
dcnt$offset literally '45h',
|
||
searcha$offset literally '47h',
|
||
searchl$offset literally '49h',
|
||
hash1$offset literally '00h',
|
||
hash2$offset literally '02h',
|
||
hash3$offset literally '04h';
|
||
|
||
declare plm label public;
|
||
|
||
/**************************************
|
||
* *
|
||
* B D O S INTERFACE *
|
||
* *
|
||
**************************************/
|
||
|
||
|
||
mon1:
|
||
procedure (func,info) external;
|
||
declare func byte;
|
||
declare info address;
|
||
end mon1;
|
||
|
||
mon2:
|
||
procedure (func,info) byte external;
|
||
declare func byte;
|
||
declare info address;
|
||
end mon2;
|
||
|
||
mon3:
|
||
procedure (func,info) address external;
|
||
declare func byte;
|
||
declare info address;
|
||
end mon3;
|
||
|
||
parse:
|
||
procedure (pfcb) address external;
|
||
declare pfcb address;
|
||
end parse;
|
||
|
||
declare cmdrv byte external; /* command drive */
|
||
declare fcb (1) byte external; /* 1st default fcb */
|
||
declare fcb16 (1) byte external; /* 2nd default fcb */
|
||
declare pass0 address external; /* 1st password ptr */
|
||
declare len0 byte external; /* 1st passwd length */
|
||
declare pass1 address external; /* 2nd password ptr */
|
||
declare len1 byte external; /* 2nd passwd length */
|
||
declare tbuff (1) byte external; /* default dma buffer */
|
||
|
||
|
||
/**************************************
|
||
* *
|
||
* B D O S Externals *
|
||
* *
|
||
**************************************/
|
||
|
||
read$console:
|
||
procedure byte;
|
||
return mon2 (1,0);
|
||
end read$console;
|
||
|
||
|
||
printchar:
|
||
procedure(char);
|
||
declare char byte;
|
||
call mon1(2,char);
|
||
end printchar;
|
||
|
||
conin:
|
||
procedure byte;
|
||
return mon2(6,0fdh);
|
||
end conin;
|
||
|
||
print$buf:
|
||
procedure (buffer$address);
|
||
declare buffer$address address;
|
||
call mon1 (9,buffer$address);
|
||
end print$buf;
|
||
|
||
|
||
read$console$buf:
|
||
procedure (buffer$address,max) byte;
|
||
declare buffer$address address;
|
||
declare new$max based buffer$address address;
|
||
declare max byte;
|
||
new$max = max;
|
||
call mon1(10,buffer$address);
|
||
buffer$address = buffer$address + 1;
|
||
return new$max; /* actually number of chars input */
|
||
end read$console$buf;
|
||
|
||
check$con$stat:
|
||
procedure byte;
|
||
return mon2 (11,0);
|
||
end check$con$stat;
|
||
|
||
version: procedure address;
|
||
/* returns current cp/m version # */
|
||
return mon3(12,0);
|
||
end version;
|
||
|
||
setdma: procedure(dma);
|
||
declare dma address;
|
||
call mon1(26,dma);
|
||
end setdma;
|
||
|
||
search$first:
|
||
procedure (fcb$address) byte;
|
||
declare fcb$address address;
|
||
return mon2 (17,fcb$address);
|
||
end search$first;
|
||
|
||
search$next:
|
||
procedure byte;
|
||
return mon2 (18,0);
|
||
end search$next;
|
||
|
||
delete$file:
|
||
procedure (fcb$address) address;
|
||
declare fcb$address address;
|
||
return mon3 (19,fcb$address);
|
||
end delete$file;
|
||
|
||
get$user$code:
|
||
procedure byte;
|
||
return mon2 (32,0ffh);
|
||
end get$user$code;
|
||
|
||
/* 0ff => return BDOS errors */
|
||
return$errors:
|
||
procedure;
|
||
call mon1 (45,0ffh);
|
||
end return$errors;
|
||
|
||
declare scbpd structure
|
||
(offset byte,
|
||
set byte,
|
||
value address);
|
||
|
||
getscbword:
|
||
procedure (offset) address;
|
||
declare offset byte;
|
||
scbpd.offset = offset;
|
||
scbpd.set = 0;
|
||
return mon3(49,.scbpd);
|
||
end getscbword;
|
||
|
||
setscbword:
|
||
procedure (offset,value);
|
||
declare offset byte;
|
||
declare value address;
|
||
scbpd.offset = offset;
|
||
scbpd.set = 0FEh;
|
||
scbpd.value = value;
|
||
call mon1(49,.scbpd);
|
||
end setscbword;
|
||
|
||
set$console$mode: procedure;
|
||
/* set console mode to ctrl-c only */
|
||
call mon1(109,1);
|
||
end set$console$mode;
|
||
|
||
declare
|
||
parse$fn structure (
|
||
buff$adr address,
|
||
fcb$adr address);
|
||
|
||
|
||
/**************************************
|
||
* *
|
||
* GLOBAL VARIABLES *
|
||
* *
|
||
**************************************/
|
||
|
||
declare successful lit '0FFh';
|
||
|
||
declare dir$entry$adr address;
|
||
declare dir$entry based dir$entry$adr (1) byte;
|
||
declare confirm$opt byte initial (false);
|
||
declare passwd$opt byte initial (false);
|
||
declare save$passwd (8) byte;
|
||
declare (savdcnt,savsearcha,savsearchl) address;
|
||
declare (hash1,hash2,hash3) address;
|
||
|
||
/* options scanner variables and data */
|
||
declare
|
||
options(*) byte
|
||
data('PASSWORD0CONFIRM',0ffh),
|
||
|
||
off$opt(*) byte data(0,9,16),
|
||
|
||
end$list byte data (0ffh),
|
||
|
||
delimiters(*) byte data (0,'[]=, ',0,0ffh),
|
||
|
||
SPACE byte data(5),
|
||
|
||
j byte initial(0),
|
||
buf$ptr address,
|
||
index byte,
|
||
endbuf byte,
|
||
delimiter byte;
|
||
|
||
declare end$of$string byte initial('0');
|
||
|
||
|
||
/**************************************
|
||
* *
|
||
* S U B R O U T I N E S *
|
||
* *
|
||
**************************************/
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* * * * Option scanner * * * */
|
||
|
||
|
||
separator: procedure(character) byte;
|
||
|
||
/* determines if character is a
|
||
delimiter and which one */
|
||
declare k byte,
|
||
character byte;
|
||
|
||
k = 1;
|
||
loop: if delimiters(k) = end$list then return(0);
|
||
if delimiters(k) = character then return(k); /* null = 25 */
|
||
k = k + 1;
|
||
go to loop;
|
||
|
||
end separator;
|
||
|
||
opt$scanner: procedure(list$ptr,off$ptr,idx$ptr);
|
||
/* scans the list pointed at by idxptr
|
||
for any strings that are in the
|
||
list pointed at by list$ptr.
|
||
Offptr points at an array that
|
||
contains the indices for the known
|
||
list. Idxptr points at the index
|
||
into the list. If the input string
|
||
is unrecognizable then the index is
|
||
0, otherwise > 0.
|
||
|
||
First, find the string in the known
|
||
list that starts with the same first
|
||
character. Compare up until the next
|
||
delimiter on the input. if every input
|
||
character matches then check for
|
||
uniqueness. Otherwise try to find
|
||
another known string that has its first
|
||
character match, and repeat. If none
|
||
can be found then return invalid.
|
||
|
||
To test for uniqueness, start at the
|
||
next string in the knwon list and try
|
||
to get another match with the input.
|
||
If there is a match then return invalid.
|
||
|
||
else move pointer past delimiter and
|
||
return.
|
||
|
||
P.Balma */
|
||
|
||
declare
|
||
buff based buf$ptr (1) byte,
|
||
idx$ptr address,
|
||
off$ptr address,
|
||
list$ptr address;
|
||
|
||
declare
|
||
i byte,
|
||
j byte,
|
||
list based list$ptr (1) byte,
|
||
offsets based off$ptr (1) byte,
|
||
wrd$pos byte,
|
||
character byte,
|
||
letter$in$word byte,
|
||
found$first byte,
|
||
start byte,
|
||
index based idx$ptr byte,
|
||
save$index byte,
|
||
(len$new,len$found) byte,
|
||
valid byte;
|
||
|
||
/*****************************************************************************/
|
||
/* internal subroutines */
|
||
/*****************************************************************************/
|
||
|
||
check$in$list: procedure;
|
||
/* find known string that has a match with
|
||
input on the first character. Set index
|
||
= invalid if none found. */
|
||
|
||
declare i byte;
|
||
|
||
i = start;
|
||
wrd$pos = offsets(i);
|
||
do while list(wrd$pos) <> end$list;
|
||
i = i + 1;
|
||
index = i;
|
||
if list(wrd$pos) = character then return;
|
||
wrd$pos = offsets(i);
|
||
end;
|
||
/* could not find character */
|
||
index = 0;
|
||
return;
|
||
end check$in$list;
|
||
|
||
setup: procedure;
|
||
character = buff(0);
|
||
call check$in$list;
|
||
letter$in$word = wrd$pos;
|
||
/* even though no match may have occurred, position
|
||
to next input character. */
|
||
i = 1;
|
||
character = buff(1);
|
||
end setup;
|
||
|
||
test$letter: procedure;
|
||
/* test each letter in input and known string */
|
||
|
||
letter$in$word = letter$in$word + 1;
|
||
|
||
/* too many chars input? 0 means
|
||
past end of known string */
|
||
if list(letter$in$word) = end$of$string then valid = false;
|
||
else
|
||
if list(letter$in$word) <> character then valid = false;
|
||
|
||
i = i + 1;
|
||
character = buff(i);
|
||
|
||
end test$letter;
|
||
|
||
skip: procedure;
|
||
/* scan past the offending string;
|
||
position buf$ptr to next string...
|
||
skip entire offending string;
|
||
ie., falseopt=mod, [note: comma or
|
||
space is considered to be group
|
||
delimiter] */
|
||
character = buff(i);
|
||
delimiter = separator(character);
|
||
/* No skip for ERA */
|
||
do while ((delimiter < 1) or (delimiter > 6));
|
||
i = i + 1;
|
||
character = buff(i);
|
||
delimiter = separator(character);
|
||
end;
|
||
endbuf = i;
|
||
buf$ptr = buf$ptr + endbuf + 1;
|
||
return;
|
||
end skip;
|
||
|
||
eat$blanks: procedure;
|
||
|
||
declare charac based buf$ptr byte;
|
||
|
||
|
||
do while ((delimiter := separator(charac)) = SPACE);
|
||
buf$ptr = buf$ptr + 1;
|
||
end;
|
||
|
||
end eat$blanks;
|
||
|
||
/*****************************************************************************/
|
||
/* end of internals */
|
||
/*****************************************************************************/
|
||
|
||
|
||
/* start of procedure */
|
||
call eat$blanks;
|
||
start = 0;
|
||
call setup;
|
||
|
||
/* match each character with the option
|
||
for as many chars as input
|
||
Please note that due to the array
|
||
indices being relative to 0 and the
|
||
use of index both as a validity flag
|
||
and as a index into the option/mods
|
||
list, index is forced to be +1 as an
|
||
index into array and 0 as a flag*/
|
||
|
||
do while index <> 0;
|
||
start = index;
|
||
delimiter = separator(character);
|
||
|
||
/* check up to input delimiter */
|
||
|
||
valid = true; /* test$letter resets this */
|
||
do while delimiter = 0;
|
||
call test$letter;
|
||
if not valid then go to exit1;
|
||
delimiter = separator(character);
|
||
end;
|
||
|
||
go to good;
|
||
|
||
/* input ~= this known string;
|
||
get next known string that
|
||
matches */
|
||
exit1: call setup;
|
||
end;
|
||
/* fell through from above, did
|
||
not find a good match*/
|
||
endbuf = i; /* skip over string & return*/
|
||
call skip;
|
||
return;
|
||
|
||
/* is it a unique match in options
|
||
list? */
|
||
good: endbuf = i;
|
||
len$found = endbuf;
|
||
save$index = index;
|
||
valid = false;
|
||
next$opt:
|
||
start = index;
|
||
call setup;
|
||
if index = 0 then go to finished;
|
||
|
||
/* look at other options and check
|
||
uniqueness */
|
||
|
||
len$new = offsets(index + 1) - offsets(index) - 1;
|
||
if len$new = len$found then do;
|
||
valid = true;
|
||
do j = 1 to len$found;
|
||
call test$letter;
|
||
if not valid then go to next$opt;
|
||
end;
|
||
end;
|
||
else go to nextopt;
|
||
/* fell through...found another valid
|
||
match --> ambiguous reference */
|
||
index = 0;
|
||
call skip; /* skip input field to next delimiter*/
|
||
return;
|
||
|
||
finished: /* unambiguous reference */
|
||
index = save$index;
|
||
buf$ptr = buf$ptr + endbuf;
|
||
call eat$blanks;
|
||
if delimiter <> 0 then
|
||
buf$ptr = buf$ptr + 1;
|
||
else
|
||
delimiter = 5;
|
||
return;
|
||
|
||
end opt$scanner;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
break: procedure;
|
||
if check$con$stat then do;
|
||
call print$buf(.(cr,lf,'*** Aborted by ^C ***$'));
|
||
call mon1(0,0);
|
||
end;
|
||
end break;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* upper case character from console */
|
||
crlf: proc;
|
||
call printchar(cr);
|
||
call printchar(lf);
|
||
end crlf;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* 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;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* error message routine */
|
||
error: proc(code);
|
||
declare
|
||
code byte;
|
||
|
||
call printchar(' ');
|
||
if code=1 then
|
||
call print$buf(.(cr,lf,'Disk I/O $'));
|
||
if code=2 then
|
||
call print$buf(.(cr,lf,'Drive $'));
|
||
if code = 3 or code = 2 then
|
||
call print$buf(.('Read Only$'));
|
||
if code = 5 then
|
||
call print$buf(.('Currently Opened$'));
|
||
if code = 7 then
|
||
call print$buf(.('Password Error$'));
|
||
if code < 3 then
|
||
call mon1(0,0);
|
||
end error;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* try to delete fcb at fcb$address
|
||
return error code if unsuccessful */
|
||
delete:
|
||
procedure(fcb$address) byte;
|
||
declare
|
||
fcb$address address,
|
||
fcbv based fcb$address (32) byte,
|
||
error$code address,
|
||
code byte;
|
||
|
||
if passwd$opt then
|
||
fcbv(5) = fcbv(5) or 80h;
|
||
call setdma(.save$passwd(0)); /* password */
|
||
fcbv(0) = fcb(0); /* drive */
|
||
error$code = delete$file(fcb$address);
|
||
fcbv(5) = fcbv(5) and 7fh; /* reset xfcb bit */
|
||
if low(error$code) = 0FFh then do;
|
||
code = high(error$code);
|
||
if (code=1) or (code=2) then
|
||
call error(code);
|
||
return code;
|
||
end;
|
||
return successful;
|
||
end delete;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* 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 at fcb + 16 */
|
||
getpasswd: proc;
|
||
dcl (i,c) byte;
|
||
|
||
call print$buf(.('Password: ','$'));
|
||
retry:
|
||
call fill(.save$passwd(0),' ',8);
|
||
do i = 0 to 7;
|
||
nxtchr:
|
||
if (c:=ucase) >= ' ' then
|
||
save$passwd(i)=c;
|
||
if c = cr then
|
||
go to exit;
|
||
if c = ctrlx then
|
||
goto retry;
|
||
if c = bksp then do;
|
||
if i<1 then
|
||
goto retry;
|
||
else do;
|
||
save$passwd(i:=i-1)=' ';
|
||
goto nxtchr;
|
||
end;
|
||
end;
|
||
if c = 3 then
|
||
call mon1(0,0);
|
||
end;
|
||
exit:
|
||
c = check$con$stat; /* clear raw I/O mode */
|
||
end getpasswd;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* error on deleting a file */
|
||
file$err: procedure(code);
|
||
declare code byte;
|
||
|
||
if not confirm$opt then do; /* print file */
|
||
call printchar('A'+fcb(0)-1);
|
||
call printchar(':');
|
||
call printchar(' ');
|
||
do k=1 to 11;
|
||
if k=9 then
|
||
call printchar('.');
|
||
call printchar(dir$entry(k));
|
||
end;
|
||
call print$buf(.(' $'));
|
||
end;
|
||
call print$buf(.('Not erased, $'));
|
||
call error(code);
|
||
call crlf;
|
||
end file$err;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
erase: procedure;
|
||
if (code:=delete(.fcb)) <> successful then do;
|
||
if code < 3 then
|
||
call error(code);
|
||
else if code = 7 then do;
|
||
call file$err(code);
|
||
call getpasswd;
|
||
call crlf;
|
||
code = delete(.fcb);
|
||
end;
|
||
if code <> successful then
|
||
call file$err(code);
|
||
end;
|
||
end erase;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
parse$options: procedure;
|
||
declare
|
||
t address,
|
||
char based t byte,
|
||
i byte;
|
||
|
||
delimiter = 1;
|
||
index = 0;
|
||
do while ((delimiter <> 0) and (delimiter <> 2) and (delimiter <> 6));
|
||
call opt$scanner(.options(0),.off$opt(0),.index);
|
||
if index = 0 then do;
|
||
/* unrecognized option */
|
||
call print$buf(.(cr,lf,'ERROR: Missing Delimiter or$'));
|
||
call print$buf(.(cr,lf,' Unrecognized Option $'));
|
||
call print$buf(.('Near: $'));
|
||
t = buf$ptr - endbuf - 1;
|
||
do i = 1 to endbuf;
|
||
call printchar(char);
|
||
t = t + 1;
|
||
end;
|
||
call mon1(0,0);
|
||
end;
|
||
if index = 1 then
|
||
passwd$opt = true;
|
||
if index = 2 then
|
||
confirm$opt = true;
|
||
end;
|
||
end parse$options;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
input$found: procedure (buffer$adr) byte;
|
||
declare buffer$adr address;
|
||
declare char based buffer$adr byte;
|
||
do while (char = ' ') or (char = tab);
|
||
buffer$adr = buffer$adr + 1;
|
||
end;
|
||
if char = 0 then /* eoln */
|
||
return false; /* input not found */
|
||
else
|
||
return true; /* input found */
|
||
end input$found;
|
||
|
||
/**************************************
|
||
* *
|
||
* M A I N P R O G R A M *
|
||
* *
|
||
**************************************/
|
||
|
||
declare (i,k,code,response,user,dcnt) byte;
|
||
declare status address;
|
||
declare char$count byte;
|
||
declare last$dseg$byte byte
|
||
initial (0);
|
||
declare no$chars byte;
|
||
declare m based status byte;
|
||
|
||
plm:
|
||
do;
|
||
if (low(version) < cpmversion) or (high(version) = 1) then do;
|
||
call print$buf(.('Requires CP/M 3.0 $'));
|
||
call mon1(0,0);
|
||
end;
|
||
call set$console$mode;
|
||
if not input$found(.tbuff(1)) then do;
|
||
/* prompt for file */
|
||
confirm$opt = true; /* confirm, unless otherwise specified */
|
||
call print$buf(.('Enter filename: $'));
|
||
no$chars = read$console$buf(.tbuff(0),40);
|
||
char$count = no$chars + 2;
|
||
call print$buf(.(cr,lf,'$'));
|
||
tbuff(1) = ' '; /* blank out nc field */
|
||
tbuff(char$count) = 00h; /* eoln marker set */
|
||
/* convert input string to upper case */
|
||
do i = 1 to char$count;
|
||
if tbuff(i+1) >= 'a' then
|
||
if tbuff(i+1) < '}' then
|
||
tbuff(i+1) = tbuff(i+1) - 20h;
|
||
end;
|
||
end;
|
||
parse$fn.buff$adr = .tbuff(1);
|
||
parse$fn.fcb$adr = .fcb;
|
||
status = parse(.parse$fn);
|
||
if status = 0FFFFh then do;
|
||
call print$buf(.('ERROR: Invalid file name $'));
|
||
call mon1(0,0);
|
||
end;
|
||
if status <> 0 then do; /* options must follow */
|
||
do while m = ' ';
|
||
status = status + 1; /* skip over blank delimiters */
|
||
end;
|
||
buf$ptr = status + 1; /* skip first delimiter */
|
||
call parse$options;
|
||
end;
|
||
if fcb(0) = 0 then
|
||
fcb(0) = low (mon2 (25,0)) + 1;
|
||
user = get$user$code;
|
||
call return$errors;
|
||
call move(8,.fcb16,.save$passwd(0));
|
||
if not confirm$opt then do;
|
||
i = 0;
|
||
do while fcb(i:=i+1) = '?';
|
||
end;
|
||
if i > 11 then
|
||
if not passwd$opt then do;
|
||
call print$buf(.('Confirm delete all user files (Y/N)?$'));
|
||
response = read$console;
|
||
if not ((response = 'y') or (response = 'Y')) then
|
||
call mon1(0,0);
|
||
call crlf;
|
||
end;
|
||
end;
|
||
call move(16,.fcb,.fcb16);
|
||
call setdma(.tbuff);
|
||
dcnt = search$first (.fcb16);
|
||
if dcnt = 0FFh then do;
|
||
call print$buf(.('No File $'));
|
||
call mon1(0,0);
|
||
end;
|
||
do while dcnt <> 0ffh;
|
||
dir$entry$adr = .tbuff(ror(dcnt,3) and 110$0000b);
|
||
savdcnt = getscbword(dcnt$offset);
|
||
savsearcha = getscbword(searcha$offset);
|
||
savsearchl = getscbword(searchl$offset);
|
||
/* save searched fcb's hash code (5 bytes) */
|
||
hash1 = getscbword(hash1$offset);
|
||
hash2 = getscbword(hash2$offset);
|
||
hash3 = getscbword(hash3$offset);
|
||
if confirm$opt then do;
|
||
if dir$entry(0) = user then do;
|
||
call printchar ('A'+fcb(0)-1);
|
||
call printchar (':');
|
||
call printchar (' ');
|
||
do k = 1 to 11;
|
||
if k = 9
|
||
then call printchar ('.');
|
||
call printchar (dir$entry(k));
|
||
end;
|
||
call print$buf(.(' (Y/N)? $'));
|
||
response = read$console;
|
||
call printchar (cr);
|
||
call printchar (lf);
|
||
if response = ctrlc then do;
|
||
call print$buf(.(cr,lf,'*** Aborted by ^C ***$'));
|
||
call mon1(0,0);
|
||
end;
|
||
if (response = 'y') or
|
||
(response = 'Y') then do;
|
||
call move (12,.dir$entry(1),.fcb(1));
|
||
call erase;
|
||
end;
|
||
end;
|
||
end;
|
||
else do; /* not confirm option */
|
||
call move(12,.dir$entry(1),.fcb(1));
|
||
call break;
|
||
call erase;
|
||
end;
|
||
call setdma(.tbuff);
|
||
call setscbword(dcnt$offset,savdcnt);
|
||
call setscbword(searcha$offset,savsearcha);
|
||
call setscbword(searchl$offset,savsearchl);
|
||
/* restore hash code */
|
||
call setscbword(hash1$offset,hash1);
|
||
call setscbword(hash2$offset,hash2);
|
||
call setscbword(hash3$offset,hash3);
|
||
if .fcb16 <> savsearcha then /* restore search fcb if destroyed */
|
||
call move(16,.fcb16,savsearcha);
|
||
dcnt = search$next;
|
||
end;
|
||
call mon1(0,0);
|
||
end;
|
||
end era;
|
||
|