midrange.com code scratchpad
Name:
DlwUpdProd
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
03/06/2013 11:20:39 pm
IP:
Logged
Description:
A CLP that performs a Start Debug with Update Production files setting turned off. The likely error conditions of "job already being serviced" and "debug already active in this job" are both ignored; no record of the exception is left in the joblog, but that is easily modified. Other errors, e.g. authority {CPF0001 with diagnostic CPD0032}, would be resignaled to the invoker.
This CLP would be used in place of STRDBG UPDPROD(*NO) requests used in code, so the invoking program need not code for exceptions; i.e. if any exception occurs, the default exception handler for the invoker should get invoked so the condition can be reviewed. Using a separate CLP also allows the code to be created to adopt necessary authority to enable STRDBG, if desirable.
A default CMD {no parameters} could be created to invoke this CLP if more desirable than a CALL in the invoker. But be sure to use MODE(*ALL) on the CRTCMD request.
Code:
  1. pgm
  2. dcl &xk *char 04 /* exception message key */
  3. dcl &xi *char 07 /* exception msg msgid   */
  4. dcl &mk *char 04 /* prior msg msgkey      */
  5. dcl &mi *char 07 /* prior message msgid   */
  6. dcl &ec *char  8 /* errcde parm */ value(x'0000000000000000')
  7. dcl &mt *char 10 /* movpm: msg type array */
  8. dcl &mc *int   4 /* movpm: msg type count */ value(0)
  9. dcl &se *char 10 /* movpm: stack entry */ value('*')
  10. dcl &sc *int    4/* movpm: stack count */ value(1)
  11.   monmsg cpf0000 exec(goto badthing)
  12. mainpgm:
  13.   *system/strdbg pgm(*none) updprod(*no) opmsrc(*no) srvpgm(*none) +
  14.        class(*none) dspmodsrc(*pgmdep) srcdbgpgm(*sysdft)          +
  15.        unmonpgm(*none) /* let MAXTRC() default */
  16. /* @DBG Note: cpf1992 is not documented, but is possible Excm */
  17.   monmsg (cpf1999 cpf0001) exec(do)
  18.     rcvmsg pgmq(*same (*)) msgq(*pgmq) msgtype(*excp) rmv(*no) +
  19.            keyvar(&xk) msgid(&xi)
  20.     rcvmsg pgmq(*same (*)) msgq(*pgmq) msgtype(*prv ) rmv(*no) +
  21.            msgkey(&xk) keyvar(&mk) msgid(&mi) /* prior msg */
  22.     if cond( ( &xi *eq 'CPF1999' *and &mi *eq 'CPF1937' )   +
  23.      /* already being serviced; just ignore and clear error */ +
  24.        *or   ( &xi *eq 'CPF0001' *and &mi *eq 'CPD0039' ) ) +
  25.      /* debug already active;   just ignore and clear error */ +
  26.       then(do)
  27.      rmvmsg pgmq(*same (*)) msgq(*pgmq) clear(*old) rmvexcp(*yes)
  28.     enddo
  29.     else do /* move the prior msg to caller; resend *excm */
  30.      if cond(&mi *ne ' ') then(do) /* a prior msg was found */
  31.       call qmhmovpm (&mk &mt &mc &se &sc &ec)
  32.      enddo
  33.      /* resignal the cpf1999 or cpf0001 or the unexpected */
  34.      call qmhrsnem (&xk &ec)
  35.     enddo /* end-else do; resignal exits: RTX(*) */
  36.   enddo /* end-monmsg cpf1999 */
  37.   /* no error, debug started with updprod(*no) */
  38. mainend:
  39.   return
  40. badthing: /* move any diags and resend the *excm */
  41.    chgvar &mt '*DIAG' /* move diag message        */
  42.    chgvar &mc 1       /* Diag is only msg type    */
  43.    chgvar &mk '    '  /* move by type, not by key */
  44.    call qmhmovpm (&mk &mt &mc &se &sc &ec)
  45.    call qmhrsnem (&xk &ec)
  46. endpgm
  47.  
© 2004-2019 by midrange.com generated in 0.008s valid xhtml & css