QZRUCLSP - Call Service Program Procedure

Call Service Program Procedure Program: VARPROC1 H DFTACTGRP(*NO) ACTGRP(*NEW) * * This program demonstrates using the QZRUCLSP API to do "soft * coded" calls to routines in the MSGSRV service program. * Scott Klement, Nov 6, 2003 * * * Compile me with: * CRTBNDRPG VARPROC1 SRCFILE(xxx/xxx) * (Note that you do NOT have to bind the MSGSRV *SRVPGM!) * * Call me with: * CALL VARPROC1 PARM('COMPMSG' 'THIS IS MY COOL MESSAGE' 23) * CALL VARPROC1 PARM('DIAGMSG' 'THIS IS MY COOL MESSAGE' 23) * CALL VARPROC1 PARM('ESCAPEMSG' 'THIS IS MY COOL MESSAGE' 23) * CALL VARPROC1 PARM('STATUSMSG' 'THIS IS MY COOL MESSAGE' 23) * * Note that the output from DIAGMSG will go to the job log. * * * API error code structure * D dsEC DS D dsEC_BytesP 10I 0 inz(%size(dsEC)) D dsEC_BytesA 10I 0 inz(0) D dsEC_MsgID 7A D dsEC_Resvd 1A D dsEC_MsgDta 240A * * Call Service Program Procedure API (QZRUCLSP) * d QZRUCLSP pr extpgm('QZRUCLSP') d QualSrvPgm 20A const d ExportName 4096A options(*varsize) const d RtnValFmt 10I 0 const d ParmsFmt 10I 0 dim(256) options(*varsize) d NumOfParms 10I 0 const d Errorcode 1024a options(*varsize) d ReturnValue 10I 0 options(*nopass) d Parameter1 256A options(*nopass) d Parameter2 10I 0 options(*nopass) * * Parameter/Return types to use with QZRUCLSP API * d RETTYPE_NONE C 0 d RETTYPE_INT C 1 d RETTYPE_PTR C 2 d RETTYPE_INTERR C 3 d PARMTYPE_INT C 1 d PARMTYPE_PTR C 2 d SrvPgm s 10A inz('MSGSRV') d SrvPgmLib s 10A inz('*LIBL') d Procedure s 32A d ParmType s 10I 0 dim(2) d RtnVal s 10I 0 D Message s 256A D Length s 15P 5 D IntLen s 10I 0 D Msg s 52A c *entry plist c parm Procedure c parm Message c parm Length c eval IntLen = Length c eval ParmType(1) = PARMTYPE_PTR c eval ParmType(2) = PARMTYPE_INT c callp QZRUCLSP( SrvPgm+SrvPgmLib: c %trimr(Procedure)+x'00': c RETTYPE_INT: c ParmType: 2: c dsEC: c RtnVal: c Message: c IntLen) c select c when dsEC_BytesA > 0 c eval Msg = 'Call failed with ' + dsEC_MsgID c dsply Msg c when RtnVal <> 0 c eval Msg = 'Procedure returned error: ' + c %trim(%editc(RtnVal:'L')) c dsply Msg c endsl c eval *inlr = *on Program: VARPROC2 * * This program demonstrates using procedure pointers with a SELECT * group to "soft-code" procedure names. * Scott Klement, Nov 6, 2003 * * Compile me with: * CRTRPGMOD VARPROC2 SRCFILE(xxx/xxx) * CRTPGM VARPROC2 BNDSRVPGM(MSGSRV) ACTGRP(*NEW) * (Note that you DO have to bind the MSGSRV *SRVPGM!) * * Call me with: * CALL VARPROC2 PARM('COMPMSG' 'THIS IS MY COOL MESSAGE' 23) * CALL VARPROC2 PARM('DIAGMSG' 'THIS IS MY COOL MESSAGE' 23) * CALL VARPROC2 PARM('ESCAPEMSG' 'THIS IS MY COOL MESSAGE' 23) * CALL VARPROC2 PARM('STATUSMSG' 'THIS IS MY COOL MESSAGE' 23) * * Note that the output from DIAGMSG will go to the job log. * D MsgProcPtr s * procptr D AnyMsgProc PR 10I 0 ExtProc(MsgProcPtr) D Message 256A options(*varsize) D Length 10I 0 value d Procedure s 32A d RtnVal s 10I 0 D Message s 256A D Length s 15P 5 D Msg s 52A c *entry plist c parm Procedure c parm Message c parm Length c select c when Procedure = 'ESCAPEMSG' c eval MsgProcPtr = %paddr('ESCAPEMSG') c when Procedure = 'COMPMSG' c eval MsgProcPtr = %paddr('COMPMSG') c when Procedure = 'STATUSMSG' c eval MsgProcPtr = %paddr('STATUSMSG') c when Procedure = 'DIAGMSG' c eval MsgProcPtr = %paddr('DIAGMSG') c endsl c eval RtnVal = AnyMsgProc(Message: Length) c if RtnVal <> 0 c eval Msg = 'Procedure returned error: ' + c %trim(%editc(RtnVal:'L')) c dsply Msg c endif c eval *inlr = *on Program: MSGSRV H NOMAIN * * This service program sends messages 4 different ways, it's used * by the VARPROC1 and VARPROC2 programs to demonstrate soft-coded * procedure calls. * Scott Klement, Nov 6, 2003 * * To compile: * CRTRPGMOD MODULE(mylib/MSGSRV) SRCFILE(mylib/mysrcpf) * CRTSRVPGM SRVPGM(mylib/MSGSRV) MODULE(mylib/MSGSRV) EXPORT(*ALL) * * * API error code structure * D dsEC DS D dsEC_BytesP 10I 0 inz(%size(dsEC)) D dsEC_BytesA 10I 0 inz(0) D dsEC_MsgID 7A D dsEC_Resvd 1A D dsEC_MsgDta 240A * * Send Program Message API * D QMHSNDPM PR ExtPgm('QMHSNDPM') D MessageID 7A Const D QualMsgF 20A Const D MsgData 256A Const D MsgDtaLen 10I 0 Const D MsgType 10A Const D CallStkEnt 10A Const D CallStkCnt 10I 0 Const D MessageKey 4A D ErrorCode 1024A options(*varsize) D CompMsg PR 10I 0 D Message 256A options(*varsize) D Length 10I 0 value D EscapeMsg PR 10I 0 D Message 256A options(*varsize) D Length 10I 0 value D StatusMsg PR 10I 0 D Message 256A options(*varsize) D Length 10I 0 value D DiagMsg PR 10I 0 D Message 256A options(*varsize) D Length 10I 0 value *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * CompMsg(): Send a completion message. * * Message = message to send * Length = length of message to send * * returns 0 if successful, or -1 if an error occurs *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P CompMsg B export D CompMsg PI 10I 0 D Message 256A options(*varsize) D Length 10I 0 value D MsgKey s 4A c reset dsEC c callp QMHSNDPM('CPF9897': 'QCPFMSG *LIBL': c Message: Length: '*COMP': c '*CTLBDY': 2: MsgKey: dsEC) c if dsEC_BytesA > 0 c return -1 c else c return 0 c endif P E *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * EscapeMsg(): Send a completion message. * * Message = message to send * Length = length of message to send * * returns -1 if an error occurs * (If successful, program stops, so no return value is possible) *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P EscapeMsg B export D EscapeMsg PI 10I 0 D Message 256A options(*varsize) D Length 10I 0 value D MsgKey s 4A c reset dsEC c callp QMHSNDPM('CPF9897': 'QCPFMSG *LIBL': c Message: Length: '*ESCAPE': c '*CTLBDY': 2: MsgKey: dsEC) c return -1 P E *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * StatusMsg(): Send a status message, and delay for 1 second * * Message = message to send * Length = length of message to send * * returns 0 if successful, or -1 if an error occurs *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P StatusMsg B export D StatusMsg PI 10I 0 D Message 256A options(*varsize) D Length 10I 0 value D MsgKey s 4A D QCMDEXC PR ExtPgm('QCMDEXC') D command 200A const D length 15P 5 const c reset dsEC c callp QMHSNDPM('CPF9897': 'QCPFMSG *LIBL': c Message: Length: '*STATUS': c '*EXT': 0: MsgKey: dsEC) c if dsEC_BytesA > 0 c return -1 c else c callp QCMDEXC('DLYJOB DLY(1)': 13) c return 0 c endif P E *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * DiagMsg(): Send a diagnostic message (to the job log) * * Message = message to send * Length = length of message to send * * returns 0 if successful, or -1 if an error occurs *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P DiagMsg B export D DiagMsg PI 10I 0 D Message 256A options(*varsize) D Length 10I 0 value D MsgKey s 4A c reset dsEC c callp QMHSNDPM('CPF9897': 'QCPFMSG *LIBL': c Message: Length: '*DIAG': c '*': 1: MsgKey: dsEC) c if dsEC_BytesA > 0 c return -1 c else c return 0 c endif P E Thanks to Scott Klement