MODULE ACCESS=
!Access control routine for NETSPL
BEGIN

FORWARD ROUTINE
ACCESS,
CKACCESS,	!Get & return the access bits
CKACCHANDLE;	!Condition handler for ACCESS

REQUIRE 'INTR.REQ';
LIBRARY 'DAPLIB';	!Dap declarations & macros

THIS_IS [ACCE]	VERSION [2]	EDIT[16]	DATE [25,SEP,79]

%(	R E V I S I O N   H I S T O R Y

[16]	Don't say "ACCESS REFUSED" if disk isn't mounted, etc.
[15]	Fix [14] so not to lose buffers & thus grow
[14]	Look in ACCESS.FTS first
[13]	Fix granting /ALL if any switches set but /NONE
[12]	Make /RENAME check both new & old file
	make CHECK_ACCESS block into a routine
[11]	Fix /NONE not working on left of "=" sign
	Fix error msgs so not always ... for read 
[10]	Change BIND FB=N[FB]: REF FILE_BLOCK to BIND FB=.N[FB]: FILE_BLOCK
[7]	Fix /NONE, make everything conform to documentation
[6]	Make LSWITCHES (& GSWITCHES) use bits from right to left
[5]	Remove [4], NDB$REQUESTOR is once again ASCIZ
[4]	Make NDB$REQUESTOR ASCIC string

END	R E V I S I O N   H I S T O R Y )%

