45. プログラムが活動中であるかどうか調べる IFACTIVE
S/36 の OCL で唯一、S/38 や AS400, IBM i になかった命令は
プログラムが活動中であるかどうかを調べるコマンドである。
たまにプログラムが現在、この実行ジョブのスタックで実行しているのかどうかを知りたいことがある。
( S/36 の If-Active はすべてのシステム空間を検査していた)
手軽に実行中のプログラムを検査する方法はないだろうか ?
幸い、実行スタックの中身はAPI : QWVRCSTK で調べることができるが
API にまだ不慣れな人や C言語の苦手な人のために CLP で手軽に検査することのできる
コマンド: IFACTIVE を作成したのでここで紹介する。
IFACTIVEコマンドでプログラム/ライブラリー名を指定して実行すると
実行中であれば単に実行が正常終了するだけであるが
指定したプログラムが実行されていない場合はCPF9897 が *ESCAPE で戻される。
従って MONMSG CPF9800 で上位の呼び出しプログラムでモニターしておけば
そのプログラムが活動中であるかどうかを容易に知ることができる。
【コマンド: IFACTIVE】
0001.00 CMD PROMPT(' プログラム活動検査 ')
0002.00 PARM KWD(PGM) TYPE(PGM) +
0003.00 PROMPT(' プログラム ')
0004.00 PGM: QUAL TYPE(*NAME) LEN(10) SPCVAL((*PRV)) MIN(1)
0005.00 QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) +
0006.00 SPCVAL((*LIBL) (*CURLIB) (*PRV)) +
0007.00 PROMPT(' ライブラリー ')
【コンパイル】
CRTCMD CMD(MYLIB/IFACTIVE) PGM(MYLIB/IFACTIVECL) SRCFILE(MYSRCLIB/QCMDSRC) AUT(*ALL)
【CLP: IFACTIVECL】
0001.00 PGM PARM(&PGMOBJLIB)
0002.00 /*-------------------------------------------------------------------*/
0003.00 /* IFACTIVECL : プログラム活動検査 */
0004.00 /* */
0005.00 /* 2015/11/24 作成 */
0006.00 /*-------------------------------------------------------------------*/
0007.00 DCL VAR(&PGMOBJLIB) TYPE(*CHAR) LEN(20)
0008.00 DCL VAR(&CMPOBJLIB) TYPE(*CHAR) LEN(20)
0009.00 DCL VAR(&PGM) TYPE(*CHAR) LEN(10)
0010.00 DCL VAR(&OBJLIB) TYPE(*CHAR) LEN(10)
0011.00 DCL VAR(&JOBINFO) TYPE(*CHAR) LEN(56)
0012.00 DCL VAR(&IND) TYPE(*CHAR) LEN(4) +
0013.00 VALUE(X'00000002')
0014.00 DCL VAR(&JOB) TYPE(*CHAR) LEN(10)
0015.00 DCL VAR(&USER) TYPE(*CHAR) LEN(10)
0016.00 DCL VAR(&NBR) TYPE(*CHAR) LEN(6)
0017.00 DCL VAR(&MSG) TYPE(*CHAR) LEN(132)
0018.00 DCL VAR(&MSGID) TYPE(*CHAR) LEN(7)
0019.00 DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
0020.00 DCL VAR(&MSGFLIB) TYPE(*CHAR) LEN(10)
0021.00 DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(132)
0022.00 DCL VAR(&TYPE) TYPE(*CHAR) LEN(1)
0023.00 DCL VAR(&TOPGMQ) TYPE(*CHAR) LEN(10)
0024.00 DCL VAR(&RCVVAR) TYPE(*CHAR) LEN(3000)
0025.00 DCL VAR(&RCVLEN) TYPE(*CHAR) LEN(4) +
0026.00 VALUE(X'00000BB8') /* 3000 バイト */
0027.00 DCL VAR(&APIERR) TYPE(*CHAR) LEN(116) +
0028.00 VALUE(X'000074') /* 2 進数 */
0029.00 DCL VAR(&NULL2) TYPE(*CHAR) LEN(2) +
0030.00 VALUE(X'0000')
0031.00 DCL VAR(&NULL4) TYPE(*CHAR) LEN(4) +
0032.00 VALUE(X'00000000')
0033.00 DCL VAR(&NULL8) TYPE(*CHAR) LEN(8) +
0034.00 VALUE(X'0000000000000000')
0035.00 DCL VAR(&ENTRY) TYPE(*CHAR) LEN(4)
0036.00 DCL VAR(&ENTRYS) TYPE(*DEC) LEN(8 0)
0037.00 DCL VAR(&N) TYPE(*DEC) LEN(8 0)
0038.00 DCL VAR(&OFFSET) TYPE(*CHAR) LEN(4)
0039.00 DCL VAR(&OFFSETS) TYPE(*DEC) LEN(8 0)
0040.00 DCL VAR(&LENGTH) TYPE(*CHAR) LEN(4)
0041.00 DCL VAR(&LENGTHS) TYPE(*DEC) LEN(8 0)
0042.00 MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
0043.00
0044.00 RTVJOBA JOB(&JOB) USER(&USER) NBR(&NBR) TYPE(&TYPE)
0045.00 IF COND(&TYPE *EQ '0') THEN(DO) /* バッチ */
0046.00 CHGVAR VAR(&TOPGMQ) VALUE('*SYSOPR ')
0047.00 ENDDO /* バッチ */
0048.00 ELSE CMD(DO) /* 対話式 */
0049.00 CHGVAR VAR(&TOPGMQ) VALUE('*TOPGMQ ')
0050.00 ENDDO /* 対話式 */
0051.00
0052.00 CHGVAR VAR(%SST(&JOBINFO 1 10)) VALUE(&JOB)
0053.00 CHGVAR VAR(%SST(&JOBINFO 11 10)) VALUE(&USER)
0054.00 CHGVAR VAR(%SST(&JOBINFO 21 6)) VALUE(&NBR)
0055.00 CHGVAR VAR(%SST(&JOBINFO 43 2)) VALUE(&NULL2)
0056.00 CHGVAR VAR(%SST(&JOBINFO 45 4)) VALUE(&IND)
0057.00 CHGVAR VAR(%SST(&JOBINFO 49 8)) VALUE(&NULL8)
0058.00 CALL PGM(QWVRCSTK) PARM(&RCVVAR &RCVLEN +
0059.00 'CSTK0100' &JOBINFO 'JIDF0100' &APIERR)
0060.00 IF COND(%SST(&APIERR 5 4) *NE &NULL4) THEN(DO)
0061.00 SNDPGMMSG +
0062.00 MSG('API: QWVRCSTK の実行で次のエラーが発生 +
0063.00 しました。 ') MSGTYPE(*DIAG)
0064.00 GOTO APIERR
0065.00 ENDDO
0066.00 CHGVAR VAR(&LENGTH) VALUE(%SST(&RCVVAR 1 4))
0067.00 CHGVAR VAR(&LENGTHS) VALUE(%BIN(&LENGTH))
0068.00 CHGVAR VAR(&ENTRY) VALUE(%SST(&RCVVAR 17 4))
0069.00 CHGVAR VAR(&ENTRYS) VALUE(%BIN(&ENTRY))
0070.00 CHGVAR VAR(&N) VALUE(1)
0071.00 CHGVAR VAR(&OFFSET) VALUE(%SST(&RCVVAR 13 4))
0072.00 CHGVAR VAR(&OFFSETS) VALUE(%BIN(&OFFSET))
0073.00 CHGVAR VAR(&OFFSETS) VALUE(&OFFSETS + 1)
0074.00 LOOP: CHGVAR VAR(&LENGTH) VALUE(%SST(&RCVVAR &OFFSETS 4))
0075.00 CHGVAR VAR(&LENGTHS) VALUE(%BIN(&LENGTH))
0076.00 CHGVAR VAR(&OFFSETS) VALUE(&OFFSETS + 24)
0077.00 CHGVAR VAR(&CMPOBJLIB) VALUE(%SST(&RCVVAR &OFFSETS +
0078.00 20))
0079.00 IF COND(&CMPOBJLIB *EQ &PGMOBJLIB) THEN(DO) /* +
0080.00 活動中 */
0081.00 RETURN
0082.00 ENDDO /* 活動中 */
0083.00 IF COND(&N < &ENTRYS) THEN(DO)
0084.00 CHGVAR VAR(&OFFSETS) VALUE(&OFFSETS + &LENGTHS - 24)
0085.00 CHGVAR VAR(&N) VALUE(&N + 1)
0086.00 GOTO LOOP
0087.00 ENDDO
0088.00 /* 非活動 */
0089.00 CHGVAR VAR(&PGM) VALUE(%SST(&PGMOBJLIB 1 10))
0090.00 CHGVAR VAR(&OBJLIB) VALUE(%SST(&PGMOBJLIB 11 10))
0091.00 CHGVAR VAR(&MSGDTA) VALUE(' プログラム ' *CAT +
0092.00 &OBJLIB *TCAT '/' *CAT &PGM *TCAT +
0093.00 ' は活動していません。 ')
0094.00 SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&MSGDTA) +
0095.00 TOPGMQ(*PRV) TOMSGQ(*TOPGMQ) MSGTYPE(*ESCAPE)
0096.00 RETURN
0097.00
0098.00 APIERR:
0099.00 CHGVAR VAR(&MSGID) VALUE(%SST(&APIERR 9 7))
0100.00 CHGVAR VAR(&MSGDTA) VALUE(%SST(&APIERR 17 100))
0101.00 CHGVAR VAR(&MSGF) VALUE('QCPFMSG ')
0102.00 CHGVAR VAR(&MSGFLIB) VALUE('QSYS ')
0103.00 GOTO SNDMSG
0104.00 ERROR: RCVMSG MSGTYPE(*LAST) RMV(*NO) MSG(&MSG) +
0105.00 MSGDTA(&MSGDTA) MSGID(&MSGID) MSGF(&MSGF) +
0106.00 MSGFLIB(&MSGFLIB)
0107.00 SNDMSG: IF COND(&MSGID *EQ ' ') THEN(DO)
0108.00 SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&MSG) +
0109.00 TOMSGQ(&TOPGMQ) MSGTYPE(*ESCAPE)
0110.00 ENDDO
0111.00 ELSE CMD(DO)
0112.00 SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
0113.00 MSGDTA(&MSGDTA) TOMSGQ(&TOPGMQ) +
0114.00 MSGTYPE(*ESCAPE)
0115.00 ENDDO
0116.00 ENDPGM
【コンパイル】
CRTCLPGM PGM(MYLIB/IFACTIVECL) SRCFILE(MYSRCLIB/QCLSRC) AUT(*ALL)
【解説】
原理的には至って簡単であり API : QWVRCSTK でスタックを &RCVVAR に入れたものを
LOOP して階層を取り出して指定したプログラム: &PGMOBJLIB があるかどうかを調べる。
もし見つかった場合は、何もせずにそのまま RETURN で戻るが
見つからなかった場合は SNDPGMMSG で CPF9897 を *ESCAPE で戻す。
【上位のプログラムの例: SNDPGMMSG】
0001.00 PGM PARM(&MSGID &MSGF &MSGFLIB &MSGDTA)
0002.00 /*-------------------------------------------------------------------*/
0003.00 /* SNDPGMMSG: RPG 内での PGM メッセージ送信 */
0004.00 /* */
0005.00 /* 2015/11/24: HTML ドライバーから呼ばれた場合だけは */
0006.00 /* MAIN モジュールのエラーである旨を告げる */
0007.00 /*-------------------------------------------------------------------*/
0008.00 DCL VAR(&MSGID) TYPE(*CHAR) LEN(7)
0009.00 DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
0010.00 DCL VAR(&MSGFLIB) TYPE(*CHAR) LEN(10)
0011.00 DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(132)
0012.00 DCL VAR(&MSG) TYPE(*CHAR) LEN(132)
0013.00 DCL VAR(&TYPE) TYPE(*CHAR) LEN(1)
0014.00 DCL VAR(&TOPGMQ) TYPE(*CHAR) LEN(10)
0015.00 DCL VAR(&HTMLDVR) TYPE(*CHAR) LEN(1) VALUE('*')
0016.00 MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
0017.00
0018.00 RTVJOBA TYPE(&TYPE)
0019.00 IF COND(&TYPE *EQ '0') THEN(DO) /* +
0020.00 バッチ・ジョブ */
0021.00 CHGVAR VAR(&TOPGMQ) VALUE('*SYSOPR ')
0022.00 ENDDO /* バッチ・ジョブ */
0023.00 ELSE CMD(DO) /* 対話式 */
0024.00 CHGVAR VAR(&TOPGMQ) VALUE('*TOPGMQ ')
0025.00 ENDDO /* 対話式 */
0026.00 ASNET.COM/IFACTIVE PGM(ASNET.COM/HTMLDVR)
0027.00 MONMSG MSGID(CPF9800) EXEC(DO)
0028.00 CHGVAR VAR(&HTMLDVR) VALUE(' ')
0029.00 ENDDO
0030.00
0031.00 IF COND(&HTMLDVR *EQ '*') THEN(DO) /* +
0032.00 HTML ドライバー */
0033.00 SNDPGMMSG MSG('[ERROR] +
0034.00 MAIN モジュールで次のエラーが検出されまし +
0035.00 た。 ') TOMSGQ(&TOPGMQ) MSGTYPE(*INFO)
0036.00 ENDDO /* HTML ドライバー */
0037.00 SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
0038.00 MSGDTA(&MSGDTA) TOMSGQ(&TOPGMQ) +
0039.00 MSGTYPE(*ESCAPE)
0040.00 RETURN
0041.00
0042.00 ERROR: RCVMSG MSGTYPE(*LAST) RMV(*NO) MSG(&MSG) +
0043.00 MSGDTA(&MSGDTA) MSGID(&MSGID) MSGF(&MSGF) +
0044.00 MSGFLIB(&MSGFLIB)
0045.00 SNDMSG: IF COND(&MSGID *EQ ' ') THEN(DO)
0046.00 SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA(&MSG) +
0047.00 TOMSGQ(&TOPGMQ) MSGTYPE(*ESCAPE)
0048.00 ENDDO
0049.00 ELSE CMD(DO)
0050.00 SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
0051.00 MSGDTA(&MSGDTA) TOMSGQ(&TOPGMQ) +
0052.00 MSGTYPE(*ESCAPE)
0053.00 ENDDO
0054.00 ENDPGM
【解説】
この SNDPGMMSG というCLプログラムは
HTMLドライバーと呼ばれる(HTMLDVR)プログラム中、
それも例外サブルーチン : *PSSR で呼び出されて実行される。
ただし SNDPGMMSG は汎用的なエラー・メッセージ送信のプログラムなので
他の場面での使用も想定している。
ただ HTMLDVR というプログラムから呼ばれたときは
「MAIN モジュールで次のエラーが検出されました。」というメッセージも合わせて送りたいのである。
つまり HTMLDVR というプログラムが実行中の場合はこのメッセージも付記するのである。
このことを判断させるために IFACTIVE コマンドを使って検査して結果を MONMSG で監視している。
0026.00 ASNET.COM/IFACTIVE PGM(ASNET.COM/HTMLDVR)
0027.00 MONMSG MSGID(CPF9800) EXEC(DO)
0028.00 CHGVAR VAR(&HTMLDVR) VALUE(' ')
0029.00 ENDDO
