mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-25 17:34:06 +00:00
1221 lines
41 KiB
Plaintext
1221 lines
41 KiB
Plaintext
initdir: procedure options(main);
|
||
|
||
/* REVISION HISTORY:
|
||
2/02/84 glp converted password input to raw I/O
|
||
1/24/83 whf converted to run on CCP/M-86
|
||
11/12/82 pb fixed bug in clearout, buildnew, and reconstruction */
|
||
|
||
declare
|
||
COPYRIGHT char(44) static initial
|
||
('COPYRIGHT (c) 1983 BY DIGITAL RESEARCH INC.');
|
||
|
||
/*
|
||
copyright(c) 1982, 1983
|
||
digital research
|
||
box 579
|
||
pacific grove, ca
|
||
93950
|
||
*/
|
||
|
||
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|
||
|
||
|
||
* * * DISK INTERFACE * * *
|
||
|
||
|
||
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
|
||
|
||
%include 'diomod.dcl';
|
||
|
||
%include 'initdira.dcl';
|
||
|
||
%replace
|
||
TRUE by '1'b,
|
||
FALSE by '0'b;
|
||
|
||
/* directory array 4K */
|
||
declare
|
||
1 dir_fcb(0:127),
|
||
3 user bit(8),
|
||
3 rest(31) char(1),
|
||
|
||
1 outbuf(0:127),
|
||
2 user fixed(7),
|
||
2 rest(31) char(1),
|
||
|
||
1 buffer2(0:127),
|
||
2 user bit(8),
|
||
2 rest(31) bit(8),
|
||
|
||
1 outb(0:127) based(outptr),
|
||
2 rest char(32),
|
||
|
||
1 outb2(0:127) based(outptr),
|
||
2 user bit(8),
|
||
2 rest(31) char(1),
|
||
|
||
1 outb3(0:127) based(outptr),
|
||
2 user fixed(7),
|
||
2 rest(31) bit(8),
|
||
|
||
1 outb4(0:127) based(outptr),
|
||
2 sfcbm char(1),
|
||
2 sfcb(3),
|
||
3 stamps char(8),
|
||
3 mode bit(8),
|
||
3 rest char(1),
|
||
2 frest char(1),
|
||
|
||
1 infcb(0:127) based(dirptr),
|
||
2 rest char(32),
|
||
|
||
1 infcb2(0:127) based(dirptr),
|
||
2 user char(1),
|
||
2 name char(11),
|
||
2 pmode bit(8),
|
||
2 junk1 char(11),
|
||
2 stamp char(8),
|
||
|
||
1 clearbuf(0:127) based(clearptr),
|
||
2 rest char(32),
|
||
|
||
zeroes(31) bit(8) static init((31)'00000000'b)
|
||
;
|
||
|
||
/* directory array mask */
|
||
declare
|
||
1 dirm(0:127) based(dirptr),
|
||
3 user fixed(7),
|
||
3 fname char(8),
|
||
3 ftype char(3),
|
||
3 fext bin fixed(7),
|
||
3 fs1 bit(8),
|
||
3 fs2 bit(8),
|
||
3 frc fixed(7),
|
||
3 diskpass(8) char(1),
|
||
3 rest char(8);
|
||
|
||
declare /* disk parameter header mask */
|
||
dphp ptr ext,
|
||
1 dph_mask based(dphp),
|
||
2 xlt1 ptr,
|
||
2 space1(3) bit(8), /*******************/
|
||
2 mediaf bit(8), /* whf 1/8/83 */
|
||
2 space2(2) bit(8), /*******************/
|
||
2 dpbptr ptr,
|
||
2 csvptr ptr,
|
||
2 alvptr ptr,
|
||
2 dirbcb ptr,
|
||
2 dtabcb ptr,
|
||
2 hash ptr,
|
||
/*** 2 hbank ptr, ***/
|
||
|
||
xlt ptr; /* save the xlt ptr because of F10 buffer */
|
||
|
||
declare /* disk parameter block mask */
|
||
dpbp ptr external,
|
||
1 dpb_mask based(dpbp),
|
||
2 spt fixed(15),
|
||
2 blkshft fixed(7),
|
||
2 blkmsk fixed(7),
|
||
2 extmsk fixed(7),
|
||
2 dsksiz fixed(15),
|
||
2 dirmax fixed(15),
|
||
2 diralv bit(16),
|
||
2 checked fixed(15),
|
||
2 offset fixed(15),
|
||
2 physhf fixed(7),
|
||
2 phymsk fixed(7),
|
||
|
||
( dspt decimal(7,0),
|
||
dblk decimal(7,0) ) external;
|
||
|
||
declare (
|
||
dir_blks(32) bit(8),
|
||
errorcode bit(16)) external;
|
||
|
||
declare (
|
||
MAXSAVE bin fixed(15),
|
||
enddcnt bin fixed(15),
|
||
nxfcb bin fixed(15),
|
||
notsaved bin fixed(15),
|
||
xptr pointer) external,
|
||
|
||
1 XFCBs(1) based(xptr),
|
||
2 user bin fixed(7),
|
||
2 name char(11),
|
||
2 pmode bit(8),
|
||
2 stamp char(8);
|
||
|
||
|
||
declare
|
||
INITMSG char(54) static initial
|
||
('INITDIR WILL ACTIVATE TIME STAMPS FOR SPECIFIED DRIVE.'),
|
||
CONFIRM char(60) varying static initial
|
||
('Do you want to re-format the directory on drive: '),
|
||
|
||
ASKCLEAR char(44) static initial
|
||
('Do you want the existing time stamps cleared'),
|
||
RECOVER char(50) varying static init
|
||
('Do you want to recover time/date directory space'),
|
||
YN char(10) static initial(' (Y/N)? '),
|
||
YES char(1) static initial('Y'),
|
||
lyes char(1) static initial('y'),
|
||
yesno char(1),
|
||
|
||
UPPERCASE char(26) static initial
|
||
('ABCDEFGHIJKLMNOPQRSTUVWXYZ'),
|
||
LOWERCASE char(26) static initial
|
||
('abcdefghijklmnopqrstuvwxyz'),
|
||
|
||
pass1 char(20) static initial
|
||
('End of PASS 1.'),
|
||
ERRORM char(7) static initial
|
||
('ERROR: '),
|
||
TERM char(30) static initial
|
||
('INITDIR TERMINATED.'),
|
||
errvers char(50) static initial
|
||
('Requires Concurrent CP/M-86 2.0'),
|
||
errnotnew char(31) static initial
|
||
('Directory already re-formatted.'),
|
||
errtoobig char(30) static initial
|
||
('Not enough room in directory.'),
|
||
errpass char(15) static initial
|
||
('Wrong password.'),
|
||
errSTRIP char(30) varying static initial
|
||
('No time stamps present.'),
|
||
errMEM char(30) varying static initial
|
||
('Not enough available memory.'),
|
||
errRO char(20) varying static initial
|
||
('Disk is READ ONLY.'),
|
||
errWHAT char(30) varying static initial
|
||
('Cannot find last XFCB.'),
|
||
/*** errRSX char(60) varying static initial
|
||
('Cannot re-format the directory with RSXs in memory.'), ***/
|
||
errunrec char(19) static initial
|
||
('Unrecognized drive.'),
|
||
errDISKACT char(40) varying static initial
|
||
('Some other process has an open file.'),
|
||
errCONSOLE char(40) varying static initial
|
||
('INITDIR must be run in foreground only.'),
|
||
errXREAD char(22) varying static initial
|
||
('Fatal XIOS read error.'),
|
||
errXWRITE char(23) varying static initial
|
||
('Fatal XIOS write error.'),
|
||
errBIOS char(20) static initial
|
||
('Cannot select drive.');
|
||
|
||
declare (
|
||
outptr pointer,
|
||
bufptr1 pointer,
|
||
bufptr2 pointer,
|
||
dirptr pointer,
|
||
drivptr pointer,
|
||
clearptr pointer,
|
||
|
||
nempty bin fixed(15),
|
||
(nfcbs,nfcbs1) bin fixed(15),
|
||
lastsfcb bin fixed(15),
|
||
lastdcnt bin fixed(15),
|
||
(lasti,lastx) bin fixed(15),
|
||
lastsect bin fixed(15),
|
||
cleardcnt bin fixed(15),
|
||
(gsec,gtrk) bin fixed(15),
|
||
(dcnt,sect) bin fixed(15),
|
||
outdcnt bin fixed(15),
|
||
newdcnt bin fixed(15),
|
||
outidx bin fixed(7),
|
||
curdisk bin fixed(7),
|
||
newlasti bin fixed(7),
|
||
(sfcbidx,sfcboffs) bin fixed(15),
|
||
usernum fixed(7),
|
||
SFCBmark fixed(7) static initial(33),
|
||
Dlabel bin fixed(7) static initial (32)
|
||
) external,
|
||
|
||
Redo bit(1),
|
||
bad bit(1),
|
||
writeflag bit(1),
|
||
CLEARSECT bit(1),
|
||
CLEARSFCB bit(1),
|
||
labdone bit(1) static initial(false),
|
||
cversion bit(16),
|
||
READonly bit(16),
|
||
|
||
ptreos pointer,
|
||
EOS bit(8) static initial('00'b4),
|
||
CEOS char(1) based (ptreos),
|
||
|
||
fcb(32) char(1),
|
||
fcb0(50) char(1) based (drivptr),
|
||
dr0 fixed(7) based(drivptr),
|
||
disks char(16) static initial
|
||
('ABCDEFGHIJKLMNOP'),
|
||
drive bin fixed(7),
|
||
cdrive char(1);
|
||
|
||
declare
|
||
1 SCB,
|
||
2 soffs fixed(7),
|
||
2 seter fixed(7),
|
||
2 value char(2);
|
||
|
||
/**** commented out whf CCP/M-86
|
||
dcl
|
||
ccppage bit(8);
|
||
****/
|
||
|
||
/*************************************************************************
|
||
|
||
|
||
*** MAIN PROGRAM ***
|
||
|
||
|
||
**************************************************************************/
|
||
|
||
declare i bin fixed(7);
|
||
|
||
cversion = vers();
|
||
if substr(cversion,9,8) ~= '31'b4 |
|
||
((substr(cversion,1,8) & '11111101'b1) ~= '14'b4)
|
||
then call errprint((errvers));
|
||
|
||
if openvec() ~= 0 then call errprint(errDISKACT); /*** 1/83 whf ***/
|
||
|
||
soffs = 23;
|
||
seter = 0;
|
||
/*** ccppage = sgscb(addr(SCB)); /* if RSX present then stop */
|
||
/*** if substr(ccppage,7,1) = '1'b then call errprint(errRSX); */
|
||
|
||
drivptr = dfcb0(); /* get drive */
|
||
drive = dr0;
|
||
if dr0 > 16 then drive = 0;
|
||
|
||
do while(drive = 0); /* none recognized */
|
||
call wrongdisk(i,drive);
|
||
call getdisk(i,drive);
|
||
end;
|
||
|
||
cdrive = substr(disks,drive,1);
|
||
|
||
curdisk = curdsk(); /* restore BIOS to this */
|
||
|
||
put edit(INITMSG,confirm,cdrive,YN)(skip(2),a,skip,a,a,a);
|
||
get list(yesno);
|
||
if yesno ~= YES & yesno ~= lyes then call reboot;
|
||
|
||
READonly = rovec(); /* is the drive RO ? */
|
||
if substr(READonly,(17-drive),1) = '1'b then
|
||
call errprint(errRO);
|
||
|
||
call dselect(drive);
|
||
nfcbs = ((phymsk + 1)*4) - 1; /* # fcbs/physical rcd - 1 */
|
||
nfcbs1 = nfcbs + 1;
|
||
|
||
/* everything kosher, lock up system */
|
||
if syslock() ~= 0 then call errprint(errDISKACT); /*** 1/83 whf ***/
|
||
|
||
dirptr = addr(dir_fcb(0));
|
||
dcnt = 0;
|
||
call read_sector(dcnt,dirptr);
|
||
|
||
call allxfcb; /* allocate XFCB data space */
|
||
if dirm(3).user = SFCBmark then call query; /* recover SFCB space? */
|
||
call countdir; /* count number of directory entries */
|
||
|
||
if conlock() ~= 0 then call errprint(errCONSOLE); /*** 1/83 whf ***/
|
||
|
||
call init;
|
||
call restore;
|
||
|
||
/********************************************************************/
|
||
|
||
|
||
wrongdisk: procedure(i,drive) external;
|
||
declare (i,j,drive) bin fixed(7);
|
||
|
||
put list(ERRORM,errunrec);
|
||
|
||
/** put skip list('DRIVE: ');
|
||
j = i;
|
||
ptreos = addr(EOS);
|
||
do while(fcb0(j) ~= ' ' & fcb0(j) ~= CEOS);
|
||
put edit(fcb0(j))(a);
|
||
j = j + 1;
|
||
end;
|
||
**/
|
||
put skip;
|
||
|
||
end wrongdisk;
|
||
|
||
getdisk: procedure(i,drive) external;
|
||
declare (i,drive) bin fixed(7);
|
||
|
||
put skip list('Enter Drive: ');
|
||
get list(fcb0(i));
|
||
fcb0(i) = translate(fcb0(i),UPPERCASE,LOWERCASE);
|
||
fcb0(i+1) = ':';
|
||
|
||
drive = index(disks,fcb0(i));
|
||
|
||
end getdisk;
|
||
|
||
|
||
/**************************************************************************/
|
||
|
||
|
||
init: procedure external;
|
||
|
||
declare
|
||
(i,j,k,l) bin fixed(15);
|
||
|
||
lastx = nxfcb;
|
||
sect = sect - 1;
|
||
dcnt = dcnt - 1; /* reset to good dcnt */
|
||
|
||
if Redo then do;
|
||
newdcnt = lastdcnt;
|
||
newlasti = lasti;
|
||
end;
|
||
else do;
|
||
lastsfcb = lastdcnt/3 + 1;
|
||
newdcnt = lastdcnt + lastsfcb + (2 - mod(lastdcnt,3));
|
||
if newdcnt > dirmax then do;
|
||
lastdcnt = dirmax - nempty;
|
||
lastsfcb = lastdcnt/3 + 1;
|
||
newdcnt = lastdcnt + lastsfcb + (2 - mod(lastdcnt,3));
|
||
|
||
if newdcnt > dirmax then
|
||
call errprint(errtoobig);
|
||
|
||
call collapse; /* remove all empties by
|
||
collapsing dir from top */
|
||
lastsfcb = lastdcnt/3 + 1;
|
||
newdcnt = lastdcnt + lastsfcb + (2 - mod(lastdcnt,3));
|
||
if newdcnt > dirmax then
|
||
call errprint(errtoobig);
|
||
end;
|
||
newlasti = mod(newdcnt,nfcbs1) - 3 + mod(lastdcnt,3);
|
||
end;
|
||
|
||
outptr = addr(buffer2(0)); /* want to clear last read
|
||
sector...buffer2 only used
|
||
in collapse so it is free */
|
||
call clearout;
|
||
clearptr = outptr;
|
||
outptr = addr(outbuf(0));
|
||
call clearout; /* zero output buffer */
|
||
|
||
|
||
/***********************************************************************/
|
||
|
||
|
||
do while(lastsect < sect ); /* clear from end of dir */
|
||
call write_sector(dcnt,outptr);
|
||
dcnt = dcnt - nfcbs1;
|
||
sect = sect - 1;
|
||
end;
|
||
|
||
if (nempty - 1) ~= dirmax then do; /* if there are files on dir */
|
||
|
||
/* bottom of directory is
|
||
now all E5 and 21...
|
||
it is positioned to the
|
||
last good sector of the old
|
||
directory. */
|
||
dcnt = lastdcnt;
|
||
enddcnt = newdcnt;
|
||
call read_sector(dcnt,dirptr); /* read last good sector */
|
||
|
||
outidx = newlasti; /* index into out buffer */
|
||
call buildnew(lasti); /* fill in outbuff from the
|
||
bottom up...need this call
|
||
because lasti may be in
|
||
middle of read buffer */
|
||
do while(dcnt >= 0);
|
||
/* as soon as we are finished
|
||
with reading old sector,
|
||
then go clear it. This
|
||
should limit possibility
|
||
that duplicate FCB's occur.
|
||
*/
|
||
call read_sector(dcnt,dirptr);
|
||
call buildnew(nfcbs);
|
||
end;
|
||
|
||
end; /* virgin dir */
|
||
|
||
else call write_sector(0,outptr); /* write last sector */
|
||
|
||
do while(notsaved > 0);
|
||
call moreXFCB;
|
||
end;
|
||
|
||
end init;
|
||
|
||
/************************************************************************/
|
||
|
||
|
||
strip: procedure external;
|
||
|
||
/* remove all SFCB from directory by jamming
|
||
E5 into user field. Also turn off time/date
|
||
stamping in DIR LABEL. */
|
||
|
||
declare (i,j) bin fixed(7),
|
||
1 direct(0:127) based(dirptr),
|
||
2 junk1 char(12),
|
||
2 ext bit(8),
|
||
2 rest char(19),
|
||
|
||
olddcnt bin fixed(15);
|
||
|
||
|
||
dcnt = 0;
|
||
|
||
do while(dcnt <= dirmax);
|
||
|
||
call read_sector(dcnt,dirptr);
|
||
|
||
olddcnt = dcnt;
|
||
do i = 0 to nfcbs while(dcnt <= dirmax);
|
||
|
||
if ~labdone then
|
||
if dirm(i).user = Dlabel then do;
|
||
call getpass(i);
|
||
direct(i).ext = direct(i).ext & '10000001'b;
|
||
labdone = true;
|
||
end;
|
||
|
||
if dirm(i).user = SFCBmark then
|
||
dir_fcb(i).user = 'E5'b4;
|
||
|
||
dcnt = dcnt + 1;
|
||
end;
|
||
|
||
call write_sector(olddcnt,dirptr);
|
||
end;
|
||
|
||
end strip;
|
||
|
||
|
||
/*****************************************************************************/
|
||
|
||
|
||
|
||
countdir: procedure external;
|
||
declare i bin fixed(7);
|
||
|
||
/* there are 5 valid sets of codes in
|
||
the user field:
|
||
|
||
E5 - empty
|
||
0-15 - user numbers
|
||
32 - Directory label
|
||
33 - SFCB marker
|
||
16-31 - XFCB marker
|
||
|
||
This routine counts the # of used
|
||
directory slots ignoring E5.
|
||
NOTE: if SFCB present then last
|
||
slot = SFCB */
|
||
|
||
Redo = false;
|
||
nempty = 0;
|
||
sect = 0;
|
||
nxfcb = 0;
|
||
notsaved = 0;
|
||
bad = true;
|
||
/* If dir is already time stamped then
|
||
SFCBs should appear in every sector,
|
||
notably the first sector. Thus,
|
||
test first sector. If first sector
|
||
has SFCB then all do. If none in
|
||
first & they appear later then
|
||
INITDIR was probably interrupted.
|
||
In that case, zap the found SFCB's
|
||
and treat dir as virgin. */
|
||
|
||
if dirm(3).user = SFCBmark then bad = false;
|
||
|
||
do while(dcnt <= dirmax);
|
||
do i = 0 to nfcbs while(dcnt <= dirmax);
|
||
if dir_fcb(i).user ~= 'E5'b4 then do;
|
||
usernum = dirm(i).user;
|
||
|
||
/* assume sfcb's were caught before this */
|
||
if usernum > 15 & usernum < 32 then
|
||
call getXFCB(i);
|
||
|
||
/* if LABEL then check for password...
|
||
may terminate in getpass */
|
||
|
||
else if usernum = Dlabel then call getpass(i);
|
||
|
||
if (usernum < 33) | (~bad & usernum = 33) then
|
||
do;
|
||
|
||
lasti = i;
|
||
lastsect = sect;
|
||
lastdcnt = dcnt;
|
||
end; /* bad...*/
|
||
else if usernum = 33 then nempty = nempty + 1;
|
||
|
||
end; /* E5 ... */
|
||
else nempty = nempty + 1;
|
||
dcnt = dcnt + 1;
|
||
end;
|
||
|
||
sect = sect + 1;
|
||
call read_sector(dcnt,dirptr);
|
||
end;
|
||
|
||
if ~Redo then lastsfcb = lastdcnt/3 + 1;
|
||
|
||
end countdir;
|
||
|
||
getXFCB: procedure(i) external;
|
||
declare i bin fixed(7);
|
||
|
||
if nxfcb <= MAXSAVE then do;
|
||
nxfcb = nxfcb + 1;
|
||
XFCBs(nxfcb).user = usernum - 16;
|
||
XFCBs(nxfcb).name = infcb2(i).name;
|
||
XFCBs(nxfcb).pmode = infcb2(i).pmode;
|
||
XFCBs(nxfcb).stamp = infcb2(i).stamp;
|
||
end;
|
||
else notsaved = notsaved + 1;
|
||
|
||
end getXFCB;
|
||
|
||
|
||
allxfcb: procedure external;
|
||
|
||
/* allocates largest available block of space
|
||
to be used in storing XFCB info.
|
||
maxwds & allwds use word units */
|
||
|
||
declare maxwds entry returns(fixed(15)),
|
||
allwds entry(fixed(15)) returns(pointer),
|
||
size bin fixed(15);
|
||
|
||
size = maxwds(); /* get largest block in free space */
|
||
xptr = allwds(size); /* reserve it */
|
||
MAXSAVE = 2*(size/21); /* # XFCBs that can be saved */
|
||
if MAXSAVE <= 10 then call errprint(errMEM);
|
||
|
||
end allxfcb;
|
||
|
||
|
||
query: procedure external;
|
||
|
||
if bad then return;
|
||
|
||
put skip(2) list(errnotnew);
|
||
|
||
/* check to see if user wants
|
||
to strip SFCB's */
|
||
if ~asker(RECOVER) then do;
|
||
Redo = true;
|
||
CLEARSFCB = false;
|
||
if asker(ASKCLEAR) then do;
|
||
CLEARSFCB = true;
|
||
return;
|
||
end;
|
||
end;
|
||
else call strip; /* this will end down here
|
||
after stripping */
|
||
|
||
call restore; /* dir is already formattted &
|
||
user does not want to clear
|
||
old SFCB's....just stop */
|
||
|
||
end query;
|
||
|
||
buildnew: procedure(endidx) external;
|
||
declare (i,j,k,endidx) bin fixed(15);
|
||
|
||
declare 1 ot(0:127) based(outptr),
|
||
2 user fixed(7),
|
||
2 fname char(8),
|
||
2 ftype char(3),
|
||
2 rest char(20);
|
||
|
||
/* build output buffer from
|
||
input(end) to input(0).
|
||
k => refers to input */
|
||
k = endidx;
|
||
do while(k >= 0);
|
||
usernum = dirm(k).user;
|
||
|
||
outb(outidx).rest = infcb(k).rest;
|
||
|
||
if usernum = SFCBmark then do;
|
||
if bad then outb2(outidx).user = 'E5'b4;
|
||
else if CLEARSFCB then outb3(outidx).rest = zeroes;
|
||
end;
|
||
|
||
if usernum < 16 then do;
|
||
if nxfcb > 0 then /* if fcb is ex=0 and XFCB
|
||
exists then check for
|
||
possible SFCB update */
|
||
call putXFCB(k);
|
||
end;
|
||
|
||
if ~Redo & mod(outidx,4) = 0 then outidx = outidx - 2;
|
||
else outidx = outidx - 1;
|
||
|
||
k = k - 1;
|
||
dcnt = dcnt - 1;
|
||
|
||
if outidx < 0 then do;
|
||
if dcnt > 14 then
|
||
if mod(dcnt + 1,nfcbs1) = 0 then
|
||
call write_sector(dcnt + 1,clearptr);
|
||
call write_sector(newdcnt,outptr);
|
||
newdcnt = newdcnt - nfcbs1;
|
||
outidx = nfcbs - 1;
|
||
if Redo then outidx = outidx + 1;
|
||
end;
|
||
end;
|
||
|
||
end buildnew;
|
||
|
||
|
||
/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
|
||
|
||
|
||
compare: procedure(k) returns(fixed(7)) external;
|
||
|
||
declare (i,j,k) bin fixed(7),
|
||
1 direc(0:127) based(dirptr),
|
||
2 user fixed(7),
|
||
2 name(11) char(1),
|
||
2 rest char(20),
|
||
|
||
1 XFCB2(1) based(xptr),
|
||
2 user char(1),
|
||
2 name(11) char(1),
|
||
2 rest char(9);
|
||
|
||
/* compare fcb with XFCB list;
|
||
return position in list if
|
||
found, 0 otherwise.
|
||
Nullify usernum field in
|
||
XFCB list (=99) if found.
|
||
Decrement #xfcb as well.*/
|
||
do i = 1 to nxfcb;
|
||
if XFCBs(i).user ~= 99 then do;
|
||
if XFCBs(i).user = direc(k).user then do;
|
||
|
||
do j = 1 to 11;
|
||
if direc(k).name(j) ~= XFCB2(i).name(j)
|
||
then go to outx;
|
||
end;
|
||
|
||
/* found a match */
|
||
XFCBs(i).user = 99;
|
||
nxfcb = nxfcb - 1;
|
||
return(i);
|
||
|
||
outx: end;
|
||
end;
|
||
end;
|
||
|
||
return(0);
|
||
|
||
end compare;
|
||
|
||
moreXFCB: procedure external;
|
||
/* we could not store all the xfcb's in memory
|
||
available, so now must make another pass &
|
||
store as many XFCB as possible.
|
||
'notsaved' > 0 ==> we may have to
|
||
do this again. */
|
||
declare (i,k) bin fixed(7);
|
||
|
||
dcnt = enddcnt; /* go to end of directory */
|
||
if ~findXFCB(k) then /* work backwards trying to find
|
||
last known XFCB...if not found
|
||
then something very strange has
|
||
happened; */
|
||
call errprint(errWHAT);
|
||
|
||
notsaved = 0; /* now in last sector where last XFCB
|
||
occurs...look for other XFCB that
|
||
we know is there. */
|
||
nxfcb = 0;
|
||
|
||
dcnt = dcnt + 1;
|
||
lastdcnt = dcnt; /* save position of last XFCB + 1 */
|
||
lasti = k + 1; /* index in sector */
|
||
do while(dcnt <= enddcnt);
|
||
do i = k+1 to nfcbs while(dcnt <= enddcnt);
|
||
usernum = dirm(i).user;
|
||
if usernum > 15 & usernum < 32 then call getXFCB(i);
|
||
dcnt = dcnt + 1;
|
||
end;
|
||
k = 0;
|
||
call read_sector(dcnt,dirptr);
|
||
end;
|
||
|
||
dcnt = 0; /* go to start of dir */
|
||
do while(dcnt <= enddcnt);
|
||
call read_sector(dcnt,dirptr);
|
||
outdcnt = dcnt;
|
||
writeflag = false; /* putXFCB sets when it finds a
|
||
match */
|
||
|
||
do k = 0 to nfcbs while(dcnt <= enddcnt);
|
||
outidx = k;
|
||
if dirm(k).user < 16 then call putXFCB(k);
|
||
dcnt = dcnt + 1;
|
||
end;
|
||
if writeflag then call write_sector(outdcnt,dirptr);
|
||
end;
|
||
|
||
end moreXFCB;
|
||
|
||
findXFCB: procedure(idx) returns(bit(1)) external;
|
||
|
||
/* find the last known XFCB...starts from the
|
||
last written sector in the dir and goes
|
||
backwards...hopefully that's faster */
|
||
declare idx fixed(7);
|
||
|
||
do while(dcnt > 0);
|
||
call read_sector(dcnt,dirptr);
|
||
do idx = 0 to nfcbs while(dcnt > 0);
|
||
usernum = dirm(idx).user;
|
||
if usernum > 15 & usernum < 32 then
|
||
if XFCBs(lastx).name = infcb2(idx).name then
|
||
return(true);
|
||
dcnt = dcnt - 1;
|
||
end;
|
||
end;
|
||
|
||
return(false); /* big trouble...*/
|
||
|
||
end findXFCB;
|
||
|
||
|
||
putXFCB: procedure(k) external;
|
||
/* if this is extent 0 fold and names match
|
||
then update SFCB from XFCB */
|
||
declare (k,j) fixed(7);
|
||
|
||
if dirm(k).fext <= dpb_mask.extmsk then do;
|
||
j = compare(k);
|
||
if j ~= 0 then do;
|
||
|
||
/* fcb matches XFCB...
|
||
update the SFCB */
|
||
sfcboffs = mod(outidx+1,4);
|
||
sfcbidx = outidx + (4 - sfcboffs);
|
||
outb4(sfcbidx).sfcb(sfcboffs).stamps =
|
||
XFCBs(j).stamp;
|
||
outb4(sfcbidx).sfcb(sfcboffs).mode =
|
||
XFCBs(j).pmode;
|
||
writeflag = true;
|
||
end;
|
||
end; /* extent 0 ? */
|
||
|
||
end putXFCB;
|
||
|
||
|
||
errprint: procedure(msg) external;
|
||
declare
|
||
msg char(60) varying;
|
||
|
||
put edit(ERRORM,msg,TERM)(skip(2),a,a,skip,a);
|
||
put skip(2);
|
||
|
||
call restore;
|
||
|
||
end errprint;
|
||
|
||
|
||
asker: procedure(msg) returns(bit(1)) external;
|
||
|
||
declare msg char(60) varying;
|
||
|
||
put skip list(msg,YN);
|
||
get list(yesno);
|
||
|
||
if yesno ~= YES & yesno ~= lyes then return(false);
|
||
|
||
return(true);
|
||
|
||
end asker;
|
||
|
||
|
||
clearout: procedure external;
|
||
declare
|
||
(i,j) bin fixed(7);
|
||
|
||
do i = 0 to nfcbs;
|
||
if mod(i+1,4) ~= 0 then outb2(i).user = 'E5'b4;
|
||
else outb3(i).user = SFCBmark;
|
||
|
||
do j = 1 to 31;
|
||
outb3(i).rest(j) = '00000000'b;
|
||
end;
|
||
end;
|
||
|
||
end clearout;
|
||
|
||
getpass: procedure(fcbx) external;
|
||
/* Drive may be password protected...
|
||
Get passw from user and compare
|
||
with Password in label.
|
||
Label password is encoded by first
|
||
reversing each char nibble and then
|
||
XOR'ing with the sum of the pass.
|
||
S2 in label = that sum. */
|
||
|
||
declare
|
||
passwd(8) bit(8) based(passptr),
|
||
|
||
passptr pointer,
|
||
convptr pointer,
|
||
pchar(8) bit(8),
|
||
cvpass(8) char(1) based(convptr),
|
||
inpass char(8),
|
||
c char(1),
|
||
(i,j,fcbx) bin fixed(7);
|
||
|
||
labdone = true;
|
||
|
||
passptr = addr(dirm(fcbx).diskpass);
|
||
convptr = addr(pchar(1));
|
||
|
||
do i = 1 to 8; /* XOR each character */
|
||
pchar(i) = bool(passwd(i),dirm(fcbx).fs1,'0110'b);
|
||
end;
|
||
|
||
if cvpass(8) <= ' ' then return; /* no password */
|
||
|
||
put skip(2) list('Directory is password protected.');
|
||
put skip list('Password, please. >');
|
||
/* get list(inpass); */
|
||
retry:
|
||
inpass = ' ';
|
||
do i = 1 to 8;
|
||
nxtchr:
|
||
c = coninp();
|
||
if c >= ' ' then
|
||
substr(inpass,i,1) = c;
|
||
if c = ascii(13) then /* cr */
|
||
goto exit;
|
||
if c = ascii(24) then /* ^X */
|
||
goto retry;
|
||
if c = ascii(8) then do; /* ^H */
|
||
if i<2 then
|
||
goto retry;
|
||
else do;
|
||
i = i - 1;
|
||
substr(inpass,i,1) = ' ';
|
||
goto nxtchr;
|
||
end;
|
||
end;
|
||
if c = ascii(3) then do; /* ^C */
|
||
put skip(2);
|
||
call restore;
|
||
end;
|
||
end;
|
||
exit:
|
||
c = break(); /* Clear raw I/O mode */
|
||
put skip(1);
|
||
|
||
inpass = translate(inpass,UPPERCASE,LOWERCASE);
|
||
|
||
j = 8;
|
||
do i = 1 to 8;
|
||
if substr(inpass,i,1) ~= cvpass(j) then call errprint(errpass);
|
||
j = j - 1;
|
||
end;
|
||
|
||
end getpass;
|
||
|
||
|
||
collapse: procedure external;
|
||
|
||
declare whichbuf bin fixed(7),
|
||
enddcnt bin fixed(15),
|
||
(i,nout1,nout2) bin fixed(7);
|
||
|
||
dcnt = 0;
|
||
sect = 0;
|
||
outdcnt = 0;
|
||
whichbuf = 0;
|
||
nout1 = 0;
|
||
nout2 = 0;
|
||
lastsect = 0;
|
||
enddcnt = lastdcnt + nempty;
|
||
lastdcnt = 0;
|
||
bufptr1 = addr(outbuf(0));
|
||
bufptr2 = addr(buffer2(0));
|
||
|
||
do while(dcnt <= enddcnt); /* read up to last dcnt */
|
||
|
||
call read_sector(dcnt,dirptr);
|
||
|
||
do i = 0 to nfcbs while(dcnt <= enddcnt);
|
||
if dir_fcb(i).user ~= 'E5'b4 &
|
||
dirm(i).user ~= SFCBmark then do;
|
||
|
||
if whichbuf = 0 then
|
||
call fill(bufptr1,i,nout1,whichbuf);
|
||
else call fill(bufptr2,i,nout2,whichbuf);
|
||
end;
|
||
dcnt = dcnt + 1;
|
||
end;
|
||
|
||
sect = sect + 1;
|
||
if nout1 = nfcbs1 then call flush_write(nout1,bufptr1);
|
||
else if nout2 = nfcbs1 then call flush_write(nout2,bufptr2);
|
||
end;
|
||
|
||
dcnt = dcnt - 1; /* fill unused slots in buffer
|
||
with empty...scratch rest of
|
||
dir */
|
||
if whichbuf = 0 then call fill2(bufptr1,nout1);
|
||
else call fill2(bufptr2,nout2);
|
||
|
||
end collapse;
|
||
|
||
fill: proc(bufptr,i,nout,whichbuf);
|
||
declare bufptr pointer,
|
||
(i,j,nout) bin fixed(7),
|
||
whichbuf bin fixed(7),
|
||
|
||
1 buffer(0:127) based(bufptr),
|
||
2 out char(32);
|
||
|
||
buffer(nout).out = infcb(i).rest;
|
||
|
||
lastdcnt = lastdcnt + 1;
|
||
nout = nout + 1;
|
||
if nout = nfcbs1 then whichbuf = mod((whichbuf + 1),2);
|
||
|
||
end fill;
|
||
|
||
flush_write: proc(nout,bufptr);
|
||
declare nout bin fixed(7),
|
||
bufptr pointer;
|
||
|
||
/* always behind the read...thus don't
|
||
need to test to see if read sector =
|
||
write sector. */
|
||
call write_sector(outdcnt,bufptr);
|
||
outdcnt = outdcnt + nfcbs1;
|
||
nout = 0;
|
||
lastsect = lastsect + 1;
|
||
|
||
end flush_write;
|
||
|
||
fill2: proc(bufptr,nout);
|
||
|
||
declare (i,j,nout) bin fixed(7),
|
||
bufptr pointer,
|
||
1 buffer(0:127) based(bufptr),
|
||
2 user bit(8),
|
||
2 rest(31) bit(8);
|
||
|
||
do i = nout to nfcbs;
|
||
buffer(i).user = 'E5'b4;
|
||
do j = 1 to 31;
|
||
buffer(i).rest(j) = '00000000'b;
|
||
end;
|
||
end;
|
||
|
||
lastdcnt = lastdcnt - 1;
|
||
lasti = nout - 1;
|
||
call flush_write(nout,bufptr);
|
||
|
||
do i = 0 to nfcbs; /* prepare empty sector */
|
||
buffer(i).user = 'E5'b4;
|
||
do j = 1 to 31;
|
||
buffer(i).rest(j) = '00000000'b;
|
||
end;
|
||
end;
|
||
|
||
/* clear rest of directory */
|
||
do while (outdcnt < dcnt);
|
||
call write_sector(outdcnt,bufptr);
|
||
outdcnt = outdcnt + nfcbs1;
|
||
end;
|
||
|
||
end fill2;
|
||
|
||
restore: procedure external;
|
||
declare
|
||
1 xdpb based(dpbp),
|
||
2 front char(11),
|
||
2 chkvecb bit(16);
|
||
|
||
/* if selected drive was permanent,
|
||
then must force login of drive to
|
||
restore good directory buffers and
|
||
hash tables */
|
||
/* In CCP/M-86, this is done by setting
|
||
the login sequence number in the DPH
|
||
to zero, thus ensuring hard disks wi
|
||
also get reset. Look at rtn 'seldsk'
|
||
in 'initdira.a86' */
|
||
/*
|
||
if chkvecb = '1000000000000000'b then do;
|
||
if drive = 0 then drive = curdisk;
|
||
else drive = drive - 1;
|
||
checked = 0;
|
||
call reset();
|
||
errorcode = select(drive);
|
||
chkvecb = '1000000000000000'b;
|
||
errorcode = select(drive);
|
||
end;
|
||
*/
|
||
call sysunlock(); /* unlock the disk system whf 1/83 */
|
||
dphp = seldsk(curdisk); /* restore drive */
|
||
call reset(); /* reset disk system */
|
||
errorcode = select(curdisk);
|
||
call conunlock(); /* allow switching of consoles whf 1/83 */
|
||
|
||
call reboot;
|
||
|
||
end restore;
|
||
|
||
/* read logical record # to dma address */
|
||
read_sector: procedure(lrcd,dmaaddr) external;
|
||
dcl
|
||
lrcd bin fixed(15),
|
||
prcd decimal(7,0),
|
||
dmaaddr pointer; /* dma address */
|
||
|
||
prcd = lrcd/nfcbs1;
|
||
gtrk = track(prcd);
|
||
call settrk(gtrk);
|
||
gsec = sector(prcd);
|
||
call setsec(gsec);
|
||
|
||
call bstdma(dmaaddr);
|
||
if rdsec() ~= 0 then do;
|
||
put skip list('While reading record ',prcd);
|
||
put list(': track ',gtrk,', sector',gsec);
|
||
call errprint(errXREAD);
|
||
end;
|
||
|
||
end read_sector;
|
||
|
||
|
||
/* write logical record # from dma address */
|
||
write_sector: procedure(lrcd,dmaaddr) external;
|
||
dcl
|
||
lrcd bin fixed(15),
|
||
dmaaddr pointer, /* dma address */
|
||
prcd decimal(7,0);
|
||
|
||
prcd = lrcd/nfcbs1; /* #fcbs/phys rec */
|
||
gtrk = track(prcd);
|
||
call settrk(gtrk);
|
||
gsec = sector(prcd);
|
||
call setsec(gsec);
|
||
|
||
call bstdma(dmaaddr);
|
||
if wrsec(1) ~= 0 then do;
|
||
put skip list('While writing record ',prcd);
|
||
put list(': track ',gtrk,', sector',gsec);
|
||
call errprint(errXREAD);
|
||
end;
|
||
|
||
|
||
end write_sector;
|
||
|
||
|
||
/* select disk drive */
|
||
dselect: procedure((d)) external;
|
||
dcl
|
||
p ptr,
|
||
wdalv(16) fixed(15) based(p),
|
||
btalv(16) fixed(7) based(p),
|
||
all bit(16),
|
||
d fixed(7);
|
||
|
||
|
||
dcl
|
||
1 dpb based (dpbp),
|
||
2 sec bit(16),
|
||
2 bsh bit(8),
|
||
2 blm bit(8),
|
||
2 exm bit(8),
|
||
2 dsm bit(16),
|
||
2 drm bit(16),
|
||
2 al0 bit(8),
|
||
2 al1 bit(8),
|
||
2 cks bit(16),
|
||
2 off bit(8);
|
||
|
||
if d = 0 then d = curdsk();
|
||
else d = d - 1;
|
||
|
||
errorcode = select(d); /* sync BIOS & BDOS */
|
||
dphp = seldsk(d);
|
||
if dphp = null then call errprint(errBIOS);/* can't select disk */
|
||
|
||
xlt = xlt1;
|
||
dpbp = dpbptr;
|
||
|
||
dspt = decimal(spt); /**** whf 1/8/83 ****/
|
||
|
||
end dselect;
|
||
|
||
/* convert logical rcd # to physical sector */
|
||
sector: procedure(i) returns(fixed(15)) external;
|
||
dcl
|
||
i decimal(7,0);
|
||
|
||
return(sectrn(binary(mod(i,dspt),15),xlt));
|
||
|
||
end sector;
|
||
|
||
|
||
/* logical record # to physical track */
|
||
track: procedure(i) returns(fixed(15)) external;
|
||
dcl
|
||
i decimal(7,0);
|
||
|
||
return(offset + binary(i/dspt,15));
|
||
|
||
end track;
|
||
|
||
|
||
/* logical record # to physical block */
|
||
conv: procedure(i) returns(fixed(15)) external;
|
||
dcl
|
||
i fixed(7),
|
||
j fixed(15),
|
||
p ptr,
|
||
n fixed(7) based(p);
|
||
|
||
p = addr(j);
|
||
j = 0;
|
||
n = i;
|
||
return(j);
|
||
end conv;
|
||
|
||
patch: procedure;
|
||
dcl i fixed(15);
|
||
|
||
i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
||
i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
||
i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
||
i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
||
i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
||
i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
||
i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
||
i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5; i=i+5;
|
||
end patch;
|
||
|
||
|
||
|
||
end initdir;
|
||
|