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;
