MODULE PFILE
	(
	 MAIN = PFILE,
	 %TITLE'Second-level file protection'
	 IDENT = '1-2.0'
	) =

 BEGIN
  !++
  ! FACILITY:		User/management utilities
  !
  ! ABSTRACT:
  !
  !	This program allows files to be protected in such a way as to be able
  !	to circumvent even BYPASS.
  !
  ! ENVIRONMENT:	User and kernel mode
  !
  ! AUTHOR:		Ken A L Coar
  !
  ! MODIFIED BY:
  !
  !	KLC0116	Ken Coar	 2-JAN-1986 08:26
  !		Added documentation, cleaned up a little and made pretty
  !		for distribution. Fixed some more problems with wildcarding
  !		and related-file processing.
  !
  !	KLC0215	Ken Coar	23-FEB-1984
  !		Added wildcard processing and /LOG qualifier.
  !
  !	KLC0019	Ken Coar	15-MAR-1985 08:22
  !		Fixed RMS$_VER error (NAM blocks were overwriting themselves).
  !--

  %SBTTL'Declarations'

  !
  ! SWITCHES:
  !

  SWITCHES
   ADDRESSING_MODE (EXTERNAL = GENERAL, NONEXTERNAL = WORD_RELATIVE);

  !
  ! LINKAGES:
  !
  !	NONE.
  !

  !
  ! INCLUDE FILES:
  !

  LIBRARY 'SYS$LIBRARY:LIB';		! LIB plus STARLET
  LIBRARY 'KEN_LIBRARY:KENLIB';		! Local declarations

  !
  ! FORWARD ROUTINES:
  !
  !	NONE.
  !

  !
  ! EXTERNAL REFERENCES:
  !

  EXTERNAL ROUTINE
   CLI$GET_VALUE,
   CLI$PRESENT,
   ECS$MAXIMISE_ERROR,
   LIB$SYS_FAO,
   LIB_CLI_SIG_TO_RET;

  !
  ! MACROS:
  !
  !	NONE.
  !

  !
  ! EQUATED SYMBOLS:
  !
  !	NONE.
  !

  !
  ! FIELDS:
  !
  !	NONE.
  !

  !
  ! PSECTS:
  !

  RTL_PSECTS (FACILITY=LIB);

  !
  ! OWN STORAGE:
  !

  OWN
   MASK			:	BYTE INITIAL (0),
   NEWLEV		:	BYTE,
   DCHAN		:	WORD,
   ACLEVEL		:	BBLOCK [ATR$S_ACLEVEL],
   ATR			:	BBLOCK [12]
				PRESET(
					[ATR$W_SIZE] = ATR$S_ACLEVEL,
					[ATR$W_TYPE] = ATR$C_ACLEVEL,
					[ATR$L_ADDR] = ACLEVEL
				      ),
   FIB			:	BBLOCK [FIB$C_LENGTH]
				PRESET(
					[FIB$V_WRITE] = 1,
					[FIB$V_FINDFID] = 1
				      ),
   DFIB			:	DESCR (BUFFER=FIB,LENGTH=FIB$C_LENGTH),
   DFILE		:	DESCR (CLASS=DYNAMIC),
   DNEWPROT		:	DESCR (CLASS=DYNAMIC),
   DPROT		:	DESCR (CLASS=DYNAMIC),
   DEVNAM		:	BBLOCK [64],
   DDEVNAM		:	DESCR (BUFFER=DEVNAM),
   DVILST		:	$DVILST(
					(64, DEVNAM, DEVNAM, DDEVNAM)
				       ),
   RES			:	BBLOCK [NAM$C_MAXRSS],
   RRS			:	BBLOCK [NAM$C_MAXRSS],
   PES			:	BBLOCK [NAM$C_MAXRSS],
   PRS			:	BBLOCK [NAM$C_MAXRSS],
   DRS			:	DESCR (BUFFER=PRS),
   DES			:	DESCR (BUFFER=PES),
   RNAM			:	$NAM(
					ESS=NAM$C_MAXRSS,
					RSS=NAM$C_MAXRSS,
					ESA=RES,
					RSA=RRS
				    ),
   PNAM			:	$NAM(
					ESS=NAM$C_MAXRSS,
					RSS=NAM$C_MAXRSS,
					ESA=PES,
					RSA=PRS,
					RLF=RNAM
				    ),
   PFAB			:	$FAB(
					NAM=PNAM
				    ),
   RFAB			:	$FAB(
					FNA=PES,
					NAM=RNAM
				    );

  BIND
   KD_FACILITY		=	%ASCID'PFILE',
   KD_USER		=	%ASCID'U',
   KD_SUPER		=	%ASCID'S',
   KD_EXEC		=	%ASCID'E',
   KD_KERNEL		=	%ASCID'K';

