mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-25 17:34:06 +00:00
609 lines
16 KiB
Plaintext
609 lines
16 KiB
Plaintext
$ TITLE('CP/M 3.0 --- REN ')
|
||
ren:
|
||
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
|
||
29 Sept 82 by Thomas J. Mason
|
||
03 Dec 82 by Bruce Skidmore
|
||
*/
|
||
|
||
declare
|
||
mpmproduct literally '01h', /* requires mp/m */
|
||
cpmversion literally '30h'; /* requires 3.0 cp/m */
|
||
|
||
|
||
declare
|
||
true literally '0FFh',
|
||
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',
|
||
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;
|
||
|
||
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;
|
||
|
||
conin:
|
||
procedure byte;
|
||
return mon2(6,0ffh);
|
||
end conin;
|
||
|
||
printchar:
|
||
procedure (char);
|
||
declare char byte;
|
||
call mon1 (2,char);
|
||
end printchar;
|
||
|
||
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 byte;
|
||
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;
|
||
|
||
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);
|
||
declare fcb$address address;
|
||
call mon1 (19,fcb$address);
|
||
end delete$file;
|
||
|
||
rename$file:
|
||
procedure (fcb$address) address;
|
||
declare fcb$address address;
|
||
return mon3 (23,fcb$address);
|
||
end rename$file;
|
||
|
||
setdma: procedure(dma);
|
||
declare dma address;
|
||
call mon1(26,dma);
|
||
end setdma;
|
||
|
||
/* 0ff => return BDOS errors */
|
||
return$errors:
|
||
procedure(mode);
|
||
declare mode byte;
|
||
call mon1 (45,mode);
|
||
end return$errors;
|
||
|
||
declare
|
||
parse$fn structure (
|
||
buff$adr address,
|
||
fcb$adr address);
|
||
|
||
parse: procedure (pfcb) address external;
|
||
declare pfcb address;
|
||
end parse;
|
||
|
||
declare scbpd structure
|
||
(offset byte,
|
||
set byte,
|
||
value address);
|
||
|
||
getscbbyte:
|
||
procedure (offset) byte;
|
||
declare offset byte;
|
||
scbpd.offset = offset;
|
||
scbpd.set = 0;
|
||
return mon2(49,.scbpd);
|
||
end getscbbyte;
|
||
|
||
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;
|
||
|
||
|
||
/**************************************
|
||
* *
|
||
* GLOBAL VARIABLES *
|
||
* *
|
||
**************************************/
|
||
|
||
/* Note: there are three fcbs used by
|
||
this program:
|
||
|
||
1) new$fcb: the new file name
|
||
(this can be a wildcard if it
|
||
has the same pattern of question
|
||
marks as the old file name)
|
||
Any question marks are replaced
|
||
with the corresponding filename
|
||
character in the old$fcb before
|
||
doing the rename function.
|
||
|
||
2) cur$fcb: the file to be renamed
|
||
specified in the rename command.
|
||
(any question marks must correspond
|
||
to question marks in new$fcb).
|
||
|
||
3) old$fcb: a fcb in the directory
|
||
matching the cur$fcb and used in
|
||
the bdos rename function. This
|
||
cannot contain any question marks.
|
||
*/
|
||
|
||
declare successful lit '0FFh';
|
||
declare failed (*) byte data(cr,lf,'ERROR: Not renamed, $'),
|
||
read$only (*) byte data(cr,lf,'ERROR: Drive read only.$'),
|
||
bad$wildcard (*) byte data('Invalid wildcard.$');
|
||
declare passwd (8) byte;
|
||
declare
|
||
new$fcb$adr address, /* new name */
|
||
new$fcb based new$fcb$adr (32) byte;
|
||
declare cur$fcb (33) byte; /* current fcb (old name) */
|
||
|
||
/**************************************
|
||
* *
|
||
* 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;
|
||
|
||
if code = 0 then do;
|
||
call print$buf(.('ERROR: No such file to rename.$'));
|
||
call mon1(0,0);
|
||
end;
|
||
if code=1 then do;
|
||
call print$buf(.(cr,lf,'Disk I/O.$'));
|
||
call mon1(0,0);
|
||
end;
|
||
if code=2 then do;
|
||
call print$buf(.read$only);
|
||
call mon1(0,0);
|
||
end;
|
||
if code = 3 then
|
||
call print$buf(.read$only(15));
|
||
if code = 5 then
|
||
call print$buf(.('Currently Opened.$'));
|
||
if code = 7 then
|
||
call print$buf(.('Bad password.$'));
|
||
if code = 8 then
|
||
call print$buf(.('file already exists$'));
|
||
if code = 9 then do;
|
||
call print$buf(.bad$wildcard);
|
||
call mon1(0,0);
|
||
end;
|
||
end error;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* print file name */
|
||
print$file: procedure(fcbp);
|
||
declare k byte;
|
||
declare typ lit '9'; /* file type */
|
||
declare fnam lit '11'; /* file type */
|
||
declare
|
||
fcbp addr,
|
||
fcbv based fcbp (32) byte;
|
||
|
||
do k = 1 to fnam;
|
||
if k = typ then
|
||
call printchar('.');
|
||
call printchar(fcbv(k) and 7fh);
|
||
end;
|
||
end print$file;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* try to rename fcb at old$fcb$adr to name at new$fcb$adr
|
||
return error code if unsuccessful */
|
||
rename:
|
||
procedure(old$fcb$adr) byte;
|
||
declare
|
||
old$fcb$adr address,
|
||
old$fcb based old$fcb$adr (32) byte,
|
||
error$code address,
|
||
code byte;
|
||
|
||
call move (16,new$fcb$adr,old$fcb$adr+16);
|
||
call setdma(.passwd); /* password */
|
||
call return$errors(0FFh); /* return bdos errors */
|
||
error$code = rename$file (old$fcb$adr);
|
||
call return$errors(0); /* normal error mode */
|
||
if low(error$code) = 0FFh then do;
|
||
code = high(error$code);
|
||
if code < 3 then
|
||
call error(code);
|
||
return code;
|
||
end;
|
||
return successful;
|
||
end rename;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* upper case character from console */
|
||
ucase: proc(c) byte;
|
||
dcl c byte;
|
||
|
||
if c >= '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 crlf;
|
||
call print$buf(.('Enter password: ','$'));
|
||
retry:
|
||
call fill(.passwd,' ',8);
|
||
do i = 0 to 7;
|
||
nxtchr:
|
||
if (c:=ucase(conin)) >= ' ' then
|
||
passwd(i)=c;
|
||
if c = cr then do;
|
||
call crlf;
|
||
go to exit;
|
||
end;
|
||
if c = ctrlx then
|
||
goto retry;
|
||
if c = bksp then do;
|
||
if i<1 then
|
||
goto retry;
|
||
else do;
|
||
passwd(i:=i-1)=' ';
|
||
goto nxtchr;
|
||
end;
|
||
end;
|
||
if c = ctrlc then
|
||
call mon1(0,0);
|
||
end;
|
||
exit:
|
||
c = check$con$stat; /* clear raw I/O mode */
|
||
end getpasswd;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* check for wildcard in rename command */
|
||
wildcard: proc byte;
|
||
dcl (i,wild) byte;
|
||
|
||
wild = false;
|
||
do i=1 to 11;
|
||
if cur$fcb(i) = '?' then
|
||
if new$fcb(i) <> '?' then do;
|
||
call print$buf(.failed);
|
||
call print$buf(.bad$wildcard);
|
||
call mon1(0,0);
|
||
end;
|
||
else
|
||
wild = true;
|
||
end;
|
||
return wild;
|
||
end wildcard;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* set up new name for rename function */
|
||
set$new$fcb: proc(old$fcb$adr);
|
||
dcl old$fcb$adr address,
|
||
old$fcb based old$fcb$adr (32) byte;
|
||
dcl i byte;
|
||
|
||
old$fcb(0) = cur$fcb(0); /* set up drive */
|
||
do i=1 to 11;
|
||
if cur$fcb(i) = '?' then
|
||
new$fcb(i) = old$fcb(i);
|
||
end;
|
||
end set$new$fcb;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* try deleting files one at a time */
|
||
single$file:
|
||
procedure;
|
||
declare (code,dcnt) byte;
|
||
declare (old$fcb$adr,savdcnt,savsearcha,savsearchl) addr;
|
||
declare old$fcb based old$fcb$adr (32) byte;
|
||
declare (hash1,hash2,hash3) address;
|
||
|
||
file$err: procedure(fcba);
|
||
dcl fcba address;
|
||
call print$buf(.failed);
|
||
call print$file(fcba);
|
||
call printchar(' ');
|
||
call error(code);
|
||
end file$err;
|
||
|
||
call setdma(.tbuff);
|
||
if (dcnt:=search$first(.cur$fcb)) = 0ffh then
|
||
call error(0);
|
||
|
||
do while dcnt <> 0ffh;
|
||
old$fcb$adr = shl(dcnt,5) + .tbuff;
|
||
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); /* saved one extra byte */
|
||
call set$new$fcb(old$fcb$adr);
|
||
if (code:=rename(old$fcb$adr)) = 8 then do;
|
||
call file$err(new$fcb$adr);
|
||
call print$buf(.(', delete (Y/N)?$'));
|
||
if ucase(read$console) = 'Y' then do;
|
||
call delete$file(new$fcb$adr);
|
||
code = rename(old$fcb$adr);
|
||
end;
|
||
else
|
||
go to next;
|
||
end;
|
||
if code = 7 then do;
|
||
call file$err(old$fcb$adr);
|
||
call getpasswd;
|
||
code = rename(old$fcb$adr);
|
||
end;
|
||
if code <> successful then
|
||
call file$err(old$fcb$adr);
|
||
else do;
|
||
call crlf;
|
||
call print$file(new$fcb$adr);
|
||
call printchar('=');
|
||
call print$file(old$fcb$adr);
|
||
end;
|
||
next:
|
||
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 .cur$fcb <> savsearcha then /*restore orig fcb if destroyed*/
|
||
call move(16,.cur$fcb,savsearcha);
|
||
dcnt = search$next;
|
||
end;
|
||
end single$file;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
/* invalid rename command */
|
||
bad$entry: proc;
|
||
|
||
call print$buf(.failed);
|
||
call print$buf(.('ERROR: Invalid File.',cr,lf,'$'));
|
||
call mon1(0,0);
|
||
end bad$entry;
|
||
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
finish$parse: procedure;
|
||
parse$fn.buff$adr = parse$fn.fcb$adr+1; /* skip delimiter */
|
||
parse$fn.fcb$adr = .cur$fcb;
|
||
parse$fn.fcb$adr = parse(.parse$fn);
|
||
call move(8,.cur$fcb+16,.passwd);
|
||
end finish$parse;
|
||
|
||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||
|
||
input$found: procedure (buffer$adr) byte;
|
||
declare buffer$adr address;
|
||
declare char based buffer$adr byte;
|
||
do while (char = ' ') or (char = 9); /* tabs & spaces */
|
||
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 ver address;
|
||
declare i byte;
|
||
declare no$chars byte; /* number characters input */
|
||
declare second$string$ptr address; /* points to second filename input */
|
||
declare ptr based second$string$ptr byte;
|
||
declare last$dseg$byte byte
|
||
initial (0);
|
||
|
||
plm:
|
||
ver = version;
|
||
if (low(ver) < cpmversion) or (high(ver) = mpmproduct) then do;
|
||
call print$buf(.('Requires CP/M 3.0','$'));
|
||
call mon1(0,0);
|
||
end;
|
||
|
||
parse$fn.buff$adr = .tbuff(1);
|
||
new$fcb$adr, parse$fn.fcb$adr = .fcb;
|
||
if input$found(.tbuff(1)) then do;
|
||
if (parse$fn.fcb$adr:=parse(.parse$fn)) <> 0FFFFh then
|
||
call finish$parse;
|
||
end;
|
||
else do;
|
||
|
||
/* prompt for files */
|
||
call print$buf(.('Enter New Name: $'));
|
||
no$chars = read$console$buf(.tbuff(0),40);
|
||
if no$chars <= 0 then do;
|
||
call print$buf(.(cr,lf,'ERROR: Incorrect file specification.',cr,lf,'$'));
|
||
call mon1(0,0);
|
||
end; /* no$char check */
|
||
|
||
tbuff(1)= ' '; /* blank out nc field for file 1 */
|
||
second$string$ptr = .tbuff(no$chars + 2);
|
||
call crlf;
|
||
|
||
call print$buf(.('Enter Old Name: $'));
|
||
no$chars = read$console$buf(second$string$ptr,40);
|
||
call crlf;
|
||
ptr = ' '; /* blank out mx field */
|
||
second$string$ptr = second$string$ptr + 1;
|
||
ptr = '='; /* insert delimiter for parse */
|
||
second$string$ptr = second$string$ptr + no$chars + 1; /* eoln */
|
||
ptr = cr; /* put eoln delimeter in string */
|
||
parse$fn.buff$adr = .tbuff(1);
|
||
new$fcb$adr, parse$fn.fcb$adr = .fcb;
|
||
if (parse$fn.fcb$adr := parse(.parse$fn)) <> 0FFFFh then
|
||
call finish$parse;
|
||
end;
|
||
if parse$fn.fcb$adr = 0FFFFh then
|
||
call bad$entry;
|
||
if fcb(0) <> 0 then
|
||
if cur$fcb(0) <> 0 then do;
|
||
if fcb(0) <> cur$fcb(0) then
|
||
call bad$entry;
|
||
end;
|
||
else
|
||
cur$fcb(0) = new$fcb(0); /* set drive */
|
||
if wildcard then
|
||
call singlefile;
|
||
else if rename(.cur$fcb) <> successful then
|
||
call singlefile;
|
||
call mon1(0,0);
|
||
end ren;
|
||
|