MODULE LOCK
	(
	 MAIN = LOCK,
	 %TITLE'Lock resource at DCL level'
	 IDENT = '1-0.0'
	) =

 BEGIN
  !++
  ! FACILITY:		User utilities
  !
  ! ABSTRACT:
  !
  !	This program allows the user to lock resources using supervisor-mode
  !	locks, which will not be dequeued upon image rundown.
  !
  ! ENVIRONMENT:	User mode, kernel mode, CMKRNL required,
  !			possibly SYSLCK
  !
  ! AUTHOR:		Ken A L Coar
  !
  ! MODIFIED BY:
  !
  !	KLC0178	Ken Coar	 1-APR-1986 08:22
  !		Genesis.
  !--

  %SBTTL'Declarations'

  !
  ! SWITCHES:
  !

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

  !
  ! LINKAGES:
  !
  !	NONE.
  !

  !
  ! INCLUDE FILES:
  !

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

  !
  ! FORWARD ROUTINES:
  !

  FORWARD ROUTINE
   EXIT_HANDLER			:	INTERNAL_CALL,
   KERNEL_CANCEL		:	INTERNAL_CALL,
   KERNEL_ENQ			:	INTERNAL_CALL,
   KERNEL_POST			:	INTERNAL_CALL;

  !
  ! EXTERNAL REFERENCES:
  !

  EXTERNAL ROUTINE
   CLI$GET_VALUE,
   CLI$PRESENT,
   LIB$GET_EF,
   LIB$LOOKUP_KEY,
   LIB$SYS_FAO,
   LIB_CLI_SIG_TO_RET;

  EXTERNAL LITERAL
   LOCK_OBTAINED,
   LOCK_RELEASED,
   LOCK_CONVERTED,
   LOCK_WAIT,
   LOCK_CANCELLED,
   LOCK_NOTLOCKED,
   LOCK_NOWAIT;

  !
  ! MACROS:
  !
  !	NONE.
  !

  !
  ! EQUATED SYMBOLS:
  !
  !	NONE.
  !

  !
  ! FIELDS:
  !

  MDL_STRUCT (OP);
  MDL_FIELD (FLAGS, L, );
  MDL_BIT(
		MASK, ,
		(CONVERT, ),
		(QUEUED, ),
		(SYSLOCK, ),
		(RELEASE, ),
		(WAIT, ),
		(LOG, )
	 );
  MDL_FIELD (MODE, B, );
  MDL_FIELD (EF, L, );
  MDL_LENGTH (LENGTH);
  MDL_END;

  !
  ! PSECTS:
  !

  RTL_PSECTS (FACILITY=LIB);

  !
  ! OWN STORAGE:
  !

  OWN
   OP			:	BBLOCK [OP_K_LENGTH]
				INITIAL (REP OP_K_LENGTH OF BYTE (0)),
   LKSTAT		:	_LKSB,
   ESTATUS		:	LONG,
   EBLOCK		:	VECTOR [4, LONG]
				PRESET(
					[1] = EXIT_HANDLER,
					[2] = 1,
					[3] = ESTATUS
				      ),
   DSCR			:	DESCR (CLASS=DYNAMIC),
   DRESOURCE		:	DESCR (CLASS=DYNAMIC),
   DLNAME		:	DESCR (CLASS=DYNAMIC),
   DMODE		:	DESCR (CLASS=DYNAMIC),
   DOMODE		:	DESCR (CLASS=DYNAMIC),
   MESSAGE		:	VECTOR [10, LONG];

  BIND
   KD_P1		=	%ASCID'P1',
   KD_SCOPE		=	%ASCID'SCOPE',
   KD_MODE		=	%ASCID'MODE',
   KD_RELEASE		=	%ASCID'RELEASE',
   KD_WAIT		=	%ASCID'WAIT',
   KD_LOG		=	%ASCID'LOG',
   KD_LNAME		=	%ASCID'LOCK_!AS',
   KD_LTABLE		=	%ASCID'LNM$PROCESS',
   KD_AF		=	%ASCID'!AF',
   KR_MODES		=	$KEY_TABLE(
						('CREAD', LCK$K_CRMODE),
						('CWRITE', LCK$K_CWMODE),
						('EXCLUSIVE', LCK$K_EXMODE),
						('NULL', LCK$K_NLMODE),
						('PREAD', LCK$K_PRMODE),
						('PWRITE', LCK$K_PWMODE)
					  ),
   KR_SCOPES		=	$KEY_TABLE(
						('GROUP', 0),
						('SYSTEM', 1)
					  );