%SBTTL'KERNEL_MODIFY - Actually modify the file'
  GLOBAL ROUTINE KERNEL_MODIFY =
  !++
  ! FUNCTIONAL DESCRIPTION:
  !
  !	This routine is called to modify the access bits in the file header.
  !	It is called in kernel mode so that it cannot fail to access the file
  !	in order to modify the attributes.
  !
  ! CALLING SEQUENCE:
  !
  !	ret-status.wlc.v = $CMKRNL (ROUTIN=KERNEL_MODIFY)
  !
  ! FORMAL PARAMETERS:
  !
  !	NONE.
  !
  ! IMPLICIT INPUTS:
  !
  !	MASK		byte containing ones for the fields to be changed.
  !			Used to erase the old settings in those fields.
  !	NEWLEV		byte containing new access code, ORed into fields
  !			cleared via MASK.
  !	DCHAN		word containing channel assigned to the device.
  !	DFIB		descriptor for File Information Block which is
  !			associated with the file.
  !
  ! IMPLICIT OUTPUTS:
  !
  !	NONE.
  !
  ! COMPLETION STATUS:
  !
  !	SS$_NORMAL		successful completion
  !	other			some error from $QIOW
  !
  ! SIDE EFFECTS:
  !
  !	File access protection changed to reflect new field settings.
  !
  !--
   BEGIN
    LOCAL
     IOSTAT		:	_IOSB,
     STATUS		:	LONG;
    STATUS = $QIOW(
			CHAN=.DCHAN,
			EFN=32,
			FUNC=(IO$_ACCESS OR IO$M_ACCESS),
			IOSB=IOSTAT,
			P1=DFIB,
			P5=ATR
		  );
    IF .STATUS THEN STATUS = .IOSTAT [IOSB_W_STATUS];
    %CHECK ();
    ACLEVEL = .ACLEVEL AND (NOT .MASK);
    ACLEVEL = .ACLEVEL OR .NEWLEV;
    STATUS = $QIOW(
			CHAN=.DCHAN,
			EFN=32,
			FUNC=IO$_DEACCESS,
			IOSB=IOSTAT,
			P1=DFIB,
			P5=ATR
		  );
    IF .STATUS THEN STATUS = .IOSTAT [IOSB_W_STATUS];
    RETURN .STATUS;
   END;

%SBTTL'SETMASK - Build mask from command line'
  GLOBAL ROUTINE SETMASK(
				VALUE,
				OFFSET
			) =
  !++
  ! FUNCTIONAL DESCRIPTION:
  !
  !	This routine builds the access mask at the specified offset, which
  !	determines the access type. The new mask for that type is ORed into the
  !	existing mask.
  !
  ! CALLING SEQUENCE:
  !
  !	ret-status.wlc.v = SETMASK (value.rb.v, offset.rb.v)
  !
  ! FORMAL PARAMETERS:
  !
  !	VALUE		byte character indicating the mode. Passed by value.
  !	OFFSET		byte count of bit positions to shift before inserting
  !			new mask value. Passed by value.
  !
  ! IMPLICIT INPUTS:
  !
  !	MASK		byte containing ones for those bits to be replaced.
  !	NEWLEV		byte containing the current setting of the mode
  !			protection.
  !
  ! IMPLICIT OUTPUTS:
  !
  !	MASK		new field inserted into mask specification.
  !	NEWLEV		new mode protection.
  !
  ! COMPLETION STATUS:
  !
  !	SS$_NORMAL		successful completion
  !	SS$_BADPARAM		user specified something other than U, S, E,
  !				or K
  !
  ! SIDE EFFECTS:
  !
  !	NONE.
  !
  !--
   BEGIN
    LOCAL
     NEWBITS		:	LONG;
    MASK = .MASK OR %B'11'^.OFFSET;
    SELECTONE .VALUE OF
     SET
      ['U']		:	NEWBITS = %B'00000000';
      ['S']		:	NEWBITS = %B'00000001';
      ['E']		:	NEWBITS = %B'00000010';
      ['K']		:	NEWBITS = %B'00000011';
      [OTHERWISE]	:	RETURN SS$_BADPARAM;
     TES;
    NEWBITS = .NEWBITS ^ .OFFSET;
    NEWLEV = .NEWLEV OR .NEWBITS;
    RETURN SS$_NORMAL;
   END;

