On 5/26/2017 11:55 AM, Rob Berendt wrote:
Aren't you at 7.1 or higher? If so, then why use the API instead of
QSYS2.JOBLOG_INFO
at
http://ibm.biz/DB2foriServices
I wish I could do that in CL.
Here's an example of looping through messages in CL three ways:
1) The 'standard' error handler that has been published here several
times. This is for... unexpected messages.
2) The 'checkpoint' method, where the program sends a message to itself
as a record of where it started execution; there's no need to go back
further than that. This can't see program messages that were sent to
programs no longer in the stack, ie IBM programs comprising DB2.
Normally, I would save the message key and RMVMSG these, but I didn't
for this technology demonstrator.
3) The job log API method.
pgm
dcl &firstkey *char 4
dcl &lastkey *char 4
dcl &findkey *char 4
/* Std err */
dcl &errorsw *lgl
dcl &msgid *char len(7)
dcl &msgdta *char len(100)
dcl &msgf *char len(10)
dcl &msgflib *char len(10)
/* Open list of job log messages QGYOLJBL API */
dcl &rcvvar *char 5120
dcl &rcvvarlen *int
dcl &listinfo *char 80
dcl &nbrrcds *int
dcl &msgslt *char 256
dcl &msgsltlen *int
dcl &errcde *char 256
dcl &apimsgid *char 7
dcl &i *int
dcl &nextOff *int
dcl &fldOff *int
dcl &fldsrtn *int
dcl &msgsev *int
dcl &msgtyp *char 2
dcl &msgkey *char 4
dcl &msgfil *char 10
dcl &msglib *char 10
dcl &msgstamp *char 19
dcl &threadid *char 8
dcl &timezn *char 10
dcl &j *int
dcl &flddata *char 1024
dcl &fldnxtoff *int
dcl &fldlen *int
dcl &fldID *int
dcl &fldtyp *char 1
dcl &fldsts *char 1
dcl &fldres *char 14
dcl &flddtalen *int
dcl &fldtext *char 512
monmsg cpf0000 exec(goto stderr1)
/* when run through the standard error handler, */
/* does not find the *DIAG message */
/* because the message is sent to a system program */
/* that is no longer in the stack */
/* so let's try the checkpoint paradigm */
sndpgmmsg msg('test_msg begins') topgmq(*same) keyvar(&firstkey)
/* rmvmsg msgkey(&firstkey) */
/* first-last message keys don't work because the messages were not */
/* sent to THIS program; they were sent to IBM programs which are */
/* no longer in the stack. Same issue as the naive RCVMSG loop */
/* intentionally falls over */
runsql 'update NOFILE set COLA = COLB' +
commit(*none) option(*list) seclvltxt(*yes)
/* same problem; the messages are in the job log but not in */
/* a program message queue that we can access any more */
monmsg cpf0000 exec(do)
sndpgmmsg msg('test_msg error') topgmq(*same) keyvar(&lastkey)
/* rmvmsg msgkey(&lastkey) */
/* increment the checkpoint key and start looking */
chgvar %bin(&findkey) (%bin(&firstkey) + 1)
dmpclpgm
dowhile (%bin(&findkey) < %bin(&lastkey))
rcvmsg pgmq(*same ('QSQRUN3')) msgkey(&findkey) msgid(&msgid) +
rmv(*no) msgdta(&msgdta)
monmsg cpf2410 exec(leave) /* msgkey not found */
monmsg cpf2479 /* call stack entry not found */
sndpgmmsg ('loop=*' *cat &msgid *cat '*')
chgvar %bin(&findkey) (%bin(&findkey) + 1)
enddo
/* since the messages are in the job log, look there for them */
chgvar &rcvvar ' '
chgvar &rcvvarlen %size(&rcvvar)
chgvar &listinfo ' '
chgvar &nbrrcds 10
chgvar %sst(&msgslt 1 10) '*NEXT' /* direction */
chgvar %sst(&msgslt 11 26) '*' /* qual job name */
chgvar %sst(&msgslt 37 16) ' ' /* internal job ID */
chgvar %sst(&msgslt 53 4) &firstkey /* starting msgkey */
chgvar %bin(&msgslt 57 4) %size(&msgdta) /* max msg len */
chgvar %bin(&msgslt 61 4) 0 /* msx msg help len */
chgvar %bin(&msgslt 65 4) 80 /* offset to fld IDs */
chgvar %bin(&msgslt 69 4) 1 /* # fields to return */
chgvar %bin(&msgslt 73 4) 84 /* offset to call msg queue name */
chgvar %bin(&msgslt 77 4) 1 /* size of call msg queue name */
chgvar %bin(&msgslt 81 4) 0302 /* 1st fld ID */
chgvar %sst(&msgslt 85 1) '*' /* call msg queue name */
chgvar &msgsltlen 86
chgvar &errcde ' '
chgvar %bin(&errcde 1 4) %size(&errcde) /* normal exception handler */
chgvar %bin(&errcde 1 4) 0 /* force white msg - this is a raw demo */
chgvar %bin(&errcde 5 4) 0
call QGYOLJBL (&rcvvar &rcvvarlen &listinfo &nbrrcds +
&msgslt &msgsltlen &errcde)
/* what happened on the API call? */
if (%bin(&errcde 5 4) *ne 0) then(do)
chgvar &apimsgid %sst(&errcde 9 7)
dmpclpgm
return
enddo
/* parse out the response */
chgvar &i 1
chgvar &msgkey &firstkey
dowhile (&msgkey < &lastkey)
/* base fields for every message */
chgvar &nextOff %bin(&rcvvar &i 4) /* offset to next entry */
if (&nextOff *eq 0) leave
chgvar &i (&i + %size(&nextOff))
chgvar &fldOff %bin(&rcvvar &i 4) /* offset to fields */
chgvar &i (&i + %size(&fldOff))
chgvar &fldsrtn %bin(&rcvvar &i 4) /* # fields returned */
chgvar &i (&i + %size(&fldsrtn))
chgvar &msgsev %bin(&rcvvar &i 4) /* msg severity */
chgvar &i (&i + %size(&msgsev))
chgvar &msgid %sst(&rcvvar &i 7) /* msg ID */
chgvar &i (&i + %size(&msgid))
chgvar &msgtyp %sst(&rcvvar &i 2) /* msg type */
chgvar &i (&i + %size(&msgtyp))
chgvar &msgkey %sst(&rcvvar &i 4) /* msg type */
chgvar &i (&i + %size(&msgkey))
chgvar &msgfil %sst(&rcvvar &i 10) /* msg file */
chgvar &i (&i + %size(&msgfil))
chgvar &msglib %sst(&rcvvar &i 10) /* msg file lib */
chgvar &i (&i + %size(&msglib))
chgvar &msgstamp %sst(&rcvvar &i 19) /* msg time stamp */
chgvar &i (&i + %size(&msgstamp))
chgvar &threadid %sst(&rcvvar &i 8) /* thread ID */
chgvar &i (&i + %size(&threadid))
chgvar &timezn %sst(&rcvvar &i 10) /* time zone */
chgvar &i (&i + %size(&timezn))
/* variable; depends on field IDs requested */
/* this is hard-wired for message text, 0302 */
chgvar &fldoff (&fldoff + 1)
chgvar &flddata %sst(&rcvvar &fldoff 256)
chgvar &j 1
chgvar &fldNxtOff %bin(&flddata &j 4) /* offset to next field */
chgvar &j (&j + %size(&fldNxtOff))
chgvar &fldlen %bin(&flddata &j 4) /* field length returned */
chgvar &j (&j + %size(&fldlen))
chgvar &fldid %bin(&flddata &j 4) /* field ID */
chgvar &j (&j + %size(&fldid))
chgvar &fldtyp %sst(&flddata &j 1) /* field data type */
chgvar &j (&j + %size(&fldtyp))
chgvar &fldsts %sst(&flddata &j 1) /* field status */
chgvar &j (&j + %size(&fldsts))
chgvar &fldres %sst(&flddata &j 14) /* reserved */
chgvar &j (&j + %size(&fldres))
chgvar &flddtalen %bin(&flddata &j 4) /* field data length */
chgvar &j (&j + %size(&flddtalen))
chgvar &fldtext %sst(&flddata &j &flddtalen) /* field data */
chgvar &j (&j + %size(&fldtext))
/* if we were to have multiple ID keys, we'd use the offset */
/* that we just got */
/* zero means all done */
/* for the moment, just dump the variables */
/* and go to the next message */
/* since we only asked for 0302 and we know there's no more fields */
sndpgmmsg &fldtext
dmpclpgm
chgvar &i (&nextoff + 1)
enddo
dmpclpgm
return
enddo
sndpgmmsg 'No errors trapped'
return
/* Standard error handling routine */
stderr1:
/* Set "Error in progress" switch */
if &errorsw do
sndpgmmsg 'errorsw is on, aborting'
sndpgmmsg msgid(cpf9999) +
msgf(qcpfmsg) +
msgtype(*escape) /* func chk */
goto end
enddo
chgvar &errorsw '1' /* set to fail if error occurs */
/* Re-send diagnostic messages */
stderr2:
rcvmsg msgtype(*diag) +
pgmq(*same *) +
msgdta(&msgdta) +
msgid(&msgid) +
msgf(&msgf) +
msgflib(&msgflib)
monmsg cpf0000 exec(goto stderr3)
sndpgmmsg ('*DIAG=*' *cat &msgid *cat '*')
if (&msgid *eq ' ') goto stderr3
sndpgmmsg msgid(&msgid) +
msgf(&msgflib/&msgf) +
msgdta(&msgdta) +
msgtype(*diag)
goto stderr2 /* loop back for addl diagnostics */
/* Re-send escape messages */
stderr3:
rcvmsg msgtype(*excp) +
msgdta(&msgdta) +
msgid(&msgid) +
msgf(&msgf) +
msgflib(&msgflib)
monmsg cpf0000
sndpgmmsg ('*ESCAPE=*' *cat &msgid *cat '*')
sndpgmmsg msgid(&msgid) +
msgf(&msgflib/&msgf) +
msgdta(&msgdta) +
msgtype(*escape)
sndpgmmsg msgid(cpf9898) +
msgf(qcpfmsg) +
msgdta('runsqlstm failed') +
msgtype(*escape)
end:
dmpclpgm
endpgm
midrange.com
