LCKOBJC: +
  PGM PARM(&P_OBJ &P_WAIT &P_OPMAYCAN)
/* -----------------------------------------------------------------*/
/* Program attemps to lock an object with the requested lock state, */
/* *EXCL, EXCLRD, etc.                                              */
/* If it fails to obtain the lock in the specified time it talks to */
/* the system operator, telling him which job are causing the       */
/* ALCOBJ to fail. Operator can opt to cancel, or retry the ALCOBJ  */
/* for 5, 10, 0r 30 minutes, or the default class wait time.        */
/* -----------------------------------------------------------------*/
/* Use the LCKOBJ command to invoke this program                    */
/* -----------------------------------------------------------------*/
/* 11/24/97 LENNON Original writing                                 */
/* -----------------------------------------------------------------*/
/* 10/05/2001 Sam Lennon. If a non file object is locked *EXCL then */
/*            RTVOBJD to get real library name to put in the        */
/*            message fails. If this occurs, just continue and      */
/*            *LIBL may appear in the message.                      */
/*            Change retry logic to allow entry of varying times.   */
/*            Installed 9/2002.                                     */
/* -----------------------------------------------------------------*/
/* Input parameters */
  DCL VAR(&P_OBJ)      TYPE(*CHAR) LEN(48)    /* Obj & lib */
  DCL VAR(&P_WAIT)     TYPE(*DEC)  LEN(5)     /* Seconds */
  DCL VAR(&P_OPMAYCAN) TYPE(*CHAR) LEN(4)     /* *YES *NO */

/* Variables used in this program */
  DCL VAR(&ORGWAIT)    TYPE(*DEC)  LEN(7)     /* Original wait*/
  DCL VAR(&ELEMC)      TYPE(*CHAR) LEN(2)     /* # elements */
  DCL VAR(&ELEMP)      TYPE(*DEC)  LEN(5)     /* # elements */
  DCL VAR(&JOBTYPE)    TYPE(*CHAR) LEN(1)     /* 1=interactive */
  DCL VAR(&LCKSTATE)   TYPE(*CHAR) LEN(8)     /* *SHRRD, etc */
  DCL VAR(&KEYVAR)     TYPE(*CHAR) LEN(4)     /* messages */
  DCL VAR(&MEMBER)     TYPE(*CHAR) LEN(10)    /* if *FILE */
  DCL VAR(&OBJNAM)     TYPE(*CHAR) LEN(10)    /* Obj name  */
  DCL VAR(&OBJLIB)     TYPE(*CHAR) LEN(10)    /* Obj lib   */
  DCL VAR(&OPMSG)      TYPE(*CHAR) LEN(500)   /* No msg fld passed */
  DCL VAR(&REPLY)      TYPE(*CHAR) LEN(2)     /* Oper Reply */
  DCL VAR(&RETMSG)     TYPE(*CHAR) LEN(200)   /* From GETOBJUSR */
  DCL VAR(&TYPE)       TYPE(*CHAR) LEN(8)     /* Obj type  */
  DCL VAR(&WAIT)       TYPE(*DEC)  LEN(5)     /* Wait as num */
  DCL VAR(&WAITC)      TYPE(*CHAR) LEN(5)     /* Wait as char */
  DCL VAR(&WAITMIN)    TYPE(*DEC)  LEN(5)     /* Wait in mins */
  DCL VAR(&WAITMSG)    TYPE(*CHAR) LEN(20)     /* temp field */

 /* Error Handling Variables */
  DCL VAR(&E_MSGID)    TYPE(*CHAR) LEN(7)
  DCL VAR(&E_MSGF)     TYPE(*CHAR) LEN(10)
  DCL VAR(&E_MSGFLIB)  TYPE(*CHAR) LEN(10)
  DCL VAR(&E_MSGDTA)   TYPE(*CHAR) LEN(100)

/* Catch unmonitored errors */
  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))

/*==== Pre processing of input parameters =========================*/
  /* &P_OBJ is a mixed list:                          */
  /*    1 L2   binary # elements                      */
  /*    3 L10  object name                            */
  /*   13 L10  library                                */
  /*   23 L8   object type                            */
  /*   31 L8   lock state, *EXCL etc.                 */
  /*   39 L10  member, if data base file              */

  /* Get number of elements */
  CHGVAR VAR(&ELEMC) VALUE(%SST(&P_OBJ 1 2))
  CHGVAR VAR(&ELEMP) VALUE(%BIN(&ELEMC))

  /* Extract elements from list.  First 3 are required. */
  /* Obj and lib are considered 1 element */
  CHGVAR VAR(&OBJNAM) VALUE(%SST(&P_OBJ 3 10))
  CHGVAR VAR(&OBJLIB) VALUE(%SST(&P_OBJ 13 10))
  CHGVAR VAR(&TYPE) VALUE(%SST(&P_OBJ 23 8))
  CHGVAR VAR(&LCKSTATE) VALUE(%SST(&P_OBJ 31 8))

  /* Member is optional */
  IF COND(&ELEMP *GT 3) THEN(DO)
      CHGVAR VAR(&MEMBER) VALUE(%SST(&P_OBJ 39 10))
  ENDDO

/* If MEMBER is blank, change to *FIRST. *FIRST is ignored on   */
/* non-file objects, but blanks causes a syntax error in ALCOBJ */
  /* IF COND(&MEMBER *EQ ' ') THEN(DO) */
      /* CHGVAR VAR(&MEMBER) VALUE('*FIRST') */
  /* ENDDO */