%SBTTL'PFILE - Main program'
  GLOBAL ROUTINE PFILE =
  !++
  ! FUNCTIONAL DESCRIPTION:
  !
  !	This is the main program. It parses the command line, and then finds
  !	all files specified and applies the new protection to them.
  !
  ! CALLING SEQUENCE:
  !
  !	Called by CLI as main entry point.
  !
  ! FORMAL PARAMETERS:
  !
  !	NONE.
  !
  ! IMPLICIT INPUTS:
  !
  !	Called from DCL.
  !
  ! IMPLICIT OUTPUTS:
  !
  !	NONE.
  !
  ! COMPLETION STATUS:
  !
  !	SS$_NORMAL		successful completion
  !	SS$_BADPARAM		mode other than U, S, E, or K was specified
  !
  ! SIDE EFFECTS:
  !
  !	File protections changed.
  !
  !--
   BEGIN
    LOCAL
     LOGIT		:	BYTE INITIAL (0),
     FINALSTATUS	:	LONG INITIAL (SS$_NORMAL),
     IOSTAT		:	_IOSB,
     STATUS		:	LONG;
    ENABLE LIB_CLI_SIG_TO_RET;
    LOGIT = CLI$PRESENT (%ASCID'LOG');
    !
    !	Build new value for access protection mask.
    !
    IF CLI$GET_VALUE (%ASCID'READ', DNEWPROT) THEN
     %CHECK (SETMASK (CH$RCHAR (.DNEWPROT [DSC$A_POINTER]), 0));
    IF CLI$GET_VALUE (%ASCID'WRITE', DNEWPROT) THEN
     %CHECK (SETMASK (CH$RCHAR (.DNEWPROT [DSC$A_POINTER]), 2));
    IF CLI$GET_VALUE (%ASCID'EXECUTE', DNEWPROT) THEN
     %CHECK (SETMASK (CH$RCHAR (.DNEWPROT [DSC$A_POINTER]), 4));
    IF CLI$GET_VALUE (%ASCID'DELETE', DNEWPROT) THEN
     %CHECK (SETMASK (CH$RCHAR (.DNEWPROT [DSC$A_POINTER]), 6));
    !
    !	Process all files on the command line.
    !
    WHILE CLI$GET_VALUE (%ASCID'P1', DFILE) DO
     BEGIN
      PFAB [FAB$B_FNS] = .DFILE [DSC$W_LENGTH];
      PFAB [FAB$L_FNA] = .DFILE [DSC$A_POINTER];
      %CHECK ($PARSE (FAB=PFAB));
      DES [DSC$W_LENGTH] = .PNAM [NAM$B_ESL];
      RFAB [FAB$B_FNS] = .PNAM [NAM$B_ESL];
      $PARSE (FAB=RFAB);
      RNAM [NAM$B_RSL] = .RNAM [NAM$B_ESL];
      CH$MOVE (.RNAM [NAM$B_ESL], RES, RRS);
      STATUS = $GETDVIW (DEVNAM=DES, IOSB=IOSTAT, ITMLST=DVILST, EFN=32);
      IF .STATUS THEN STATUS = .IOSTAT [IOSB_W_STATUS];
      %CHECK ();
      %CHECK ($ASSIGN (CHAN=DCHAN, DEVNAM=DDEVNAM));
      !
      !	Process all files that match the current value of P1, which may contain
      !	wildcards.
      !
      WHILE (STATUS = $SEARCH (FAB=PFAB)) NEQ RMS$_NMF DO
       BEGIN
        LOCAL
	 MESSAGE		:	VECTOR [6, LONG]
					PRESET(
						[0] = 3,
						[1] = SHR$_PROTECTED OR 3^16,
						[2] = 2,
						[3] = DRS,
						[4] = DPROT
					      );
        DRS [DSC$W_LENGTH] = .PNAM [NAM$B_RSL];
        IF NOT .STATUS THEN
	 BEGIN
	  MESSAGE [1] = SHR$_OPENIN OR 3^16;
	  IF .DRS [DSC$W_LENGTH] EQL 0 THEN
	   IF .DES [DSC$W_LENGTH] NEQ 0
	    THEN MESSAGE [3] = DES
	    ELSE MESSAGE [3] = DFILE;
	  MESSAGE [4] = .PFAB [FAB$L_STS];
	  MESSAGE [5] = .PFAB [FAB$L_STV];
	  MESSAGE [0] = 5;
	  $PUTMSG (FACNAM=KD_FACILITY, MSGVEC=MESSAGE);
	  FINALSTATUS = ECS$MAXIMISE_ERROR (FINALSTATUS, MESSAGE [1]);
	  EXITLOOP;
	 END;
	!
	!	Go change the protection.
	!
        CH$MOVE (6, PNAM [NAM$W_DID], FIB [FIB$W_DID]);
        CH$MOVE (6, PNAM [NAM$W_FID], FIB [FIB$W_FID]);
        STATUS = $CMKRNL (ROUTIN=KERNEL_MODIFY);
	IF NOT .STATUS THEN
	 BEGIN
	  MESSAGE [1] = SHR$_OPENIN OR 3^16;
	  MESSAGE [4] = .STATUS;
	  MESSAGE [0] = 4;
	 END;
	!
	!	Write out a message if he requested it, or if it is incumbent
	!	upon us to do so implicitly because we got an error.
	!
	IF .LOGIT OR NOT .STATUS THEN
	 BEGIN
	  IF .STATUS THEN
	   BEGIN
	    !
	    !	If we're here without an error, it's because he asked us to
	    !	log all changes. Format the new protection mask for him.
	    !
	    BBLOCK [MESSAGE [1],STS$V_SEVERITY] = STS$K_SUCCESS;
	    LIB$SYS_FAO(
			%ASCID'(R:!AS,W:!AS,E:!AS,D:!AS)',
			0,
			DPROT,
			(SELECTONE .ACLEVEL <0,2,0> OF
			  SET
			   [0]		:	KD_USER;
			   [1]		:	KD_SUPER;
			   [2]		:	KD_EXEC;
			   [3]		:	KD_KERNEL;
			  TES),
			(SELECTONE .ACLEVEL <2,2,0> OF
			  SET
			   [0]		:	KD_USER;
			   [1]		:	KD_SUPER;
			   [2]		:	KD_EXEC;
			   [3]		:	KD_KERNEL;
			  TES),
			(SELECTONE .ACLEVEL <4,2,0> OF
			  SET
			   [0]		:	KD_USER;
			   [1]		:	KD_SUPER;
			   [2]		:	KD_EXEC;
			   [3]		:	KD_KERNEL;
			  TES),
			(SELECTONE .ACLEVEL <6,2,0> OF
			  SET
			   [0]		:	KD_USER;
			   [1]		:	KD_SUPER;
			   [2]		:	KD_EXEC;
			   [3]		:	KD_KERNEL;
			  TES)
		       );
	   END;
	  $PUTMSG (FACNAM=KD_FACILITY, MSGVEC=MESSAGE);
	 END;
	FINALSTATUS = ECS$MAXIMISE_ERROR (FINALSTATUS, STATUS);
       END;
      %CHECK ($DASSGN (CHAN=.DCHAN));
     END;
    !
    !	If we had any problems at all, we let him know by returning the worst
    !	error we encountered.
    !
    RETURN .FINALSTATUS OR STS$M_INHIB_MSG;
   END;

 END
ELUDOM