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:
- pgm
- dcl &xk *char 04 /* exception message key */
- dcl &xi *char 07 /* exception msg msgid */
- dcl &mk *char 04 /* prior msg msgkey */
- dcl &mi *char 07 /* prior message msgid */
- dcl &ec *char 8 /* errcde parm */ value(x'0000000000000000')
- dcl &mt *char 10 /* movpm: msg type array */
- dcl &mc *int 4 /* movpm: msg type count */ value(0)
- dcl &se *char 10 /* movpm: stack entry */ value('*')
- dcl &sc *int 4/* movpm: stack count */ value(1)
- monmsg cpf0000 exec(goto badthing)
- mainpgm:
- *system/strdbg pgm(*none) updprod(*no) opmsrc(*no) srvpgm(*none) +
- class(*none) dspmodsrc(*pgmdep) srcdbgpgm(*sysdft) +
- unmonpgm(*none) /* let MAXTRC() default */
- /* @DBG Note: cpf1992 is not documented, but is possible Excm */
- monmsg (cpf1999 cpf0001) exec(do)
- rcvmsg pgmq(*same (*)) msgq(*pgmq) msgtype(*excp) rmv(*no) +
- keyvar(&xk) msgid(&xi)
- rcvmsg pgmq(*same (*)) msgq(*pgmq) msgtype(*prv ) rmv(*no) +
- msgkey(&xk) keyvar(&mk) msgid(&mi) /* prior msg */
- if cond( ( &xi *eq 'CPF1999' *and &mi *eq 'CPF1937' ) +
- /* already being serviced; just ignore and clear error */ +
- *or ( &xi *eq 'CPF0001' *and &mi *eq 'CPD0039' ) ) +
- /* debug already active; just ignore and clear error */ +
- then(do)
- rmvmsg pgmq(*same (*)) msgq(*pgmq) clear(*old) rmvexcp(*yes)
- enddo
- else do /* move the prior msg to caller; resend *excm */
- if cond(&mi *ne ' ') then(do) /* a prior msg was found */
- call qmhmovpm (&mk &mt &mc &se &sc &ec)
- enddo
- /* resignal the cpf1999 or cpf0001 or the unexpected */
- call qmhrsnem (&xk &ec)
- enddo /* end-else do; resignal exits: RTX(*) */
- enddo /* end-monmsg cpf1999 */
- /* no error, debug started with updprod(*no) */
- mainend:
- return
- badthing: /* move any diags and resend the *excm */
- chgvar &mt '*DIAG' /* move diag message */
- chgvar &mc 1 /* Diag is only msg type */
- chgvar &mk ' ' /* move by type, not by key */
- call qmhmovpm (&mk &mt &mc &se &sc &ec)
- call qmhrsnem (&xk &ec)
- endpgm
-
|
|
|