mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-27 02:14:19 +00:00
Upload
Digital Research
This commit is contained in:
@@ -0,0 +1,420 @@
|
||||
$title ('ERAQ: Erase File with Query')
|
||||
eraseq:
|
||||
do;
|
||||
|
||||
/*
|
||||
Revised:
|
||||
19 Jan 80 by Thomas Rolander
|
||||
20 July 81 by Doug Huskey
|
||||
6 Aug 81 by Danny Horovitz
|
||||
31 Jan 83 by Bill Fitler
|
||||
*/
|
||||
|
||||
$include (:f2:copyrt.lit)
|
||||
|
||||
$include (:f2:vaxcmd.lit)
|
||||
|
||||
$include (:f2:vermpm.lit)
|
||||
|
||||
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',
|
||||
bksp literally '8';
|
||||
|
||||
|
||||
/**************************************
|
||||
* *
|
||||
* 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;
|
||||
|
||||
|
||||
|
||||
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;
|
||||
|
||||
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;
|
||||
|
||||
|
||||
terminate:
|
||||
procedure;
|
||||
call mon1 (143,0);
|
||||
end terminate;
|
||||
|
||||
declare
|
||||
parse$fn structure (
|
||||
buff$adr address,
|
||||
fcb$adr address);
|
||||
declare (saveax,savecx) word external; /* reg return vals, set in mon1 */
|
||||
|
||||
parse: procedure;
|
||||
declare (retcode,errcode) word;
|
||||
|
||||
call mon1(152,.parse$fn);
|
||||
retcode = saveax;
|
||||
errcode = savecx;
|
||||
if retcode = 0ffffh then /* parse returned an error */
|
||||
do;
|
||||
call print$buf(.('Invalid Filespec$'));
|
||||
if errcode = 23 then call print$buf(.(' (drive)$'));
|
||||
else if errcode = 24 then call print$buf(.(' (filename)$'));
|
||||
else if errcode = 25 then call print$buf(.(' (filetype)$'));
|
||||
else if errcode = 38 then call print$buf(.(' (password)$'));
|
||||
call print$buf(.('.',13,10,'$')); call terminate;
|
||||
end;
|
||||
end parse;
|
||||
|
||||
|
||||
|
||||
/**************************************
|
||||
* *
|
||||
* GLOBAL VARIABLES *
|
||||
* *
|
||||
**************************************/
|
||||
|
||||
declare xfcb byte initial(0);
|
||||
declare successful lit '0FFh';
|
||||
|
||||
declare dir$entries (128) structure (
|
||||
file (12) byte );
|
||||
|
||||
declare dir$entry$adr address;
|
||||
declare dir$entry based dir$entry$adr (1) byte;
|
||||
|
||||
/**************************************
|
||||
* *
|
||||
* S U B R O U T I N E S *
|
||||
* *
|
||||
**************************************/
|
||||
|
||||
|
||||
/* 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 Error.$'));
|
||||
if code=2 then
|
||||
call print$buf(.(cr,lf,'Drive $'));
|
||||
if code = 3 or code = 2 then
|
||||
call print$buf(.('Read Only$'));
|
||||
if code = 4 then
|
||||
call print$buf(.(cr,lf,'Invalid Filespec (drive).$'));
|
||||
if code = 5 then
|
||||
call print$buf(.('Currently Opened$'));
|
||||
if code = 7 then
|
||||
call print$buf(.('Password Error$'));
|
||||
if code < 3 or code = 4 then
|
||||
call terminate;
|
||||
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 xfcb then
|
||||
fcbv(5) = fcbv(5) or 80h;
|
||||
call setdma(.fcb16); /* 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(.fcb16,' ',8);
|
||||
do i = 0 to 7;
|
||||
nxtchr:
|
||||
if (c:=ucase) >= ' ' then
|
||||
fcb16(i)=c;
|
||||
if c = cr then
|
||||
goto exit;
|
||||
if c = ctrlx then
|
||||
goto retry;
|
||||
if c = bksp then do;
|
||||
if i<1 then
|
||||
goto retry;
|
||||
else do;
|
||||
fcb16(i:=i-1)=' ';
|
||||
goto nxtchr;
|
||||
end;
|
||||
end;
|
||||
if c = 3 then
|
||||
call terminate;
|
||||
end;
|
||||
exit:
|
||||
c = check$con$stat;
|
||||
end getpasswd;
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
|
||||
/* error on deleting a file */
|
||||
file$err: procedure(code);
|
||||
declare code byte;
|
||||
|
||||
call crlf;
|
||||
call print$buf(.('Not erased, $'));
|
||||
call error(code);
|
||||
call crlf;
|
||||
end file$err;
|
||||
|
||||
|
||||
|
||||
/**************************************
|
||||
* *
|
||||
* M A I N P R O G R A M *
|
||||
* *
|
||||
**************************************/
|
||||
|
||||
|
||||
declare (i,j,k,code,response,user,dcnt) byte;
|
||||
declare ver address;
|
||||
|
||||
declare last$dseg$byte byte
|
||||
initial (0);
|
||||
|
||||
plm$start: procedure public;
|
||||
ver = version;
|
||||
if low(ver) < Ver$BDOS or (high(ver) and Ver$Mask) = 0 then do;
|
||||
call print$buf (.(cr,lf,Ver$Needs$OS,'$'));
|
||||
call mon1(0,0);
|
||||
end;
|
||||
|
||||
if fcb(17) <> ' ' then
|
||||
if fcb(17) = 'X' then
|
||||
xfcb = true;
|
||||
else do;
|
||||
call print$buf (.(
|
||||
'Invalid Command Option.$'));
|
||||
call terminate;
|
||||
end;
|
||||
|
||||
parse$fn.buff$adr = .tbuff(1);
|
||||
parse$fn.fcb$adr = .fcb;
|
||||
call parse;
|
||||
|
||||
if fcb(0) = 0 then
|
||||
fcb(0) = low (mon2 (25,0)) + 1;
|
||||
i = -1;
|
||||
user = get$user$code;
|
||||
call return$errors;
|
||||
dcnt = search$first (.fcb);
|
||||
do while dcnt <> 0ffh;
|
||||
dir$entry$adr = .tbuff(ror(dcnt,3) and 110$0000b);
|
||||
if dir$entry(0) = user then
|
||||
do;
|
||||
if (i:=i+1) = 128 then
|
||||
do;
|
||||
call print$buf (.(
|
||||
'Too many directory entries for query.','$'));
|
||||
call terminate;
|
||||
end;
|
||||
call move (12,.dir$entry(1),.dir$entries(i));
|
||||
end;
|
||||
dcnt = search$next;
|
||||
end;
|
||||
if i = -1 then
|
||||
do;
|
||||
call print$buf (.(
|
||||
'File Not Found.','$'));
|
||||
end;
|
||||
else
|
||||
do j = 0 to i;
|
||||
call printchar ('A'+fcb(0)-1);
|
||||
call printchar (':');
|
||||
call printchar (' ');
|
||||
do k = 0 to 10;
|
||||
if k = 8
|
||||
then call printchar ('.');
|
||||
call printchar (dir$entries(j).file(k) and 07FH);
|
||||
end;
|
||||
call printchar (' ');
|
||||
call printchar ('?');
|
||||
response = read$console;
|
||||
call printchar (0dh);
|
||||
call printchar (0ah);
|
||||
if (response = 'y') or
|
||||
(response = 'Y') then
|
||||
do;
|
||||
call move (12,.dir$entries(j),.fcb(1));
|
||||
if (code:=delete(.fcb)) <> successful then do;
|
||||
if code < 3 or code = 4 then
|
||||
call error(code); /* fatal errors */
|
||||
else if code = 7 then do;
|
||||
call file$err(code);
|
||||
call getpasswd;
|
||||
code = delete(.fcb);
|
||||
end;
|
||||
if code <> successful then
|
||||
call file$err(code);
|
||||
call crlf;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
call terminate;
|
||||
end plm$start;
|
||||
|
||||
end eraseq;
|
||||
|
||||
Reference in New Issue
Block a user