%SBTTL'EXIT_HANDLER - Cancel request on program abort'
  ROUTINE EXIT_HANDLER : INTERNAL_CALL =
  !++
  ! FUNCTIONAL DESCRIPTION:
  !
  !	This routine is called as an exit handler when the program aborts
  !	unexpectedly. His task is to cancel an outstanding $ENQ request
  !	in kernel mode so it doesn't complete after the program has run down.
  !
  ! CALLING SEQUENCE:
  !
  !	EXIT_HANDLER ()
  !
  ! FORMAL PARAMETERS:
  !
  !	NONE.
  !
  ! IMPLICIT INPUTS:
  !
  !	OP control block describes how far we've gotten and what we're doing.
  !
  ! IMPLICIT OUTPUTS:
  !
  !	NONE.
  !
  ! COMPLETION STATUS:
  !
  !	SS$_NORMAL		successful completion
  !
  ! SIDE EFFECTS:
  !
  !	Any outstanding lock request gets canned.
  !
  !--
   BEGIN
    LOCAL
     STATUS		:	LONG;
    IF NOT .OP [OP_V_QUEUED] THEN RETURN SS$_NORMAL;
    %CHECK (STATUS = $CMKRNL (ROUTIN=KERNEL_CANCEL));
    !
    !	Now, it's possible that the request was granted in the meantime,
    !	so we shouldn't display the 'cancelled' message. We should, however,
    !	ensure that the logical name gets defined, because it obviously
    !	hasn't if QUEUED is set and the lock was granted.
    !
    IF .STATUS EQL SS$_CANCELGRANT THEN RETURN KERNEL_POST ();
    !
    !	All right, we really cancelled an outstanding request. Tell the
    !	user about it, and exit with the appropriate status.
    !
    MESSAGE [0] = 4;
    MESSAGE [1] = LOCK_CANCELLED;
    MESSAGE [2] = 2;
    MESSAGE [3] = 0;
    MESSAGE [4] = DRESOURCE;
    $PUTMSG (MSGVEC=MESSAGE);
    RETURN $EXIT (CODE=.MESSAGE [1] OR STS$M_INHIB_MSG);
   END;

%SBTTL'KERNEL_CANCEL - Cancel outstanding request'
  ROUTINE KERNEL_CANCEL : INTERNAL_CALL =
  !++
  ! FUNCTIONAL DESCRIPTION:
  !
  !	This routine executes in kernel mode, and dequeues any outstanding
  !	request on the lock block. We have to run in a higher mode than user
  !	because the locks are requested in supervisor mode.
  !
  ! CALLING SEQUENCE:
  !
  !	$CMKRNL (ROUTIN=KERNEL_CANCEL)
  !
  ! FORMAL PARAMETERS:
  !
  !	NONE.
  !
  ! IMPLICIT INPUTS:
  !
  !	LKSTAT is the lock block.
  !
  ! IMPLICIT OUTPUTS:
  !
  !	NONE.
  !
  ! COMPLETION STATUS:
  !
  !	SS$_NORMAL		successful completion
  !	SS$_CANCELGRANT		success; lock was granted before we could
  !				abort the request
  !
  ! SIDE EFFECTS:
  !
  !	Any outstanding lock requests are cancelled.
  !
  !--
   BEGIN
    RETURN $DEQ(
		LKID=.LKSTAT [LKSB_L_LOCKID],
		ACMODE=PSL$C_SUPER,
		FLAGS=LCK$M_CANCEL
	       );
   END;