!
!Literals
!
LITERAL	!Bit definitions for LSWITCHES
	AS_NOACCESS=0,	!/NONE was found (don't allow any access at all)
	AS_READ=1,
	AS_CREATE=2,
	AS_RENAME=3,
	AS_ERASE=4,
	AS_LIST=6,
	AS_BATCH=7,
	AS_COMMAND=8,	!1 to 8 must correspond to DAP ACCFUNC codes
	AS_WRITE=12,	!Reserved for future use
	AS_SUPERCEDE=13,!Allow superceding of existing file
	AS_ALL=15;	!/ALL
LITERAL	LF=%O'12',	CR=%O'10';
LITERAL	LINE_LEN=131;
%IF NOT %DECLARED(PATMIN) %THEN LITERAL PATMIN=4; %FI

!
! Externals
!
EXTERNAL ROUTINE READ,FPARSE,RDDIR,COPY,CKWLD6,CKWLD,DOSWITCHES,CKWLDD,
	BUFFREE,ZERO,CKWLDP,RDSIXA,CKWLDA,CHACAZ;
EXTERNAL ACSTBL;		!Switch table

!
! Routines
!
GLOBAL ROUTINE ACCESS(NB)=
!Access control routine
!Argument:
!NB:	Node data block.  File being accessed has file block
!	pointed to by NB[NDB$FB]
BEGIN
MAP NB: REF NDB;
BIND FB=.NB[NDB$FB]: FILE_BLOCK;

LOCAL	LSWITCHES: BITVECTOR[16];	!Access bits from CKACCESS

FB[FILE$GODLY]=1;	!Make sure we get as much access as we can

LSWITCHES=CKACCESS(NB[FILE$START],FB[FILE$START]);	!Check access bits

!Now check our access bits against what we need
IF .LSWITCHES[.NB[NDB$ACCFUNC]] EQL 0 THEN ERROR(FILPRT,FB[FILE$START]);

!Now clear the blocks read&written count
FB[FILE$READS]=(FB[FILE$WRITES]=0);

!Now open the file
	BEGIN
	BIND FOP=NB[NDB$FOP]: EX[6];
	BIND FAC=NB[NDB$FAC]: EX[6];	!FAC field
	SELECT .NB[NDB$ACCFUNC] OF SET
	[ACC$OPEN]:
		BEGIN
		!Does he want to delete?
		IF .FOP[FB$DLC] AND (NOT .LSWITCHES[AS_ERASE])
		THEN	ERROR(FILPRT,FB[FILE$START]);
		IF .FAC[FB$UPD] THEN
			BEGIN
			OPEN_U(FB);
			RETURN WIN;
			END
		ELSE	BEGIN
			OPEN_R(FB);
			RETURN WIN;
			END;
		END;
	[ACC$CREATE]:
		BEGIN
		IF .FAC[FB$PUT] THEN
			BEGIN
			IF .FOP[FB$SUP]
			THEN	BEGIN
				IF .LSWITCHES[AS_SUPERCEDE]
					THEN OPEN_W(FB)
					ELSE OPEN_CRE(FB);
				!We will return ER$FEX to remote system
				!either if he did not ask for supercede
				!or couldn't get it
				RETURN WIN;
				END
			ELSE	BEGIN
				OPEN_CRE(FB);
				RETURN WIN;
				END;
			END
		END;
	[ACC$RENAME]:
		BEGIN
		LOCAL RSWITCHES: BITVECTOR[16];	!Access switches for rename
		BIND RENAME_FB=.NB[NDB$RENAME_FB]: FILE_BLOCK;
		IF .RENAME_FB[FILE$DEVICE] EQL 0 !Default new device to old
		THEN	RENAME_FB[FILE$DEVICE]=.FB[FILE$DEVICE];
		RSWITCHES=CKACCESS(NB[FILE$START],.NB[NDB$RENAME_FB]);
		FB[FILE$RENAME]=RENAME_FB[FILE$ELK]; !What to rename it to
		IF .RSWITCHES[AS_CREATE]
		THEN	RENAME(FB)
		ELSE	ERROR(FILPRT,.NB[NDB$RENAME_FB]);
			!no access to new name
		RETURN WIN;
		END;
	[ACC$ERASE]:
		BEGIN
		DELETE(FB);
		RETURN WIN;
		END;
	TES;
	END;
RETURN 0;
END;
ROUTINE CKACCESS(NB,FB)=
!Local routine to get the access bits for the file.
!Reads ACCESS.USR in the specified directory.

!
! Formal Parameters
!

!NB: address of NDB
!FB: address of FILE_BLOCK of file being checked

!
! Returned value
!

!Access bits as defined above

BEGIN
MAP	NB:	REF NDB,	!NDB for transfer
	FB:	REF FILE_BLOCK;	!File being checked

!STRUCTURE BITV[BT;BLEN]=[1] BITV<BT,1>;
LOCAL	LINE: VECTOR[CH$ALLOCATION(LINE_LEN+1)], !Line we just read from ACCESS.USR
	REQUESTOR: VECTOR[CH$ALLOCATION(40)], !Requestor from ACCESS.USR
	NODEID,				!Nodeid we just read from ACCESS.USR
	FILE: NDB,			!Fileblock to scan ACCESS.USR
	FILE_SAVE: FILE_BLOCK,		!Save name of file we-re trying to open
	GSWITCHES: BITVECTOR[16],	!Global switches
	LSWITCHES: BITVECTOR[16],	!Local switches
	! Bit position corresponds to ACCESS msg function code
	PTR;				!Pointer to the above line
REGISTER	C;			!Save last character read
LABEL	CHECK_ACCESS,			!Block to get appropriate bits
	DOLINE;				!Block that process a line in ACCESS.USR

!Establish handler to catch errors on ACCESS.USR
ESTABLISH(CKACCHANDLE,NB[FILE$START],FB[FILE$START],FILE_SAVE);

CHECK_ACCESS:
	BEGIN
	COPY(FB[FILE$START],FILE_SAVE[FILE$START],FB_LEN); !Save the file block
	FB[FILE$GODLY]=1;		!Enable full file access
	FB[FILE$NAME]=%SIXBIT'ACCESS';	!Set to ACCESS.USR
	FB[FILE$EXTENSION]=%SIXBIT'   FTS';
	!Note that ACCESS.FTS will be opened on the same channel
	!as the real file will be (but not at the same time).  
	FB[FILE$MODE]=_IOASC;	!Read this in ASCII mode always

	OPEN_R(FB[FILE$START]);		!Open ACCESS.FTS
	COPY(FILE_SAVE[FILE$COUNT],FB[FILE$COUNT],.FILE_SAVE[FILE$COUNT]+1);
			!Restore lookup block
	!FB[FILE$GODLY]=.FILE_SAVE[FILE$GODLY];	!Restore godly bit
	FB[FILE$MODE]=.FILE_SAVE[FILE$MODE];	!Restore data mode

	FILE[FILE$DEVICE]=.FB[FILE$DEVICE];	!Device & directory
	IF .FB[FILE$LPPN] LEQ %O'777777'
	THEN	BEGIN
		FILE[FILE$LPPN]=FILE[FILE$PATH_FUN]; !Point to path block
		COPY(FB[FILE$PATH_FUN],FILE[FILE$PATH_FUN],SFDMAX+PATMIN);
		END
	ELSE	FILE[FILE$LPPN]=.FB[FILE$LPPN];

	WHILE 1 DO
	DOLINE:	BEGIN	!Read through ACCESS.USR
		FILE[NDB$NODEID]=(FILE[FILE$NAME]=(FILE[FILE$EXTENSION]=0));
		READ(FB[FILE$START],%REF(CH$PTR(LINE)),LINE_LEN,LF);
				!Read in a line
		PTR=CH$PTR(LINE);
		FILE[FILE$PF_NOSIG]=	!Don't signal FPARSE errors
		(FILE[FILE$PF_WILD_A]=(FILE[FILE$PF_WILDN_A]=1));
		!Remember that wildcards are allowed here
		IF FPARSE(FILE,PTR) NEQ WIN THEN LEAVE DOLINE;
					!Get nodeid & filename
		IF CKWLD(FILE,FB[FILE$START]) THEN
			BEGIN	!This line matches our file
			GSWITCHES=DOSWITCHES(ACSTBL,PTR,%REF(0));!Parse switches
			SELECT .GSWITCHES OF SET	!Check for errors
			[ILLSWI,AMBSWI]: LEAVE DOLINE;	!Bad switch
			TES;
			IF CH$RCHAR_A(PTR) NEQ %C'='
				THEN LEAVE DOLINE; !Syntax error
			NODEID=.FILE[NDB$NODEID]; !Default, if any
			DO	BEGIN
				SELECT CH$RCHAR(.PTR) OF SET
				[%C'A' TO %C'Z',%C'a' TO %C'z',%C'0' TO %C'9',
				 %C'%',%C'?',%C'*']:
					BEGIN !Nodeid (we hope)
					LOCAL RDSARG;

					RDSARG=PTR; RDSARG<35,1>=1; !Allow wilds
					NODEID=RDSIXA(.RDSARG);
					IF (CH$RCHAR_A(PTR) NEQ %C':') OR
					 (CH$RCHAR_A(PTR) NEQ %C':')
						THEN LEAVE DOLINE; !Not a nodeid
					END; !Getting nodeid
				[OTHERWISE]:;
				TES;
				IF .NODEID EQL 0 THEN LEAVE DOLINE;

				!If we didn't get it by now we never will
				SELECT (CH$RCHAR(.PTR)) OF SET
				[%C'[',%C'<']:	!Directory specifier
					BEGIN
					LOCAL REQPTR,
					   ACCESSOR: VECTOR[CH$ALLOCATION(40)];
					REQPTR=CH$PTR(ACCESSOR);
					DO CH$WCHAR_A(C=CH$RCHAR_A(PTR),REQPTR)
					 UNTIL (.C EQL %C'>') OR (.C EQL %C']');
					!Copy this requestor string
					CH$WCHAR_A(0,REQPTR); !Make ASCIZ

					!Get switches if any
					LSWITCHES=
					 DOSWITCHES(ACSTBL,PTR,%REF(0));
					SELECT .LSWITCHES OF SET
					[0]: LSWITCHES=.GSWITCHES;
					 !No switches on this side
					 ! use ones from left side
					[ILLSWI,AMBSWI]: LEAVE DOLINE;
					TES;

					IF CKWLDA(CH$PTR(ACCESSOR),
						  CH$PTR(N[REQUESTOR]))
					    AND
					   CKWLD6(.NODEID,.NB[NDB$NODEID])
					 THEN	BEGIN
						LEAVE CHECK_ACCESS
						 WITH  .LSWITCHES;
						END;!A match
					END; !Process dir & switches
				[%C',']:	CH$RCHAR_A(PTR);
				[OTHERWISE]: LEAVE DOLINE; !Syntax error
				TES;
				END WHILE 1;
				!A comma heralds the arrival of another PPN
			END;
		END; !DOLINE loop
	END;	!CHECK_ACCESS block
BUFFREE(.FB[FILE$I_BRH]);	!Free the buffers
BUFFREE(.FB[FILE$O_BRH]);	!

IF .LSWITCHES[AS_SUPERCEDE] THEN LSWITCHES[AS_CREATE]=1;
	!/SUPERCEDE implies /CREATE
IF .LSWITCHES[AS_NOACCESS] THEN ERROR(FILPRT,FB[FILE$START]);	!/NONE found
IF .LSWITCHES[AS_ALL] THEN LSWITCHES=-2;	!Set everyting if /ALL
.LSWITCHES			!Returned value
END;	!CKACCESS
ROUTINE CKACCHANDLE(SIGNAL_ARGS,MECH_ARGS,ENABLE_ARGS)=
!Condition handler for ACCESS. Any kind of condition causes access failure
!ENABLE_ARGS[1]= addr of NDB,
!ENABLE_ARGS[2]= the file block for the file being access-checked
!ENABLE_ARGS[3]= addr of FILE_SAVE
BEGIN
MAP	SIGNAL_ARGS:			REF BLOCK FIELD(SA_FIELDS),
	MECH_ARGS:			REF VECTOR,
	ENABLE_ARGS:			REF VECTOR;

BIND	NB=ENABLE_ARGS[1]:		REF NDB,
	FB=.ENABLE_ARGS[2]:		FILE_BLOCK,
	FILE_SAVE=.ENABLE_ARGS[3]:	FILE_BLOCK;


!First fix up function field so we get the right error message
FB[FILE$FUNCTION]=	(SELECT .N[ACCFUNC] OF SET
			 [ACC$OPEN]:	(IF .EX[N[FAC],FB$UPD]
					 THEN _FOSAU
					 ELSE _FORED);
			 [ACC$CREATE]:	_FOCRE;
			 [ACC$RENAME]:	_FORNM;
			 [ACC$ERASE]:	_FODLT;
			 TES
			);

!Now check the error code.  EOF or file-not-found on ACCESS.USR
!counts as a protection failure.
SELECT .SIGNAL_ARGS[SA$STSCODE] OF SET
[FILFNF]:		IF .FB[FILE$EXTENSION] EQL %SIXBIT '   FTS'
			THEN	BEGIN
				LOCAL T;
				BUFFREE(.FB[FILE$I_BRH]); ![15]
				BUFFREE(.FB[FILE$O_BRH]); ![15]
				FB[FILE$EXTENSION]=%SIXBIT '   USR';
				!Try ACCESS.USR if no ACCESS.FTS
				FB[FILE$PF_NOSIG]=1; !Do not SIGNAL errors
				T=OPEN_R(FB[FILE$START]);
				FB[FILE$PF_NOSIG]=0;
				IF .T
				THEN	RETURN SS$_CONTINUE
				END;
[FILERR TO FILOPN]:	BEGIN	!Put file block back the way we found it
			COPY(FILE_SAVE[FILE$COUNT],FB[FILE$COUNT],
			 .FILE_SAVE[FILE$COUNT]+1);
			!Restore lookup block
			FB[FILE$MODE]=.FILE_SAVE[FILE$MODE];	!Restore data mode
			END;
[ENDFILE]:		BEGIN
			BUFFREE(.FB[FILE$I_BRH]);	!Free the I/O buffers
			BUFFREE(.FB[FILE$O_BRH]);	!
			END;
[FILPRT]:		RETURN SS$_RESIGNAL;	!Don't call ourself forever
[FILFNF,ENDFILE]:	!Can't open ACCESS.USR, or read all of it already
	 		BEGIN
			SIGNALE(FILPRT,FB[FILE$START]);
			RETURN SS$_CONTINUE; !No entry in ACCESS.USR fits
			END;
[OTHERWISE]:		RETURN SS$_RESIGNAL;		!Pass the buck
TES;
END;
END ELUDOM