/* Set the default wait value                                */
/* Wait 99999 means use *CLS as the wait value on the ALCOBJ */
  IF COND(&P_WAIT = 99999) THEN(DO)
      RTVJOBA TYPE(&JOBTYPE) DFTWAIT(&ORGWAIT)
  ENDDO
  ELSE CMD(DO)
      CHGVAR VAR(&ORGWAIT) VALUE(&P_WAIT)
  ENDDO
  CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)

/*==== Convert *LIBL/*CURLIB into a real name, if possible,========*/
/*     for clarity in operator message. This may fail if the object*/
/*     is already allocated *EXCL.  If so, we just continue.       */
  IF COND(&OBJLIB *EQ '*LIBL') THEN(DO)
      RTVOBJD OBJ(&OBJLIB/&OBJNAM) OBJTYPE(&TYPE) RTNLIB(&OBJLIB)
      MONMSG MSGID(CPF9803) /* Cannot Allocate */
  ENDDO

/* Blank member is syntax error in ALLOBJ, but if you do        */
/* not specify a member it is the same as specifying *FIRST     */
/* so get the *FIRST actual name.                               */
  IF COND((&TYPE *EQ '*FILE') *AND (&MEMBER *EQ ' ') ) THEN(DO)
    RTVMBRD FILE(&OBJLIB/&OBJNAM) RTNMBR(&MEMBER)
  ENDDO

/*=== Attempt to allocate the object ==============================*/
RETRY: +
  CHGVAR VAR(&WAITC) VALUE(&WAIT)
  ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATE &MEMBER)) WAIT(&WAITC)

  /* If fail to obtain lock, then we must analyse the situation */
  MONMSG MSGID(CPF1002) EXEC(DO) /* Not allocated */

      /* If wait is longer than 60 seconds, make minutes for */
      /* message and round up to next minute.                */
      IF COND(&WAIT > 60 *AND &WAIT *NE 0) THEN(DO)
          CHGVAR VAR(&WAITMIN) VALUE((&WAIT + 59) / 60)
      /*  EDTVAR CHROUT(&WAITMSG) NUMINP(&WAITMIN) */
          CHGVAR VAR(&WAITMSG) VALUE(&WAITMIN)
          CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
          IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
          CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' minutes. ')
      ENDDO
      ELSE CMD(DO)
      /*  EDTVAR CHROUT(&WAITMSG) NUMINP(&WAIT)*/
          CHGVAR VAR(&WAITMSG) VALUE(&WAIT)
          CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
          IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
          CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' seconds. ')
      ENDDO

      /* Find out who is using the object.  By now all the   */
      /* locks may have been freed.  If so, retry the ALCOBJ */
      GETOBJUSR OBJECT(&OBJLIB/&OBJNAM) TYPE(&TYPE) MEMBER(&MEMBER) +
         MSGFLD(&RETMSG)
      IF COND(&RETMSG *EQ ' ') THEN(GOTO CMDLBL(RETRY))

      /* Build a message for the operator. */
      CHGVAR VAR(&OPMSG) VALUE(&RETMSG *TCAT '  Waited for ' *CAT +
         &WAITMSG *TCAT '  Please attempt to resolve the conflict, +
         then enter R to retry, or 5 to retry for 5 minutes, 10 to +
         retry for 10 minutes or 30 to retry for 30 minutes.')

      /* If he may cancel the job, let him know */
      IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
          CHGVAR VAR(&OPMSG) VALUE(&OPMSG *TCAT ' (Or enter C to +
             cancel.)')
      ENDDO

      /* Talk to the operator */
TALKTOOP: +
      SNDUSRMSG MSG(&OPMSG) MSGTYPE(*INQ) TOUSR(*REQUESTER) +
         MSGRPY(&REPLY) VALUES(5 10 30 R C)

      /* R = retry for originally specified time  */
      IF COND(&REPLY *EQ 'R') THEN(DO)
          CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
          GOTO CMDLBL(RETRY)
      ENDDO

      /* Send a CPF9898 escape message if operator cancels */
      IF COND(&REPLY *EQ 'C') THEN(DO)
          IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
              SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('PGM +
                 was canceled by a response of C') MSGTYPE(*ESCAPE)
          ENDDO
          ELSE (DO)
             GOTO CMDLBL(TALKTOOP)
          ENDDO
      ENDDO

      /* Else set new specified wait time and retry */
      CHGVAR VAR(&WAIT) VALUE(&REPLY)
      CHGVAR VAR(&WAIT) VALUE(&WAIT * 60)

      GOTO CMDLBL(RETRY)

  ENDDO /* MONMSG CPF1002 */

/*=== If we get this far we have the object locked as requested.===*/

/* End of program */
  GOTO CMDLBL(ENDPGM)

/*=== Error handler - resend any trapped escape message ===========*/
ERROR: +
  RCVMSG MSGTYPE(*LAST) MSGDTA(&E_MSGDTA) MSGID(&E_MSGID) +
     MSGF(&E_MSGF) MSGFLIB(&E_MSGFLIB)
  MONMSG MSGID(CPF0000) /* Just in case */
  SNDPGMMSG MSGID(&E_MSGID) MSGF(&E_MSGFLIB/&E_MSGF) +
     MSGDTA(&E_MSGDTA) MSGTYPE(*ESCAPE)
  MONMSG MSGID(CPF0000) /* Just in case */
ENDPGM: +
  ENDPGM