%SBTTL'KERNEL_ENQ - Workhorse routine'
  ROUTINE KERNEL_ENQ : INTERNAL_CALL =
  !++
  ! FUNCTIONAL DESCRIPTION:
  !
  !	This routine is called by the main program once all the parameters
  !	have been determined. We don't have to run in kernel mode, but since
  !	that's the way we're protecting the logical name containing the
  !	lock block, it's just as well.
  !
  !	We do an $ENQ rather than an $ENQW because we want to be able to tell
  !	the user we're waiting for his lock.
  !
  ! CALLING SEQUENCE:
  !
  !	$CMKRNL (ROUTIN=KERNEL_ENQ)
  !
  ! FORMAL PARAMETERS:
  !
  !	NONE.
  !
  ! IMPLICIT INPUTS:
  !
  !	OP control block contains flags.
  !
  ! IMPLICIT OUTPUTS:
  !
  !	NONE.
  !
  ! COMPLETION STATUS:
  !
  !	SS$_NORMAL		successful completion
  !	other			status from $DEQ or $ENQ
  !
  ! SIDE EFFECTS:
  !
  !	NONE.
  !
  !--
   BEGIN
    LOCAL
     ENQFLAGS		:	LONG INITIAL (0),
     STATUS		:	LONG;
    IF .OP [OP_V_WAIT]
     THEN ENQFLAGS = .ENQFLAGS OR LCK$M_SYNCSTS
     ELSE ENQFLAGS = .ENQFLAGS OR LCK$M_NOQUEUE;
    IF .OP [OP_V_SYSLOCK] THEN ENQFLAGS = .ENQFLAGS OR LCK$M_SYSTEM;
    IF .OP [OP_V_CONVERT] THEN ENQFLAGS = .ENQFLAGS OR LCK$M_CONVERT;
    IF .OP [OP_V_RELEASE]
     THEN STATUS = $DEQ (LKID=.LKSTAT [LKSB_L_LOCKID], ACMODE=PSL$C_SUPER)
     ELSE
      BEGIN
       STATUS = $ENQ(
			EFN=.OP [OP_L_EF],
			LKMODE=.OP [OP_B_MODE],
			LKSB=LKSTAT,
			FLAGS = .ENQFLAGS,
			RESNAM=DLNAME,
			ACMODE=PSL$C_SUPER
		    );
       OP [OP_V_QUEUED] = 1;
      END;
    RETURN .STATUS;
   END;

%SBTTL'KERNEL_POST - Post process logical name'
  ROUTINE KERNEL_POST : INTERNAL_CALL =
  !++
  ! FUNCTIONAL DESCRIPTION:
  !
  !	This routine is called to either (re)set or remove the logical
  !	name containing the lock status block.
  !
  ! CALLING SEQUENCE:
  !
  !	$CMKRNL (ROUTIN=KERNEL_POST)
  !
  ! FORMAL PARAMETERS:
  !
  !	NONE.
  !
  ! IMPLICIT INPUTS:
  !
  !	OP control block, DLNAME descriptor of lock name.
  !
  ! IMPLICIT OUTPUTS:
  !
  !	NONE.
  !
  ! COMPLETION STATUS:
  !
  !	SS$_NORMAL		successful completion
  !
  ! SIDE EFFECTS:
  !
  !	Logical name described by DLNAME changed or deleted.
  !
  !--
   BEGIN
    LOCAL
     LNMLST		:	BBLOCK [28] INITIAL (REP 28 OF BYTE (0));
    IF .OP [OP_V_RELEASE] THEN
     RETURN $DELLNM(
			TABNAM=KD_LTABLE,
			LOGNAM=DLNAME,
			ACMODE=%REF(PSL$C_KERNEL)
		   );
    LNMLST [0,0,16,0] = LKSB_K_LENGTH;
    LNMLST [2,0,16,0] = LNM$_STRING;
    LNMLST [4,0,32,0] = LKSTAT;
    LNMLST [8,0,32,0] = LKSB_K_LENGTH;
    LNMLST [12,0,16,0] = .DMODE [DSC$W_LENGTH];
    LNMLST [14,0,16,0] = LNM$_STRING;
    LNMLST [16,0,32,0] = .DMODE [DSC$A_POINTER];
    RETURN $CRELNM(
			ATTR=%REF(
					LNM$M_NO_ALIAS OR
					LNM$M_CONFINE
				 ),
			TABNAM=KD_LTABLE,
			LOGNAM=DLNAME,
			ACMODE=%REF(PSL$C_KERNEL),
			ITMLST=LNMLST
		  );
   END;

%SBTTL'LOCK - Main program'
  GLOBAL ROUTINE LOCK =
  !++
  ! FUNCTIONAL DESCRIPTION:
  !
  !	This is the main program. It interrogates the command line to find out
  !	what needs to be done, and calls routines appropriately.
  !
  ! CALLING SEQUENCE:
  !
  !	Called as main routine by DCL.
  !
  ! FORMAL PARAMETERS:
  !
  !	NONE.
  !
  ! IMPLICIT INPUTS:
  !
  !	Must be running under DCL command interpreter.
  !
  ! IMPLICIT OUTPUTS:
  !
  !	NONE.
  !
  ! COMPLETION STATUS:
  !
  !	LOCK_OBTAINED		success; requested lock obtained
  !	LOCK_RELEASED		success; lock relinquished
  !	LOCK_CONVERTED		success; lock mode changed
  !	LOCK_NOWAIT		failure; /NOWAIT was specified and lock was
  !				not immediately obtainable
  !	LOCK_CANCELLED		failure; program was aborted (possibly by ^Y)
  !				before the lock was granted. Note that this
  !				is returned by EXIT_HANDLER, not the mainline
  !				code.
  !
  ! SIDE EFFECTS:
  !
  !	Lock at the appropriate mode either taken out or released on the
  !	specified resource, or no change.
  !
  !--
   BEGIN
    LOCAL
     LNMLST		:	BBLOCK [40] INITIAL (REP 40 OF BYTE (0)),
     LNMEQV		:	BBLOCK [255],
     LNMLEN		:	WORD,
     LNMOMODE		:	BBLOCK [255],
     LNMMLEN		:	WORD,
     STATUS		:	LONG;
    ENABLE LIB_CLI_SIG_TO_RET;
    !
    !	Get the resource name, and build up the internal name from it.
    !
    %CHECK ($DCLEXH (DESBLK=EBLOCK));
    %CHECK (CLI$GET_VALUE (KD_P1, DRESOURCE));
    %CHECK (LIB$SYS_FAO (KD_LNAME, 0, DLNAME, DRESOURCE));
    !
    !	See if this is an existing resource we already have locked.
    !
    LNMLST [0,0,16,0] = 255;
    LNMLST [2,0,16,0] = LNM$_STRING;
    LNMLST [4,0,32,0] = LNMEQV;
    LNMLST [8,0,32,0] = LNMLEN;
    LNMLST [12,0,16,0] = 4;
    LNMLST [14,0,16,0] = LNM$_INDEX;
    LNMLST [16,0,32,0] = UPLIT (1);
    LNMLST [24,0,16,0] = 255;
    LNMLST [26,0,16,0] = LNM$_STRING;
    LNMLST [28,0,32,0] = LNMOMODE;
    LNMLST [32,0,32,0] = LNMMLEN;
    STATUS = $TRNLNM(
			TABNAM=KD_LTABLE,
			LOGNAM=DLNAME,
			ACMODE=%REF(PSL$C_KERNEL),
			ITMLST=LNMLST
		    );
    IF .STATUS NEQ SS$_NOLOGNAM THEN
     BEGIN
      %CHECK ();
      !
      !	If the length of the equivalence name is not equal to the size of a
      !	lock block, then we didn't define the name and we must abort.
      !
      IF .LNMLEN NEQ LKSB_K_LENGTH THEN RETURN SS$_BUGCHECK;
      !
      !	Copy the lock block from the logical name into real storage for future
      !	reference.
      !
      CH$MOVE (LKSB_K_LENGTH, LNMEQV, LKSTAT);
      !
      !	Store the name of the mode it is currently locked at; if this is NOT a
      !	release request, we will note the change in modes in the conversion
      !	message.
      !
      %CHECK (LIB$SYS_FAO (KD_AF, 0, DOMODE, .LNMMLEN, LNMOMODE));
      OP [OP_V_CONVERT] = 1;
     END;
    !
    !	Get flags from the command qualifiers. Note that no assumptions are
    !	made in the program; what actions are default are determined SOLELY
    !	by the command definition.
    !
    %CHECK (LIB$GET_EF (OP [OP_L_EF]));
    OP [OP_V_LOG] = CLI$PRESENT (KD_LOG);
    OP [OP_V_RELEASE] = CLI$PRESENT (KD_RELEASE);
    !
    !	We have to tell him about his mistake if he tries to release what he
    !	doesn't have.
    !
    IF .OP [OP_V_RELEASE] AND (NOT .OP [OP_V_CONVERT]) THEN
     BEGIN
      MESSAGE [0] = 3;
      MESSAGE [1] = LOCK_NOTLOCKED;
      MESSAGE [2] = 1;
      MESSAGE [3] = DRESOURCE;
      $PUTMSG (MSGVEC=MESSAGE);
      RETURN .MESSAGE [1] OR STS$M_INHIB_MSG;
     END;
    !
    !	Special actions if he's trying to release an existing lock.
    !
    IF NOT .OP [OP_V_RELEASE] THEN
     BEGIN
      OP [OP_V_WAIT] = CLI$PRESENT (KD_WAIT);
      %CHECK (CLI$GET_VALUE (KD_MODE, DMODE));
      %CHECK (LIB$LOOKUP_KEY (DMODE, KR_MODES, STATUS, DMODE));
      OP [OP_B_MODE] = .STATUS;
      %CHECK (CLI$GET_VALUE (KD_SCOPE, DSCR));
      %CHECK (LIB$LOOKUP_KEY (DSCR, KR_SCOPES, STATUS, DSCR));
      OP [OP_V_SYSLOCK] = .STATUS;
     END;
    !
    !	Setup all done; change to kernel mode (to get locks at supervisor
    !	mode) and twiddle things appropriately.
    !
    STATUS = $CMKRNL (ROUTIN=KERNEL_ENQ);
    !
    !	Now handle the return status.
    !
    !
    !	We'll get the NOTQUEUED status only if he specified /NOWAIT; we have
    !	no other interest in anything at all, since we were obviously
    !	unsuccessful.
    !
    IF .STATUS EQL SS$_NOTQUEUED THEN
     BEGIN
      MESSAGE [0] = 4;
      MESSAGE [1] = LOCK_NOWAIT;
      MESSAGE [2] = 2;
      MESSAGE [3] = 0;
      MESSAGE [4] = DRESOURCE;
      $PUTMSG (MSGVEC=MESSAGE);
      RETURN .MESSAGE [1] OR STS$M_INHIB_MSG;
     END;
    !
    !	Now for the hard part. If there was an error doing a $DEQ, we WILL NOT
    !	do anything special about displaying it.
    !
    IF .OP [OP_V_RELEASE]
     THEN
      BEGIN
       !
       !	See if there was an error. On a release, we just return the
       !	error message.
       !
       %CHECK ();
       MESSAGE [0] = 5;
       MESSAGE [1] = LOCK_RELEASED;
       MESSAGE [2] = 3;
       MESSAGE [3] = 0;
       MESSAGE [4] = DOMODE;
       MESSAGE [5] = DRESOURCE;
      END
     ELSE
      BEGIN
       IF (.STATUS EQL SS$_NORMAL) AND .OP [OP_V_WAIT] THEN
        BEGIN
	 !
	 !	If he wanted to wait for his lock, and he wanted to know if we
	 !	had to do so (/LOG present), then tell him what he wants to
	 !	know.
	 !
         MESSAGE [0] = 4;
         MESSAGE [1] = LOCK_WAIT;
         MESSAGE [2] = 2;
	 MESSAGE [3] = 0;
         MESSAGE [4] = DRESOURCE;
         IF .OP [OP_V_LOG] THEN $PUTMSG (MSGVEC=MESSAGE);
	 !
	 !	No do like we said we were going to, and wait for his request.
	 !
         $SYNCH (EFN=.OP [OP_L_EF], IOSB=LKSTAT);
        END;
       !
       !	When we get here, we have succeeded. We have either gotten the
       !	lock, converted it, or released it. Say the right things to
       !	the l'user. We basically just set up the message vector
       !	specific to each case. It will be displayed, if appropriate,
       !	at the end of this sequence.
       !
       IF .OP [OP_V_CONVERT]
        THEN
         BEGIN
          MESSAGE [0] = 6;
          MESSAGE [1] = LOCK_CONVERTED;
          MESSAGE [2] = 4;
	  MESSAGE [3] = 0;
          MESSAGE [4] = DOMODE;
          MESSAGE [5] = DRESOURCE;
          MESSAGE [6] = DMODE;
         END
        ELSE
         BEGIN
          MESSAGE [0] = 5;
          MESSAGE [1] = LOCK_OBTAINED;
          MESSAGE [2] = 3;
	  MESSAGE [3] = 0;
          MESSAGE [4] = DMODE;
          MESSAGE [5] = DRESOURCE;
         END;
      END;
    IF .OP [OP_V_LOG] THEN $PUTMSG (MSGVEC=MESSAGE);
    %CHECK ($CMKRNL (ROUTIN=KERNEL_POST));
    !
    !	Turn off the QUEUED flag because we've completed everything. Otherwise,
    !	the exit handler will be given confusing instructions. We only want him
    !	to do things if we fell out before getting here.
    !
    OP [OP_V_QUEUED] = 0;
    RETURN .MESSAGE [1] OR STS$M_INHIB_MSG;
   END;

 END
ELUDOM