如何於 CL 中產生 UUID ?(Command GENUUID with MI GENUUID)
How to Generate UUID in CL ? (Command GENUUID with MI GENUUID)
File : QCLSRC
Member: GENUUIDC
Type : CLLE
/* */
/* \\\\\\\ */
/* ( o o ) */
/*------------------------oOO----(_)----OOo-----------------------*/
/* */
/* Program : GENUUIDC */
/* System : IBM i V7R2 */
/* Author : Vengoal Chang */
/* Date : 2023/11/10 */
/* Description : Generate Universal Unique Identifier (GENUUID)*/
/* GENUUID command CPP */
/* */
/* ooooO Ooooo */
/* ( ) ( ) */
/*----------------------( )-------------( )-------------------*/
/* (_) (_) */
/* */
/* */
/* To compile : */
/* The source type must be "CLLE" (and not CLP). */
/* Compile with STRPDM option 14 or use the */
/* CRTBNDCL command. */
/* */
/*----------------------------------------------------------------*/
Pgm Parm(&UUIDP &UUIDHEX)
Dcl &UUIDP *Char 16
Dcl &UUIDHEX *Char 32
Dcl &TMPL *Char 32
Dcl &LEN *Uint 4 VALUE(32)
Dcl &BytPrv *Uint Stg(*DEFINED) +
Len(4) DefVar(&TMPL)
Dcl &BytAvl *Uint Stg(*DEFINED) +
Len(4) DefVar(&TMPL)
Dcl &Reserved *Char Stg(*DEFINED) +
Len(8) DefVar(&TMPL 10)
Dcl &UUID *Char Stg(*DEFINED) +
Len(16) DefVar(&TMPL 17)
Dcl &RcvHexLen *Int 4 32
CallPrc Prc('_PROPB') Parm((&TMPL *ByRef) +
(X'00' *ByVal) +
(&LEN *ByVal))
ChgVar &BytPrv 32
CallPrc Prc('_GENUUID') Parm((&TMPL *ByRef))
ChgVar &UUIDP &UUID
CallPrc PRC('cvthc') +
PARM((&UUIDHEX *ByRef) +
(&UUID *ByRef) +
(&RcvHexLen *ByVal))
/* DmpClPgm */
End: EndPgm
File : QCMDSRC
Member: GENUUID
Type : CMD
/*****************************************************************/
/* */
/* Command name: GenUUID */
/* */
/* Author : Vengoal Chang */
/* */
/* Date written: 2023/11/10 */
/* */
/* Description : Generate Universal Unique Identifier (GENUUID) */
/* */
/* To compile: */
/* CRTCMD CMD( GenUUID ) */
/* PGM( GenUUIDC ) */
/* SRCMBR( GenUUID ) */
/* ALLOW( *Ipgm *Bpgm ) */
/* */
/*****************************************************************/
Cmd Prompt('Generate Universal Unique ID')
Parm Kwd( UUID ) +
Type(*CHAR) +
Len(16) +
RtnVal(*YES) +
Prompt('CL var for UUID (16)')
Parm Kwd( UUIDHEX ) +
Type(*CHAR) +
Len(32) +
RtnVal(*YES) +
Prompt('CL var for UUID HEX STR (32)')
星期五, 11月 10, 2023
2023-11-10 如何於 CL 中產生 UUID ?(Command GENUUID with MI GENUUID)
星期三, 11月 08, 2023
2008-06-02 如何於 CLP 中，將資料存入原始程式檔案成員中(Source Physical File member)？(Command: WRTSRCREC)
如何於 CLP 中，將資料存入原始程式檔案成員中(Source Physical File member)？(Command: WRTSRCREC)
由於現行商業環境中時常需要做資料轉換及傳輸，最常用的工具是 SQL 或 FTP，所以時常需要寫 script
於 source 中，讓 FTP 或 RUNSQLSTM 執行時使用，而此類指令都是使用原始程式檔案成員當成script 指令來源，
所以需要事先將 script 指令寫於原始程式檔案成員中，若遇上某些名稱是動態時，便需要另寫程式控制，往往因
此類需求愈多造成困擾及維護困難，所以我寫一個指令 WRTSRCREC 來達成動態寫入資料到所指定的原始程式檔案成員。
File : QRPGLESRC
Member: WRKSRCREC
Type : RPGLE
Usage : CRTBNDRPG WRKSRCREC
**
** Program . . : WRTSRCREC
** Description : Write text to source member
** Author . . : Vengoal Chang
**
** Date . . : 2008/05/31
**
** Compile and setup instructions:
** CrtBndRpg Pgm( WRTSRCREC )
** DbgView( *LIST )
**
**
**-- Control specification: --------------------------------------------**
H DFTACTGRP(*NO) BNDDIR('QC2LE')
H OPTION(*NODEBUGIO : *SRCSTMT) DEBUG
FQSRC O A F 266 DISK USROPN INFDS(INFDS)
D WRTSRCREC PR Extpgm('WRTSRCREC')
D SRCFILE 20A CONST
D SRCMBR 10A CONST
D inData 252A
D WRTSRCREC PI
D SRCFILE 20A CONST
D SRCMBR 10A CONST
D inData 252A
D Data DS Based(pData)
D nInDataLen 5I 0
D szData 250A
D INFDS DS
D szSrcFileName 83 92A
D szSrcFileLib 93 102A
D szSrcFileMbr 129 138A
D nSrcRecLen 125 126I 0
D nSrcRecCnt 156 159I 0
* QCMDEXC - Prototyped Call
D qcmdexc PR EXTPGM('QCMDEXC')
D cmd_str 1024 OPTIONS(*VARSIZE) CONST
D cmd_len 15P 5 CONST
D cmdStr S 512A Varying
D today S D Inz(*SYS)
D SRCSEQ S 6S 2
D SRCDATE S 6S 0
D SRCDATA S 250A
**-- Send program message:
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D SpMsgId 7a Const
D SpMsgFq 20a Const
D SpMsgDta 128a Const
D SpMsgDtaLen 10i 0 Const
D SpMsgTyp 10a Const
D SpCalStkE 10a Const Options( *VarSize )
D SpCalStkCtr 10i 0 Const
D SpMsgKey 4a
D SpError 32767a Options( *VarSize )
D MsgKey s 4a
D MsgTxt s 512a
**-- Receive Program Message (QMHRCVPM) API
D QMHRCVPM PR ExtPgm('QMHRCVPM')
D MsgInfo 32767A options(*varsize)
D MsgInfoLen 10I 0 const
D Format 8A const
D StackEntry 10A const
D StackCount 10I 0 const
D MsgType 10A const
D MsgKey 4A const
D WaitTime 10I 0 const
D MsgAction 10A const
D ErrorCode 32767A options(*varsize)
**-- Message text parameter: ------------------------------------
D RCVM0200 Ds
D M2BytPrv 10i 0
D M2BytAvl 10i 0
D M2MsgSev 10i 0
D M2MsgId 7a
D M2MsgTyp 2a
D M2MsgKey 4a
D M2MsgF 10a
D M2MsgFlib 10a
D M2MsgFlibUsd 10a
D M2SndJob 10a
D M2SndUsrPrf 10a
D M2SndJobNbr 6a
D M2SndPgm 12a
D 4a
D M2SndDat 7a
D M2SndTim 6a
D 17a
D M2CcsIdCsiTxt 10i 0
D M2CcsIdCsiDta 10i 0
D M2AlrOpt 9a
D M2CcsIdTxt 10i 0
D M2CcsIdDta 10i 0
D M2MsgDtaRtn 10i 0
D M2MsgDtaAvl 10i 0
D M2MsgTxtRtn 10i 0
D M2MsgTxtAvl 10i 0
D M2MsgHlpRtn 10i 0
D M2MsgHlpAvl 10i 0
D M2MsgVarFld 4096a
D ErrorNull ds
D BytesProv 10i 0 inz(0)
D BytesAvaile 10i 0 inz(0)
C eval *INLR = *ON
C eval cmdStr= 'CHKOBJ OBJ(' +
C %TrimR(%SUBST(SRCFILE:11:10)) + '/' +
C %TrimR(%SUBST(SRCFILE:01:10)) + ')' +
C ' OBJTYPE(*FILE)' +
C ' MBR(' + %TrimR(srcmbr) + ')'
C ExSr PrcCmd
C eval cmdStr= 'OVRDBF FILE(QSRC) TOFILE(' +
C %TrimR(%SUBST(SRCFILE:11:10)) + '/' +
C %TrimR(%SUBST(SRCFILE:01:10)) + ')' +
C ' MBR(' + %TrimR(srcmbr) + ')' +
C ' SECURE(*YES)'
C ExSr PrcCmd
C open QSRC
C if NOT %OPEN(QSRC)
C return
C endif
C eval pData = %addr(inData)
C if nInDataLen > nSrcRecLen
C eval srcData = %subst(szData:1:nSrcRecLen)
C eval %Subst(srcData : nSrcRecLen : 1) = '-'
C eval srcseq = nSrcRecCnt + 1
C except OUTPUT
C eval srcData = %subst(szData:nSrcRecLen)
C eval srcseq = nSrcRecCnt + 1
C except OUTPUT
C else
C eval srcseq = nSrcRecCnt + 1
C eval srcData = %subst(szData:1:nInDataLen)
C except OUTPUT
C endif
C CLOSE QSRC
C return
*=====================================================================
* Process command
*=====================================================================
C PrcCmd BegSr
C CALLP(e) QCMDEXC( cmdStr : %len(%trimr(cmdStr)))
C If %error
C ExSr RcvErrMsg
C ExSr SndEscMsg
C return
C EndIf
C EndSr
*=====================================================================
* Retrieve error message from joblog and get message text from MSGF
*=====================================================================
C RcvErrMsg BegSr
C Callp QMHRCVPM( RCVM0200
C : %size(RCVM0200)
C : 'RCVM0200'
C : '*'
C : 0
C : '*EXCP'
C : *blanks
C : 0
C : '*SAME'
C : ErrorNull )
* Only error message
C eval MsgTxt = %SubSt( M2MsgVarFld
C : M2MsgDtaRtn + 1
C : M2MsgTxtRtn
C )
* include error and help message
C* eval MsgTxt = %SubSt( M2MsgVarFld
C* : M2MsgDtaRtn + 1
C* )
C EndSr
*=====================================================================
*-- Send escape message --**
*=====================================================================
C SndEscMsg BegSr
C callP SndPgmMsg( 'CPF9898'
C : 'QCPFMSG *LIBL'
C : MsgTxt
C : %Len( MsgTxt )
C : '*ESCAPE'
C : '*PGMBDY'
C : 1
C : MsgKey
C : ErrorNull
C )
C EndSr
*=====================================================================
OQSRC EADD OUTPUT
O SRCSEQ 6
O SRCDATE 12
O SRCDATA 266
File : QCMDSRC
Member: WRKSRCREC
Type : CMD
Usage : CRTCMD CMD(WRTSRCREC) PGM(WRTSRCREC)
/* =============================================================== */
/* = Command....... WrtSrcRec = */
/* = CPP........... WrtSrcRec = */
/* = Description... Write data to Source File Member = */
/* = = */
/* = CrtCmd Cmd( WrtSrcRec ) = */
/* = Pgm( WrtSrcRec ) = */
/* = SrcFile( YourSourceFile ) = */
/* =============================================================== */
/* = Date : 2008/05/31 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
WRTSRCREC: CMD PROMPT('Write Source Record')
/* Command processing program is WRTSRCREC */
PARM KWD(SRCFILE) TYPE(SRCF) MIN(1) +
PROMPT('Source file')
SRCF: QUAL TYPE(*NAME) DFT(QCLSRC) SPCVAL((QCLSRC) +
(QCLLESRC QRPGLESRC)) EXPR(*YES)
QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL) +
(*CURLIB)) EXPR(*YES) PROMPT('Library')
PARM KWD(SRCMBR) TYPE(*NAME) SPCVAL((*FIRST) +
(*LAST)) MIN(1) EXPR(*YES) PROMPT('Source +
member')
PARM KWD(DATA) TYPE(*CHAR) LEN(250) +
SPCVAL((*BLANKS ' ')) EXPR(*YES) +
VARY(*YES) PROMPT('Source data')
範例測試程式：此範例是利用 WRTSRCREC 指令產生下傳 QGPL/QCLSRC 原始程式檔案中所有成員的 FTP script 指令，
一般 FTP 將 AS/400 上文字資料下傳到 FTP aserver 需要下如下 FTP script 指令:
user password
LType c 950
put QGPL/QDDSSRC.mbr QDSIGNON.txt
quit
上述第一行為 FTP server 上的使用者及密碼，
第三行為將 EBCDIC CCSID 937 中文資料轉換回 Big5 中文資料(若資料中有含中文時需要加入此行 FTP 指令)
第三行為將 AS/400 上 QGPL library 中檔案 QDDSSRC 的成員 QDSIGNON，放置 FTP server 上檔名為 QDSIGNON.txt，
第四行為退出 FTP。
此範例程式將組成下傳所有 QGPL/QDDSSRC 檔案成員的 FTP script。
File : QCLSRC
Member: WRKSRCRECT
Type : CLP
Usage : CRTCLPGM PGM(WRTSRCRECT)
CALL WRTSRCREC，執行完後 DSPPFM FILE(QTEMP/QFTPSRC) MBR(MBRLIST) 即可檢視所產生的 FTP script
PGM
DCLF FILE(QAFDMBRL)
DSPFD FILE(QGPL/QDDSSRC) TYPE(*MBRLIST) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/MBRLISTP)
DLTF FILE(QTEMP/QFTPSRC)
MONMSG CPF0000
CRTSRCPF FILE(QTEMP/QFTPSRC)
ADDPFM FILE(QTEMP/QFTPSRC) MBR(MBRLIST)
/* FTP server user and password */
WRTSRCREC SRCFILE(QTEMP/QFTPSRC) SRCMBR(MBRLIST) +
DATA('user password')
/* for DBCS in data need */
WRTSRCREC SRCFILE(QTEMP/QFTPSRC) SRCMBR(MBRLIST) +
DATA('Ltpye c 950')
OVRDBF FILE(QAFDMBRL) TOFILE(QTEMP/MBRLISTP)
READ: RCVF
MONMSG CPF0864 *N GOTO END
WRTSRCREC SRCFILE(QTEMP/QFTPSRC) SRCMBR(MBRLIST) +
DATA('PUT' *BCAT &MLLIB *TCAT '/' +
*CAT &MLNAME *TCAT '.' *CAT &MLNAME +
*BCAT &MLNAME *TCAT '.TXT')
GOTO READ
END: DLTOVR FILE(QAFDMBRL)
WRTSRCREC SRCFILE(QTEMP/QFTPSRC) SRCMBR(MBRLIST) +
DATA('quit')
RETURN
ENDPGM
批次 FTP 範例程式:
File : QCLSRC
Member: FTPSRCTEST
Type : CLP
Usage : CRTCLPGM FTPSRCTEST
CALL FTPSRCTEST
PGM
DCL &SVRIP *CHAR 32
DLTF FILE(QTEMP/QFTPSRC)
MONMSG CPF0000
CRTSRCPF FILE(QTEMP/QFTPSRC)
ADDPFM FILE(QTEMP/QFTPSRC) MBR(MBRLISTOUT)
CALL WRTSRCRECT
OVRDBF FILE(INPUT) TOFILE(QTEMP/QFTPSRC) MBR(MBRLIST)
OVRDBF FILE(OUTPUT) TOFILE(QTEMP/QFTPSRC) MBR(MBRLISTOUT)
/* Specify FTP server here */
CHGVAR &SVRIP 'xxx.xxx.xxx.xxx'
FTP RMTSYS(&SVRIP)
CPYF FROMFILE(OUTPUT) TOFILE(*PRINT)
DLTOVR FILE(INPUT)
DLTOVR FILE(OUTPUT)
ENDPGM
星期一, 11月 06, 2023
2005-04-10 如何於 CLP 中擷取字串的長度？(修正版)(Command RTVSTRLEN)
如何於 CLP 中擷取字串的長度？(修正版)(Command RTVSTRLEN)
由於未注意, command source 部分錯了, 所以從新修改. 很抱歉.
要在 CLP 中取得字串長度，類似 RPGLE 中利用函數 %LEN(%TRIMR(str)) 取得字串長度，可以使用指令模式取得最方便，以下便是 RTVSTRLEN 指令：
File : QCLSRC
Member: RTVSTRLENC
Type : CLP
Usage : CRTCLPGM PGM(RTVSTRLENC) SRCFILE(lib/QCLSRC) SRCMBR(RTVSTRLENC)
The CPP source:
RTVSTRLEN: PGM PARM(&STRING &STRLEN)
DCL VAR(&STRING) TYPE(*CHAR) LEN(5002)
DCL VAR(&STRLENA) TYPE(*CHAR) LEN(2)
DCL VAR(&STRLEN) TYPE(*DEC) LEN(4 0)
CHGVAR VAR(&STRLENA) VALUE(%SST(&STRING 1 2))
CHGVAR VAR(&STRLEN) VALUE(%BIN(&STRLENA))
ENDPGM
File : QCMDSRC
Member: RTVSTRLEN
Type : CMD
Usage : CRTCMD CMD(RTVSTRLEN) PGM(lib/RTVSTRLENC) SRCFILE(lib/QCMDSRC) SRCMBR(RTVSTRLEN) ALLOW(*IPGM *BPGM)
RTVSTRLEN: CMD PROMPT('Retrieve String Length')
PARM KWD(STRING) TYPE(*CHAR) LEN(5000) VARY(*YES +
*INT2) PROMPT('Character string +
(5000)')
PARM KWD(STRLEN) TYPE(*DEC) LEN(4 0) RTNVAL(*YES) +
PROMPT('CL var for return value (4,0)')
2005-03-08 如何於 CLP 中擷取字串的長度？(Command RTVSTRLEN)
如何於 CLP 中擷取字串的長度？(Command RTVSTRLEN)
要在 CLP 中取得字串長度，類似 RPGLE 中利用函數 %LEN(%TRIMR(str)) 取得字串長度，
可以使用指令模式取得最方便，以下便是 RTVSTRLEN 指令：
File : QCLSRC
Member: RTVSTRLENC
Type : CLP
Usage : CRTCLPGM PGM(RTVSTRLENC) SRCFILE(lib/QCLSRC) SRCMBR(RTVSTRLENC)
The CPP source:
RTVSTRLEN: PGM PARM(&STRING &STRLEN)
DCL VAR(&STRING) TYPE(*CHAR) LEN(5002)
DCL VAR(&STRLENA) TYPE(*CHAR) LEN(2)
DCL VAR(&STRLEN) TYPE(*DEC) LEN(4 0)
CHGVAR VAR(&STRLENA) VALUE(%SST(&STRING 1 2))
CHGVAR VAR(&STRLEN) VALUE(%BIN(&STRLENA))
ENDPGM
File : QCMDSRC
Member: RTVSTRLEN
Type : CMD
Usage : CRTCMD CMD(RTVSTRLEN) PGM(lib/RTVSTRLENC) SRCFILE(lib/QCMDSRC) SRCMBR(RTVSTRLEN) ALLOW(*IPGM *BPGM)
RTVSTRLEN: CMD PROMPT('Retrieve String Length')
PARM KWD(STRING) TYPE(*CHAR) LEN(5000) VARY(*YES +
*INT2) PROMPT('Character string +
(5000)')
PARM KWD(STRLEN) TYPE(*DEC) LEN(4 0) RTNVAL(*YES) +
PROMPT('CL var for return value (4,0)')
星期四, 11月 02, 2023
2002-07-19 如何啟動 AS400 作業系統 V5R1 於 Library list 中支援 250 個 Library？
如何啟動 AS400 作業系統 V5R1 於 Library list 中支援 250 個 Library？
AS400 作業系統的 Library list 即是系統搜尋程式或資料庫或其他物件的路徑，類似 PC
的 PATH，Library list 於V4R5以前只能支援 25 個 Library， V5R1 以後，系統已可以支
援 250 個 Library。
於 V5R1 中，如果 dataarea QUSRSYS/QLILMTLIBL 存在，表示系統只允許 library list 容
納 25 個 Library，若你要啟動系統支援 library list 容納 250 個 library，就需要刪除
dataarea QUSRSYS/QLILMTLIBL 即可啟動。
使用指令判斷 dataarea QUSRSYS/QLILMTLIBL 是否存在：
WRKOBJ OBJ(QUSRSYS/QLILMTLIBL) OBJTYPE(*DTAARA)
畫面如下：
Work with Objects
Type options, press Enter.
2=Edit authority 3=Copy 4=Delete 5=Display authority 7=Rename
8=Display description 13=Change description
Opt Object Type Library Attribute Text
QLILMTLIBL *DTAARA QUSRSYS LIMIT USER LIBRARY LIST TO
Bottom
Parameters for options 5, 7 and 13 or command
===>
F3=Exit F4=Prompt F5=Refresh F9=Retrieve F11=Display names and types
F12=Cancel F16=Repeat position to F17=Position to
若你要回複系統僅支援 25 個時，執行下列指令：
Selection or command
===> CRTDTAARA DTAARA(QUSRSYS/QLILMTLIBL) TYPE(*CHAR) LEN(2000) VALUE(' ') TEXT
('LIMIT USER LIBRARY LIST TO 25')
為了於 Library list 中使用 250 個 Library，每個使用到 *LIBL 的程式或 API 均要修改，
如 RTVJOBA USRLIBL(&LIBL) 或 CHGLIBL 均要修改能容納 250 個 Library list 的參數如下：
DCL &LIBL *CHAR 2750
若你啟動後，相關程式沒有更改，程式執行時就會當掉。
V5R1 預設是 dataarea QUSRSYS/QLILMTLIBL 存在的，表示系統預設 library list 仍是使用
25 個 library，即當使用者從早期版本升級至 V5R1 時，不必修改有使用到 *LIBL 的程式，
而交由使用者自行決定是否啟動支援 250 個，使用者也需要更改受影響的程式。
但是 V5R2 後系統預設是 250 個，切記! 您就需要更改有使用 RTVJOBA USRLIBL(&LIBL) 或
CHGLIBL 指令或 某些 library list API 的舊有程式，該程式才能正常運作，否則程式會當掉。
2002-07-18 如何能較容易的編輯 Data Area 內容？使用 CHGDTAARA 嗎？（Command EDTDTAARA 使用 API QWCRDTAA）
如何能較容易的編輯 Data Area 內容？使用 CHGDTAARA 嗎？（Command EDTDTAARA 使用 API QWCRDTAA）
不管是 AS/400(iSeries) 的系統管理人員或程式設計人員，常常會於程式間使用 Data area
做參數傳輸介面，而 Data area 可以是字元或數字型態，當需要更改 Data area 值時，僅能
使用指令 CHGDTAARA，然而此指令介面無法顯示 Data area 原有值，使用起來很不方便，
所以可藉由 Retrieve Data Area API (QWCRDTAA)來完成。以後您可以使用此指令 EDTDTAARA 來直接編輯 Data Area 內容。
File : QDDSSRC
Member: EDTDTAARAD
Type : DSPF
Usage : CRTDSPF FILE(XXX/EDTDTAARAD) SRCFILE(XXX/QDDSSRC)
*===============================================================
* To compile:
*
* CRTDSPF FILE(XXX/EDTDTAARAD) SRCFILE(XXX/QDDSSRC)
*
*===============================================================
A DSPSIZ(24 80 *DS3)
A CF03
A CF12
A R SFLRCD SFL
A DATA 50A B 9 13CHECK(LC)
A OUTPOS 4A O 9 6DSPATR(HI)
A R SFLCTL SFLCTL(SFLRCD)
A SFLSIZ(0024)
A SFLPAG(0012)
A OVERLAY
A 21 SFLDSP
A SFLDSPCTL
A 1 29'Edit data area information'
A 3 2'Data area name . . . . . . . .:'
A INDTAAREA 10A O 3 34
A INLIB 10A O 4 35
A 8 13'....5...10...15...20...25...30...3-
A 5...40...45...50'
A DSPATR(HI)
A 7 14'Value'
A 8 4'Offset'
A 3 48'Type:'
A 4 48'Length:'
A OUTTYP 10A O 3 56
A OUTLEN 4S 0O 4 56
A 4 3'Library . . . . . . . . . . .:'
A OUTDEC 2Y 0O 4 61EDTCDE(Z)
A R FORMAT1
A 23 4'F3=Exit' COLOR(BLU)
A 23 18'F12=Previous' COLOR(BLU)
File : QRPGLESRC
Member: EDTDTAARAR
Type : RPGLE
Usage : CRTBNDRPG PGM(XXX/EDTDTAARAR) SRCMBR(EDTDTAARAR)
*===============================================================
* To compile:
*
* CRTBNDRPG PGM(XXX/EDTDTAARAR) SRCMBR(EDTDTAARAR)
*
*===============================================================
H DftActGrp(*no)
FEDTDTAARADCF E WORKSTN
F SFILE(SFLRCD:RelRecNbr)
f infds(info)
d Info ds
d key 369 369
D Cmd S 2100
D CmdLen S 15 5
D DoRrn S 5 0
D DtaAraName S 20
d F03 c const(x'33')
d F12 c const(x'3C')
D Index S 5 0
D InDtaArea S 10
D InLIb S 10
D Len S 5 0
D OData S 2000
D OutData S 50
D OutPosN S 4 0
d Protect c const(x'A0')
d NonDisplay c const(x'27')
D ReceiveLen S 10i 0
D RelRecNbr S 4 0
D Remainder S 5 0
D Result S 5 0
D RtvLength S 10i 0
D Size S 4 0
D StrPosit S 10i 0 inz(1)
D X S 5 0
D Y S 5 0
D ChgCon c 'CHGDTAARA DTAARA('
D Receiver DS 32000 based(ReceiverPt)
D BytesAvl 10i 0
D BytesAct 10i 0
D TypeReturn 10
D RecLib 10
D RtnLength 10i 0
D NbrDecimal 10i 0
D RcvData 2000
D Receiver1 DS INZ
D BytesPoss 1 4B 0
D BytesRtrnd 5 8B 0
* API error data structure
D ErrorDs DS INZ
D BytesProvd 1 4B 0 inz(116)
D BytesAvail 5 8B 0
D MessageId 9 15
D Err### 16 16
D PackedNums DS
D packed1 1 1p 0
D packed2 1 2p 0
D packed3 1 3p 0
D packed4 1 4p 0
D packed5 1 5p 0
D packed6 1 6p 0
D packed7 1 7p 0
D packed8 1 8p 0
D packed9 1 9p 0
D packed10 1 10p 0
D packed11 1 11p 0
D packed12 1 12p 0
D packed13 1 13p 0
D packed14 1 14p 0
D packed15 1 15p 0
C *ENTRY PLIST
C PARM DtaAraName
C movel DtaAraName InDtaArea
C move DtaAraName InLib
c movel InDtaArea DtaAraName
c move InLib DtaAraName
*
C CALL 'QWCRDTAA'
C PARM Receiver1
C PARM 8 ReceiveLen
C PARM DtaAraName
C PARM -1 StrPosit
C PARM 32000 RtvLength
C PARM ErrorDs
c alloc BytesPoss ReceiverPt
C CALL 'QWCRDTAA'
C PARM Receiver
C PARM BytesPoss ReceiveLen
C PARM DtaAraName
C PARM -1 StrPosit
C PARM BytesPoss RtvLength
C PARM ErrorDs
c z-add RtnLength Size
c z-add RtnLength Len
c If Len > 50
c eval Len = 50
c Endif
c z-add RtnLength OutLen
c z-add NbrDecimal OutDec
c Eval Outtyp = TypeReturn
c Eval Index = 37
c Eval OutPosN = 1
c Dou (Index + Len) > BytesPoss
c If (Index + Len) > BytesPoss
c Eval Len = (BytesPoss - Index) + 1
c else
c Eval Len = 50
c If Len > Rtnlength
c Eval Len = RtnLength
c Endif
c End
c Eval Data = %subst(Receiver:Index:Len)
c If TypeReturn = '*DEC'
c movel data PackedNums
c select
c When Len <= 1
c movel Packed1 OutData
c When Len <= 2
c movel Packed2 OutData
c When Len <= 3
c movel Packed3 OutData
c When Len <= 4
c movel Packed4 OutData
c When Len <= 5
c movel Packed5 OutData
c When Len <= 6
c movel Packed6 OutData
c When Len <= 7
c movel Packed7 OutData
c When Len <= 8
c movel Packed8 OutData
c When Len <= 9
c movel Packed9 OutData
c When Len <= 10
c movel Packed10 OutData
c When Len <= 11
c movel Packed11 OutData
c When Len <= 12
c movel Packed12 OutData
c When Len <= 13
c movel Packed13 OutData
c When Len <= 14
c movel Packed14 OutData
c When Len <= 15
c movel Packed15 OutData
c endsl
c RtnLength Div 2 Result
c Mvr Remainder
c if Remainder <> 0
c movel(p) OutData Data
c else
c eval Data = %subst(OutData:2:RtnLength)
c Endif
c Eval %subst(Data:RtnLength + 2:1) = Protect
c Eval %subst(Data:RtnLength + 1:1) = NonDisplay
c else
c If Len < 50
c Eval %subst(Data:RtnLength + 2:1) = Protect
c Eval %subst(Data:RtnLength + 1:1) = NonDisplay
c Endif
c Endif
c EVAL RelRecNbr = RelRecNbr + 1
c move OutPosN OutPos
C WRITE SFLRCD
c Eval OutPosN = OutPosN + 50
c Eval Index = Index + Len
c Enddo
c If Index < BytesPoss
c eval Len = (BytesPoss - Index) + 1
c Eval Data = %subst(Receiver:Index:Len)
c If len <> 50
c Eval %subst(Data:Len + 2:1) = Protect
c Eval %subst(Data:Len + 1:1) = NonDisplay
c Endif
C Eval RelRecNbr = RelRecNbr + 1
c move OutPosN OutPos
C WRITE SFLRCD
c Endif
c If RelRecNbr > 0
C Eval *In21 = *ON
C Endif
C WRITE FORMAT1
C EXFMT SFLCTL
c If Key <> F03 AND
c Key <> F12
c Exsr UpdateSR
c Endif
c Eval *inlr = *on
c UpdateSR Begsr
c Eval DoRRN = RelRecNbr
c Eval Index = 1
c Do DoRRN x
c x chain SflRcd
c eval %subsT(OData:Index:50) = Data
c eval index = Index + 50
c enddo
c If TypeReturn <> '*DEC'
c Eval Cmd = ChgCon + %trim(Inlib) + '/' +
c %trim(InDtaArea) +
c ') VALUE(''' + %subst(OData:1:Size) +
c ''')'
c Else
c Eval Cmd = ChgCon + %trim(Inlib) + '/' +
c %trim(InDtaArea) + ') VALUE(' +
c %subst(OData:1:(outlen-outdec)) +
c '.' +
c %subst(OData:(outlen-outdec+1):outdec) + ')'
c* Eval Cmd = ChgCon + %trim(Inlib) + '/' +
c* %trim(InDtaArea) + ') VALUE(' +
c* %subst(OData:1:Size) + ')'
c Endif
c
c ' ' Checkr Cmd Len
c z-add Len CmdLen
c call 'QCMDEXC'
c parm Cmd
c parm CmdLen
c Endsr
File : QCMDSRC
Member: EDTDTAARA
Type : CMD
Usage : CRTCMD CMD(XXX/EDTDTAARA) PGM(XXX/EDTDTAARAR)
/*==================================================================*/
/* To compile: */
/* */
/* CRTCMD CMD(XXX/EDTDTAARA) PGM(XXX/EDTDTAARAR) */
/* */
/*==================================================================*/
CMD PROMPT('Edit Data Area')
PARM KWD(DTAARA) TYPE(QUAL) MIN(1) DTAARA(*YES) +
PROMPT('Data Area')
QUAL: QUAL TYPE(*NAME) LEN(10)
QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) +
SPCVAL((*LIBL)) PROMPT('Library')
2002-07-15 如何檢查 IFS 檔案是否存在 (Command CHKOBJLNK) ?
如何檢查 IFS 檔案是否存在 (Command CHKOBJLNK) ?
由於現在有許多的應用軟體（HTTP power by Apache，Websphere 系列產品，Java等，你可以使用 WRKLNK 檢視有哪些路徑）會採用 AS/400 中的
IFS 檔案架構(與 PC windows 檔案架構類似)，所以有時會將檔案寫入 IFS 檔案，所以需
要檢查檔案是否存在，你可以使用下列指令檢查：
File : QCLSRC
Member: CHKOBJLNKC
Type : CLP
Usage : CRTCLPGM PGM(CHKOBJLNK)
/* CHECK OBJECT LINK */
PGM PARM(&OBJ &OBJERROR)
DCL VAR(&OBJ) TYPE(*CHAR) LEN(512)
DCL VAR(&OBJERROR) TYPE(*LGL)
DCL VAR(&OFF) TYPE(*LGL) VALUE('0')
DCL VAR(&ON) TYPE(*LGL) VALUE('1')
DCL VAR(&SPLF) TYPE(*CHAR) LEN(10) VALUE(CHKOBJLNK)
/* TURN ERROR FLAG OFF */
CHGVAR VAR(&OBJERROR) VALUE(&OFF)
/* CHECK TO SEE IF THE OBJECT EXISTS */
OVRPRTF FILE(*PRTF) HOLD(*YES) SPLFNAME(&SPLF) +
OVRSCOPE(*CALLLVL)
DSPLNK OBJ(&OBJ) OUTPUT(*PRINT) OBJTYPE(*ALL) +
DETAIL(*BASIC) DSPOPT(*USER)
MONMSG MSGID(CPFA0A9) EXEC(CHGVAR VAR(&OBJERROR) +
VALUE(&ON))
/* DELETE THE SPOOL FILE */
DLTSPLF FILE(&SPLF) SPLNBR(*LAST)
MONMSG MSGID(CPF0000)
ENDPGM
File : QCMDSRC
Member: CHKOBJLNK
Type : CMD
Usage : CRTCMD CMD(CHKOBJLNK) PGM(CHKOBJLNKC)
於 CLP 中使用指令 CHKOBJLNK OBJ(xxx) OBJERROR(&OBJERROR)
此指令會回傳值'1'表物件不存在，'0'表物件存在
/* CHECK OBJECT LINK */
CMD PROMPT('Check object link')
PARM KWD(OBJ) TYPE(*PNAME) LEN(512) MIN(1) +
PROMPT('Object Link to check')
PARM KWD(OBJERROR) TYPE(*LGL) RTNVAL(*YES) +
PROMPT('Object error')
2002-07-01 如何讓 AS/400 全系統備份自動化？
如何讓 AS/400 全系統備份自動化？
AS/400 全系統備份需要在專屬模式（restrictive state）下及需要在中控台（console）
上執行備份指令才能完成，由於專屬模式下，所有的使用者作業及所有子系統均已被停止
，只有系統作業及從中控台進入系統（SignOn）的線上即時作業可以正常執行，所以我們
可以利用中控台上的線上即時作業（interactive job）自動執行全系統備份作業。
做法是：
１：從中控台進入系統（SignOn），執行下列的指令，在程式中會從訊息佇列
（message queue）中讀取訊息，訊息佇列若沒有訊息時，程式會等待有訊息時才讀取，並判斷是否執行全系統備份作業。
２：於排程作業中設定某時間傳送訊息至訊息佇列，以啟動或終止備份作業。
File : QCLSRC
Member: FULSAVC
Type : CLP
Usage :
1. 新增訊息佇列 SAVSYSMSGQ: Yourlib - 指定您自己的 Library
CRTMSGQ MSGQ(Yourlib/SAVSYSMSGQ) TEXT('Message Queue for Unattended full save')
2. 修改程式中 Yourlib - 指定您自己的 Library 及 console DSP01 --指定您自己的 console 名稱
CRTCLPGM FULSAVC
CRTCMD CMD(FULSAV) PGM(Yourlib/FULSAVC)
3. 新增自動工作排程傳送啟動備份訊息 Yourlib - 指定您自己的 Library
此範例指定，此作業於每個星期天 16:55 執行：
ADDJOBSCDE JOB(BIGSAV) CMD(SNDMSG MSG('STRSAVSYS') TOMSGQ(Yourlib/SAVSYSMSGQ))
FRQ(*WEEKLY) SCDDATE(*NONE) SCDDAY(*SUN) SCDTIME('16:55:00') JOBQ(QGPL/QBASE)
USER(QSECOFR) TEXT('Send a message to start full system save.')
如果要取消份作業，上述指令 CMD 參數更改如下：
SNDMSG MSG( 'ENDSAVSYS' ) TOMSGQ( Yourlib/SAVSYSMSGQ)
4. 於星期五下班前，從 Console Sign On 進入系統，於命令列輸入 FULSAV，系統即進入等待上述啟動備份訊息
當每個星期天 16:55 時間到達時，系統會收到訊息判斷是否啟動備份作業。
附註：
由於資料量及磁帶容量與磁帶機設備不同，所以有可能需要一卷以上的磁帶做備份，若由於設備不足，您還是
要由人工換磁帶。使用此範例前，請先測試無問題後，在正式實施。
/* ***************************************************************** */
/* * * */
/* * * */
/* * TITLE........: Weekly Savsys & Full Nonsys Save (FULSAVC) * */
/* * * */
/* * * */
/* ***************************************************************** */
/* * * */
/* * To run an unattended SAVSYS, you can add a job scheduler * */
/* * entry as follows: * */
/* * * */
/* * SNDMSG MSG( 'STRSAVSYS' ) TOMSGQ( Yourlib/SAVSYSMSGQ) * */
/* * * */
/* * Specify the date and time you want the message to be sent. * */
/* * You should call this program from the console, and when the * */
/* * job scheduler sends the message the program will continue * */
/* * and perform the SAVSYS & full *NONSYS save followed by IPL. * */
/* * * */
/* * Note that by sending message ENDSAVSYS you can cause this * */
/* * program to end without performing the SAVSYS etc. * */
/* * * */
/* ***************************************************************** */
PGM
/* ***************************************************************** */
/* Declare Program Variables * */
/* ***************************************************************** */
DCL VAR(&MSG) TYPE(*CHAR) LEN(9) /* Message */
DCL VAR(&JOB) TYPE(*CHAR) LEN(10) /* This Job */
DCL VAR(&COUNT) TYPE(*DEC) LEN(4 0) VALUE(0) /* Retry */
/* ***************************************************************** */
/* Main Processing * */
/* ***************************************************************** */
/* Allocate the message queue to this job so it has exclusive ' */
/* use of the message queue so we can receive and remove ' */
/* messages from the queue. If we're unable to obtain the ' */
/* exclusive lock, then another job is using the queue and ' */
/* this job will cancel. ' */
ALCOBJ OBJ((Yourlib/SAVSYSMSGQ *MSGQ *EXCL)) WAIT(0)
MONMSG MSGID(CPF0000) EXEC(SNDPGMMSG MSGID(CPF9897) +
MSGF(QCPFMSG) MSGDTA('Unable to allocate +
SAVSYS message queue.') TOUSR(*SYSOPR) +
MSGTYPE(*ESCAPE))
/* Make sure that we are running on DSP01 (The Console)' */
/* If we're not, this job will end when we do ENDSBS *ALL *IMMED! */
RTVJOBA JOB(&JOB)
IF COND(&JOB *NE 'DSP01 ') THEN(SNDPGMMSG +
MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA('DO +
IT ON THE CORRECT SCREEN YOU MUPPET!!!!') +
MSGTYPE(*ESCAPE))
/* Remove any old messages from message queue */
RMVMSG MSGQ(Yourlib/SAVSYSMSGQ) CLEAR(*ALL)
/* Change this job's message queues to *Hold so we don't get any. */
CHGJOB LOGCLPGM(*YES) BRKMSG(*NOTIFY)
CHGMSGQ MSGQ(*USRPRF) DLVRY(*HOLD)
MONMSG MSGID(CPF2451)
CHGMSGQ MSGQ(*WRKSTN) DLVRY(*NOTIFY)
/* Receive messages in the queue. WAIT(*MAX) tells the system */
/* to wait for a message forever if no messages are in the */
/* queue. Once the message is received, it will be removed. */
Loop:
SNDPGMMSG MSGID(CPF9898) MSGF(QSYS/QCPFMSG) +
MSGDTA('Waiting for somebody to tell me +
to start save of entire system........') +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGJOB STSMSG(*NONE)
RCVMSG MSGQ(Yourlib/SAVSYSMSGQ) MSGTYPE(*ANY) +
WAIT(*MAX) RMV(*YES) MSG(&MSG)
CHGJOB STSMSG(*SYSVAL)
/* If the message is neither STRSAVSYS or ENDSAVSYS, ignore */
IF COND((&MSG *NE 'STRSAVSYS') *AND (&MSG *NE +
'ENDSAVSYS')) THEN(GOTO CMDLBL(LOOP))
/* If the message is STRSAVSYS, continue with Saves */
IF COND(&MSG *EQ 'STRSAVSYS') THEN(DO)
/* Send Start of wait Message to Qsysopr */
SNDPGMMSG MSG(SAVSYS starting in 5 mins.) +
TOMSGQ(*SYSOPR)
/* Send message to all users telling them to sign off */
SNDPGMMSG +
MSG(' -
****** The Backups for tonight will start in 5 minutes... +
Please sign off the AS/400 +
Immediately. *******') TOUSR(*ALLACT)
/* Delay job for next five minutes */
SNDPGMMSG MSGID(CPF9898) MSGF(QSYS/QCPFMSG) +
MSGDTA('Waiting for five minutes while +
users sign off........................') +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGJOB STSMSG(*NONE)
DLYJOB DLY(300)
CHGJOB STSMSG(*SYSVAL)
/* End all the subsystems */
Loop3: SNDPGMMSG MSGID(CPF9898) MSGF(QSYS/QCPFMSG) +
MSGDTA('Ending all the subsystems.....') +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGJOB STSMSG(*NONE)
ENDSBS SBS(*ALL) OPTION(*IMMED)
/* Delay job for next four minutes */
CHGJOB STSMSG(*SYSVAL)
SNDPGMMSG MSGID(CPF9898) MSGF(QSYS/QCPFMSG) +
MSGDTA('Waiting for four minutes while +
Subsystems are ended..................') +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGJOB STSMSG(*NONE)
DLYJOB DLY(240)
/* Start SAVSYS */
CHGJOB STSMSG(*SYSVAL)
SNDPGMMSG MSGID(CPF9898) MSGF(QSYS/QCPFMSG) +
MSGDTA('Saving the system (SAVSYS)... +
......................................') +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGJOB STSMSG(*NONE)
/* Loop 2 tries to do a savsys. If the system is not yet in */
/* restricted state, a count is incremented, and the program waits */
/* another two minutes and tries again. */
LOOP2: SAVSYS DEV(TAP03) ENDOPT(*LEAVE) OUTPUT(*PRINT) +
CLEAR(*ALL)
MONMSG MSGID(CPF3785) EXEC(DO)
CHGVAR VAR(&COUNT) VALUE(&COUNT + 1)
/* If we have retried 12 times (24 minutes), NYCOMSGR is started and */
/* a message is sent to QSYSOPR to be paged out. The program then */
/* loops to LOOP3 to attempt Endsbs *all *immed again. */
IF COND(&COUNT *GE 12) THEN(DO)
STRSBS SBSD(NYCOMSGR)
DLYJOB DLY(120)
SNDMSG MSG('The system wont go down on me!!') +
TOUSR(*SYSOPR)
GOTO CMDLBL(LOOP3)
ENDDO
DLYJOB DLY(120)
GOTO CMDLBL(LOOP2)
ENDDO
CHGJOB STSMSG(*SYSVAL)
/* Start SAVLIB *NONSYS */
SNDPGMMSG MSGID(CPF9898) MSGF(QSYS/QCPFMSG) +
MSGDTA('Saving all the user libraries +
(SAVLIB *NONSYS).....................') +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGJOB STSMSG(*NONE)
SAVLIB LIB(*NONSYS) DEV(TAP03) ENDOPT(*LEAVE) +
CLEAR(*AFTER) ACCPTH(*YES) OUTPUT(*PRINT)
MONMSG MSGID(CPF3777) EXEC(SNDMSG MSG('Not All +
objects Saved On Sunday Night!!!! Look at +
log of job DSP01') TOMSGQ(GSKELTON +
ACUSWORTH JBARRY DCOLAM DSTEER))
CHGJOB STSMSG(*SYSVAL)
/* Start SAVDLO */
SNDPGMMSG MSGID(CPF9898) MSGF(QSYS/QCPFMSG) +
MSGDTA('Saving all Document libraries +
(SAVDLO DLO(*ALL)....................') +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGJOB STSMSG(*NONE)
SAVDLO DLO(*ALL) FLR(*ANY) DEV(TAP03) +
ENDOPT(*LEAVE) OUTPUT(*PRINT) CLEAR(*AFTER)
CHGJOB STSMSG(*SYSVAL)
/* Start save of all directory objects */
SNDPGMMSG MSGID(CPF9898) MSGF(QSYS/QCPFMSG) +
MSGDTA('Saving all Directory objects (SAV +
OBJ((''/*'')......................') +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGJOB STSMSG(*NONE)
SAV DEV('/QSYS.LIB/TAP03.DEVD') OBJ(('/*') +
('/QSYS.LIB' *OMIT) ('/QDLS' *OMIT)) +
OUTPUT(*PRINT) ENDOPT(*UNLOAD) +
UPDHST(*YES) CLEAR(*AFTER)
CHGJOB STSMSG(*SYSVAL)
/* Apply PTFs permanently */
SNDPGMMSG MSGID(CPF9898) MSGF(QSYS/QCPFMSG) +
MSGDTA('Applying PTFs.................... +
..................................') +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGJOB STSMSG(*NONE)
APYPTF LICPGM(*ALL) APY(*PERM) DELAYED(*YES)
MONMSG MSGID(CPF3660)
CHGJOB STSMSG(*SYSVAL)
/* Power Down the System */
SNDPGMMSG MSGID(CPF9898) MSGF(QSYS/QCPFMSG) +
MSGDTA('Powering down the system......... +
..................................') +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGJOB STSMSG(*NONE)
PWRDWNSYS OPTION(*IMMED) RESTART(*YES)
CHGJOB STSMSG(*SYSVAL)
ENDDO
/* The program would not normally get to this point. If it does, */
/* it is because the message 'ENDSAVSYS' has been received. */
/* The job will now sign off for security. */
SIGNOFF LOG(*LIST)
ENDPGM
/* ***************************************************************** */
星期三, 11月 01, 2023
2002-06-13 如何限制使用者使用 CHGJOB 更改 Job 的 Job Priority 及 Run Priority 或 Batch Job 的 Job Queue ?
如何限制使用者使用 CHGJOB 更改 Job 的 Job Priority 及 Run Priority 或 Batch Job 的 Job Queue ?
有時候使用者會用到 WRKSBMJOB 指令或應用軟體中有 WRKSBMJOB，WRKACTJOB 的選項時，
那使用者就有機會使用選項 2=Change(CHGJOB) 針對自己的工作站 Job 或 自己所送出的
Batch Job 更改 Run Priority 或 Batch Job 的JobQ，那就可以使用 CHGCMD 指令設定
該指令參數VLDCKR 檢核程式來加以限制只有某些使用者可以更改 JOB RUNPTY 及 JOBQ 屬性。
CHGCMD CMD(CHGJOB) VLDCKR(libery/CHGJOBVLDC)
File : QCLSRC
Member: CHGJOBVLDC
Type : CLP
Usage : CRTCLPGM CHGJOBVLDC
CHGCMD CMD(CHGJOB) VLDCKR(libery/CHGJOBVLDC)
/* You can use CHGCMD to include a validity checking program */
/* (VLDCKR)that will prevent all but designated users or groups */
/* of users from using the CHGJOB command. Below is an example */
/* of such a program: */
PGM PARM(&JOBNAM &JOBQ &JOBPTY &OUTPTY &PRTTXT +
&MSGLG &MSGL2 &MSGL3 &BRKMS &STSMSG +
&PRTDV &OUTQ &DDM &SCDDT &SCDTM &JOBDT +
&DATSEP &PARM18 &PARM19 &PARM20 &PARM21 +
&RUNPTY &PARM23 &PARM24 &PARM25 &PARM26 +
&PARM27 &PARM28 &PARM29 &PARM30 &PARM31 +
&PARM32 &PARM33 &PARM34 &PARM35 &PARM36 +
&PARM37)
DCL VAR(&USRCLS) TYPE(*CHAR) LEN(10)
DCL VAR(&GRPPRF) TYPE(*CHAR) LEN(10)
DCL VAR(&USRPRF) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNAM) TYPE(*CHAR) LEN(26)
DCL VAR(&JOBQ) TYPE(*CHAR) LEN(20)
DCL VAR(&JOBPTY) TYPE(*CHAR) LEN(1)
DCL VAR(&OUTPTY) TYPE(*CHAR) LEN(1)
DCL VAR(&PRTTXT) TYPE(*CHAR) LEN(30)
DCL VAR(&MSGLG) TYPE(*CHAR) LEN(8)
DCL VAR(&MSGL2) TYPE(*CHAR) LEN(1)
DCL VAR(&MSGL3) TYPE(*CHAR) LEN(1)
DCL VAR(&BRKMS) TYPE(*CHAR) LEN(7)
DCL VAR(&STSMSG) TYPE(*CHAR) LEN(7)
DCL VAR(&PRTDV) TYPE(*CHAR) LEN(10)
DCL VAR(&OUTQ) TYPE(*CHAR) LEN(20)
DCL VAR(&DDM) TYPE(*CHAR) LEN(1)
DCL VAR(&SCDDT) TYPE(*CHAR) LEN(7)
DCL VAR(&SCDTM) TYPE(*CHAR) LEN(7)
DCL VAR(&JOBDT) TYPE(*CHAR) LEN(7)
DCL VAR(&DATSEP) TYPE(*CHAR) LEN(3)
DCL VAR(&PARM18) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM19) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM20) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM21) TYPE(*CHAR) LEN(250)
DCL VAR(&RUNPTY) TYPE(*CHAR) LEN(2)
DCL VAR(&PARM23) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM24) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM25) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM26) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM27) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM28) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM29) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM30) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM31) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM32) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM33) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM34) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM35) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM36) TYPE(*CHAR) LEN(250)
DCL VAR(&PARM37) TYPE(*CHAR) LEN(250)
/*-------------------------------------------------------------------*/
/* GLOBAL MONMSG */
/*-------------------------------------------------------------------*/
MONMSG (CPF0000 MCH0000) EXEC(GOTO ERROR)
RTVUSRPRF RTNUSRPRF(&USRPRF) GRPPRF(&GRPPRF) +
USRCLS(&USRCLS)
IF COND(&USRCLS = '*SECOFR' *OR +
&GRPPRF = '*PGMR' *OR +
&USRPRF = 'QSYSOPR' *OR +
&USRCLS = '*SYSOPR' *OR +
&USRPRF = 'JONES' *OR +
&USRCLS = '*SECADM') THEN( GOTO OK)
/*-------------------------------------------------------------------*/
/* REFERENCE JOBQ PARAMETER &JOBQ TO SEE IF A POINTER IS SET. */
/* JOBPTY PARAMETER &JOBPTY */
/* RUNPTY PARAMETER &RUNPTY */
/*-------------------------------------------------------------------*/
CHGVAR &JOBQ '*SAME'
MONMSG MCH3601 EXEC(GOTO JOBPTY)
GOTO NOTAUT
JOBPTY:
CHGVAR &JOBPTY '*SAME'
MONMSG MCH3601 EXEC(GOTO RUNPTY)
GOTO NOTAUT
RUNPTY:
CHGVAR &RUNPTY '*SAME'
MONMSG MCH3601 EXEC(GOTO OK)
/*-------------------------------------------------------------------*/
/* USER IS NOT AUTHORIZED TO THE RUNPTY PARAMETER OR JOBQ PARAMETER */
/*-------------------------------------------------------------------*/
NOTAUT:
SNDPGMMSG MSGID(CPD0006) +
MSGF(QSYS/QCPFMSG) +
MSGDTA('0000NOT AUTHORIZED TO CHANGE RUN PRIORITY OR +
JOBQ.') +
TOPGMQ(*PRV) +
MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) +
MSGF(QSYS/QCPFMSG) +
TOPGMQ(*PRV) +
MSGTYPE(*ESCAPE)
/*-------------------------------------------------------------------*/
/* REMOVE THE MCH3601 MESSAGE FROM THE JOB MESSAGE QUEUE (JOBLOG) */
/*-------------------------------------------------------------------*/
OK:
RCVMSG MSGQ(*PGMQ) +
MSGTYPE(*LAST) +
RMV(*YES)
RETURN
/*-------------------------------------------------------------------*/
/* ERROR HANDLER */
/*-------------------------------------------------------------------*/
ERROR:
SNDPGMMSG MSGID(CPD0006) +
MSGF(QSYS/QCPFMSG) +
MSGDTA('0000ERROR IN CHGJOB VALIDITY CHECKING PROGRAM. +
SEE JOBLOG.') +
TOPGMQ(*PRV) +
MSGTYPE(*DIAG)
MONMSG (CPF0000 MCH0000)
SNDPGMMSG MSGID(CPF0002) +
MSGF(QSYS/QCPFMSG) +
TOPGMQ(*PRV) +
MSGTYPE(*ESCAPE)
MONMSG (CPF0000 MCH0000)
/*-------------------------------------------------------------------*/
/* END OF PROGRAM */
/*-------------------------------------------------------------------*/
ENDPGM
2002-05-16 如何監控某些 System Job 所產生的錯誤訊息?(利用 MSGD 參數 DFTPGM)
如何監控某些 System Job 所產生的錯誤訊息?(利用 MSGD 參數 DFTPGM)
某些 System Job 於執行中會產生錯誤訊息, 若 System Job 程式本身將該錯誤訊息忽略,
則該錯誤訊息依錯誤嚴重性, System Job 程式有可能將該錯誤訊息傳送至 QSYSOPR Message
Queue(訊息佇列), 或僅將該錯誤訊息送至該 System Job 本身的 Job Log.
若錯誤訊息傳送至 QSYSOPR 則利用 DSPMSG QSYSOPR 命令較容易查知系統有何異樣,
可利用前期電子報"如何自動監控 QSYSOPR message queue 內的硬體重要 Attention 訊息？" 來達到及時監控.
若錯誤訊息僅送至 System Job 本身的 Job Log, 有三種情況產生:
1. 錯誤訊息送至 System Job 本身的 Job Log 後, 該 System Job 不正常中斷, 並自動產生
報表 QPJOBLOG. 因為程式中斷, 且產生報表 QPJOBLOG, 系統人員需瀏覽報表以找出錯誤
原因,並記下該錯誤訊息代碼 MSGID.
2. 錯誤訊息送至 System Job 本身的 Job Log 後, 該 System Job 不正常中斷, 於 WRKACTJOB
畫面中顯示狀態 MSGW 等待回覆訊息.因為狀態 MSGW 等待回覆訊息, 系統人員需檢視該
System Job 的 Job Log, 以找出錯誤原因,並記下該錯誤訊息代碼 MSGID, 再回覆訊息.
3. 由於 System Job 程式中直接監控該錯誤訊息,所以錯誤訊息僅送至 System Job 本身的 Job
Log , 且該 System Job 程式繼續執行. 這種情形是較難的, 因為使用者只說明他的作業不能做,
且系統並沒有 Message Queue 可供查核錯誤訊息, 此時僅能執行命令
WRKOBJLCK OBJ(userprofile) OBJTYPE(*USRPRF)
顯示該使用者所有的 Job, 從中檢視每個 Job 的 Job Log, 以找出錯誤原因,並記下該錯誤訊息代碼 MSGID.
以上三種情況對於系統管理人員或使用者均不會知道系統發生了什麼事, 尤其是系統管理人員
若未即時發現問題, 就只能等使用者反映問題,再行處理.
以上所說的 System Job 最常發生在 Client Access Host Server 的 Server Job 上,
事實上系統人員根本無法預知 System Job 會有何種錯誤訊息發生, 基本上只能從所有已發生
的錯誤訊息中學習, 避免同樣的錯誤再次發生或同樣的錯誤發生時系統能即時通知相關人員處理.
那要如何於同樣的錯誤發生時系統能即時通知相關人員呢?
(為何允許同樣的錯誤再發生呢? 因為 System Job 系統程式相關性很大, 且一般應用軟體設定
若不周全或跨系統時, 則會導致相同的錯誤發生)
所以錯誤訊息的監控基本上均架構在訊息代碼 MSGID 上, AS/400(iSeries) 上訊息代碼
MSGD 中參數 DFTPGM 可設定為當該訊息產生時, 馬上執行 DFTPGM 中所指定的程式,即可即
時處理相關作業, 如紀錄使用者當時的訊息獲通知相關人員處理.
File : QCLSRC
Member: MSGDFTPGMC
Type : CLP
Usage : CRTCLPGM MSGDFTPGMC
/* MONITOR CPF9006 CHGMSGD DFTPGM(MSGDFTPGMC) */
/* BECAUSE THE MESSAGE NOT SENT TO QSYSOPR UNDER SYSTEM BATCH JOB */
/* QPWFSERVSO WHEN USER USE NEIGHBERHOOD ON CA 3.2. */
/* AND OPERATOR NEVER KNOW WHO GOT THE ERROR OR SOMEONE NO AUTHORIZE */
/* ACCESS SYSTEM RESOURCE. */
/* THE PROGRAM WILL SEND MESSAGE TO QSYSOPR */
/* BUT THE BEST WAY IS SETUP THE USER DIRECTORY AND USERPROFILE */
/* CREATE AT THE SAME TIME. */
/* Reference : CL Command ADDMSGD */
PGM (&PARM1 &PARM2)
DCL VAR(&PARM1) TYPE(*CHAR) LEN(277)
DCL VAR(&PARM2) TYPE(*CHAR) LEN(4) /* MSG KEY */
DCL VAR(&PGMNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&MODNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&ILETYPE) TYPE(*CHAR) LEN(1)
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(20)
CHGVAR &PGMNAME %SST(&PARM1 1 10)
CHGVAR &MODNAME %SST(&PARM1 11 10)
CHGVAR &ILETYPE %SST(&PARM1 277 1)
RCVMSG MSGKEY(&PARM2) RMV(*NO) MSGDTA(&MSGDTA)
SNDPGMMSG MSGID(CPF9006) MSGF(QCPFMSG) MSGDTA(&MSGDTA) +
TOPGMQ(*EXT) TOMSGQ(*SYSOPR)
ENDPGM
File : QCLSRC
Member: MSGDFTPGMC
Type : CLP
Usage : CRTCLPGM MSGDFTPGMC
CHGMSGD MSGID(CPF9006) MSGF(QCPFMSG) DFTPGM(your library/MSGDFTPGMC)
WRKDIRE to confirm calling test program user profile not in directory
Test program: CALL MSGDFTPGMT, then the CPF9006 message will send to QSYSOPR
/* FOR TEST THE MSGDFTPGMC MONITOR CPF9006 */
/* CALL THE PROGRAM USE A USER NOT IN DIRECTORY ENTRY */
/* */
/* THEN YOU WILL SEE A MESSAGE ON QSYSOPR */
PGM
SNDNETF FILE(your library/QCLSRC) TOUSRID((TEST SYSTEM)) +
MBR(MSGDFTPGMC)
ENDPGM
2002-05-06 如何於應用軟體中建立類似系統的 Command line ?
如何於應用軟體中建立類似系統的 Command line ?
File : QDDSSRC
Member: SHELL
Type : DSPF
Usage : CRTDSPF SHELL
A R LINE BLINK
A OVERLAY
A CF03(03 'exit')
A CF04(04 'prompt')
A CF08(08 'retrieve')
A CF09(09 'retrieve')
A CF12(12 'cancel')
A 1 32'Sample Command Line' DSPATR(HI)
A 20 2'Type command, press Enter.'
A 21 2'===>'
A COMMAND 153A B 21 7DSPATR(UL) CHECK(LC)
A 23 2'F3=Exit F4=Prompt -
A F8=RetrieveA F9=Retrieve -
A F12=Cancel'
A COLOR(BLU)
*
A R MSGSFL SFL
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
A PROGRAM SFLPGMQ(10)
*
A R MSGCTL SFLCTL(MSGSFL)
A OVERLAY
A SFLDSP
A SFLDSPCTL
A SFLINZ
A SFLSIZ(25)
A SFLPAG(1)
*
A 99 SFLEND
A PROGRAM SFLPGMQ(10)
File : QCLSRC
Member: BLDCMDLINE
Type : CLP
Usage : CRTCLPGM BLDCMDLINE
CALL BLDCMDLINE
Pgm
Dclf File(Shell)
Dcl &ArchiveKey *char 4
Dcl &Big *char 6000
Dcl &BoundryKey *char 4
Dcl &Length *dec 5
Dcl &Sender *char 80
Dcl &TravelKey *char 4
Dcl &Type *char 10
Dcl &Option *char 20 -
value(X'0000000200000000000000000000000000000000')
Top: /* set new request message boundary */
SndPgmMsg MsgType(*Rqs) KeyVar(&BoundryKey) ToPgmq(*Same) Msg('/* */')
RcvMsg MsgType(*Rqs) MsgKey(&BoundryKey) Rmv(*No) Sender(&Sender)
ChgVar &Program %sst(&Sender 56 10)
ChgVar &IN99 '1'
Full: /* try to get full 6000-byte command */
ChgVar &Big &Command
If (&Big = ' ') (ChgVar &TravelKey ' ')
If (&IN04 = '1' *and &TravelKey *NE ' ') Do
RcvMsg MsgType(*Rqs) MsgKey(&TravelKey) Rmv(*No) Msg(&Big)
If (%sst(&Command 1 150) *NE %sst(&Big 1 150)) (Chgvar &Big &Command)
Enddo
F8_or_F9: /* retrieve prior requests */
If (&IN08 = '1' *and &TravelKey = ' ') (ChgVar &Type '*FIRST')
Else If (&IN08 = '1') (ChgVar &Type '*NEXT ')
Else If (&IN09 = '1' *and &TravelKey = ' ') (ChgVar &Type '*LAST ')
Else If (&IN09 = '1') (ChgVar &Type '*PRV ')
Else (Goto Archive)
Call QMHRTVRQ (&Big X'00001770' RTVQ0100 &Type &TravelKey X'00000000')
If (%bin(&Big 5 4) = 0 *and &TravelKey = ' ') (Goto Wait)
ChgVar &TravelKey ' '
If (%bin(&Big 5 4) = 0) (Goto F8_or_F9) /* now try *FIRST or *LAST */
ChgVar &TravelKey %sst(&Big 9 4)
ChgVar &Length %bin(&Big 33 4)
Chgvar &Big %sst(&Big 41 &Length)
Chgvar &Command &Big
If (%sst(&Command 1 2) = '/*') (Goto F8_or_F9) /* ignore comments */
If (&Length > 153) (ChgVar %sst(&Command 151 3) '...') /* ellipsis */
Goto Wait
Archive: /* archive command into job log */
If (&Big = ' ') (Goto Wait)
SndPgmMsg MsgType(*Rqs) KeyVar(&ArchiveKey) ToPgmq(*Same) Msg(&Big)
RcvMsg MsgType(*Rqs) MsgKey(&ArchiveKey) Rmv(*No)
Execute: /* execute command */
ChgVar &TravelKey ' '
ChgVar %sst(&Option 5 7) ('020' || &ArchiveKey)
If (&IN04 = '1') (ChgVar %sst(&Option 6 1) '1')
Call QCAPCMD (&Big X'00001770' &Option X'00000014' -
CPOP0100 ' ' X'00000000' ' ' X'00000000')
MonMsg CPF6801
MonMsg CPF0000 Exec(Goto Wait)
ChgVar &Command ' '
Wait: /* prompt for next command */
Sndf RcdFmt(MsgCtl)
SNDRcvf RcdFmt(Line)
RmvMsg MsgKey(&BoundryKey)
If (&IN03 *NE '1' *and &IN12 *NE '1') (Goto Top)
EndPgm
Process Command (QCAPCMD) API
Process Commands (QCAPCMD) API
此 API 做到下列事項
1. 在執行命令前,檢核命令語法
2. 顯示命令輔助畫面及接收命令參數(按F4 Prompt)
3. 執行指令
Process Command (QCAPCMD) API parameter list:
1 Source command string Input Char(*)
2 Length of source command string Input Binary(4)
3 Options control block Input Char(*)
The options control block is a QCAPCMD API parameter that lets you specify further options for how the command string is to be processed. This parameter is a character string that you must lay out according to API format CPOP0100 . Here are the possible values for each field of this format:
Type of Command Processing:
0 Command running: same function as QCMDEXC API
1 Command syntax check: same function as QCMDCHK API
2 Command line running: same as QCMDEXC with the addition of limited-user checking and prompting for missing required parameters
3 Command line syntax check: same as 2 except the command is not executed
4 CL program statement: the command string is checked for validity as a source code statement — the same checking that Source Entry Utility (SEU) provides for source-type CL programs
5 CL input stream: same type of checking as 4 for source-type CL job streams
6 Command definition statements: same type of checking as 4 for source-type command definitions
7 Binder definition statements: same type of checking as 4 for source-type binder definitions
8 User-defined option: checked for validity as a user-defined option for Programming Development Manager
Double-Byte Character Set (DBCS) Data Handling:
0 Ignore DBCS data
1 Handle DBCS data
Prompter Action:
0 Do not prompt even if selective prompting characters are present in the command string.
1 Prompt the command even if there are no selective prompting characters present.
2 Prompt the command only if selective prompting characters are present in the command string.
Command String Syntax:
0 AS/400 syntax
1 S/38 syntax
4 Options control block length Input Binary(4)
20 minimum value for CPOP0100 format
5 Options control block format Input Char(8)
CPOP0100 only valid value
6 Changed command string Output Char(*)
7 Length available for changed command string input Binary(4)
8 Length of changed command string available to return Output Binary(4)
9 Error code I/O Char(*)
==========================================================================================================
Retrieve Request Message (QMHRTVRQ) API
retrieves request messages from the current job's call message queue
parameter list:
1 Message information Output Char(*)
Offset Type RTVQ0100 Format
0 Binary(4) Bytes returned
4 Binary(4) Bytes available
8 Char(4) Message key
12 Char(20) Reserved
32 Binary(4) Length of request message text returned
36 Binary(4) Length of request message text available
40 Char(*) Request message text
Offset Type RTVQ0200 Format
0 Binary(4) Bytes returned
4 Binary(4) Bytes available
8 Char(4) Message key
12 Char(10) Program or service program name
22 Char(1) Receiving call stack entry type
0 OPM program
1 ILE procedure name
2 long ILE procedure name 23 Char(10) Module name
33 Char(256) Procedure name
289 Char(11) Reserved
300 Binary(4) Offset to long procedure name
304 Binary(4) Length of long procedure name
308 Binary(4) Length of request message returned
312 Binary(4) Length of request message text available
316 Char(*) Request message text
* Char(*) Long procedure name
2 Length of message information Input Binary(4)
3 Format name Input Char(8)
RTVQ0100 Basic request message information
RTVQ0200 All request message information
4 Message type Input Char(10)
*FIRST Retrieve the first request message in the current job *LAST Retrieve the last request message in the current job *NEXT Retrieve the request message after the message indicated by message key parameter *PRV Retrieve the request message before the message indicated by message key parameter
5 Message key Input Char(4)
6 Error code I/O Char(*)
2002-03-07 如何利用 Message Queue Break Message handling program 將訊息顯示於畫面第 24 行？
如何利用 Message Queue Break Message handling program 將訊息顯示於畫面第 24 行？
系統常會送出某些訊息，會中斷使用者的訊息，可以利用Message Queue Break Message handling program 將訊息顯示於畫面第 24 行
File : QCLSRC
Member: MSGH
Type : CLP
Usage : CRTCLPGM MSGH
/* PROGRAM TO HANDLE BREAK MESSAGES */
PGM PARM(&MSGQ &MSGQLIB &MSGK)
DCL VAR(&MSGQ) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGQLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGK) TYPE(*CHAR) LEN(4)
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(200)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(7)
DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGFLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGTXT) TYPE(*CHAR) LEN(200)
DCL VAR(&BLANK) TYPE(*CHAR) LEN(75)
DCL VAR(&I) TYPE(*DEC) LEN(2 0) VALUE(75)
MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
/* RECEIVE THE BREAK MESSAGE */
RCVMSG MSGQ(&MSGQLIB/&MSGQ) MSGKEY(&MSGK) RMV(*NO) +
MSG(&MSGTXT) MSGDTA(&MSGDTA) +
MSGID(&MSGID) MSGF(&MSGF) +
SNDMSGFLIB(&MSGFLIB)
/* IF THERES NO MSGID, USE &MSGTXT AND CPF9897 */
/* TO SATISFY STATUS MESSAGE REQUIREMENTS */
IF COND(&MSGID = ' ') THEN(DO)
CHGVAR VAR(&MSGID) VALUE('CPF9897')
CHGVAR VAR(&MSGFLIB) VALUE('QSYS')
CHGVAR VAR(&MSGF) VALUE('QCPFMSG')
CHGVAR VAR(&MSGDTA) VALUE(&MSGTXT)
ENDDO
/* RESEND IT AS A STATUS MESSAGE */
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGTXT) TOPGMQ(*EXT) MSGTYPE(*STATUS)
MONMSG MSGID(CPF0000)
LOOP: SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA(%SST(&BLANK 1 &I) || &MSGTXT) +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
CHGVAR VAR(&I) VALUE(&I -5)
IF COND(&I *GT 1) THEN(DO)
/* DLYJOB DLY(1) */
GOTO CMDLBL(LOOP)
ENDDO
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA(&MSGTXT) +
TOPGMQ(*EXT) MSGTYPE(*STATUS)
RETURN
ERROR:
MSGD: RCVMSG MSGTYPE(*DIAG) MSG(&MSGTXT) MSGDTA(&MSGDTA) +
MSGID(&MSGID) MSGF(&MSGF) MSGFLIB(&MSGFLIB)
IF COND(&MSGID *NE ' ') THEN(DO)
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*DIAG)
GOTO CMDLBL(MSGD)
ENDDO
MSGE: RCVMSG MSGTYPE(*EXCP) MSG(&MSGTXT) MSGDTA(&MSGDTA) +
MSGID(&MSGID) MSGF(&MSGF) MSGFLIB(&MSGFLIB)
IF COND(&MSGID *NE ' ') THEN(SNDPGMMSG +
MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE))
ENDPGM
在每次 Sign On 進入系統後下命令
CHGMSGQ MSGQ(user or WRKSTN ID) DLVRY(*BREAK) PGM(library/MSGH)，
你可將此命令加入使用者的 Initial Program 中自動執行，
再開第二台工作站測試，
SNDMSG MSG(TEST-USER-QUEUE) TOUSR(user)
or
SNDMSG MSG(TEST-WRKSTN-QUEUE) TOMSGQ(workstation id)
你可從第一個工作站看到從第二個工作站發送的訊息，顯示於第一台工作站的24行。
2002-01-14 如何自動監控 QSYSOPR message queue 內的硬體重要 Attention 訊息？
如何自動監控 QSYSOPR message queue 內的硬體重要 Attention 訊息？
此範例自動監控含有 *Attention* 訊息的系統硬體相關錯誤訊息 Message ID，並將之傳送到所指定人員的 Message queue 及 e-mail 信箱。
File : QCLSRC
Member : MONSYSOPRC
Type : CLP
Usage : CRTCLPGM MONSYSOPRC
CALL MONSYSOPRC 將自動 SBMJOB CMD(MONSYSOPRC) JOB(MONSYSOPRC) JOBQ(QCTL)
若要將此 MONSYSOPRC Job 結束，在 WRKACTJOB 畫面，於 QCLT subsystem 中
MONSYSOPRC Job 前，選擇 option '4'，即可將之結束。
/*-----------------------------------------------------------------*/
/* MONSYSOPRC- BATCHING PROGRAM */
/*-----------------------------------------------------------------*/
PGM +
DCL &JOBTYPE *CHAR 1
DCL &ERRMSG *CHAR 512
DCL &MSG *CHAR 512
DCL &MSGID *CHAR 7
DCL &MSGKEY *CHAR 4
DCL &MSGQ *CHAR 10 'QSYSOPR '
DCL &MSGQLIB *CHAR 10 '*LIBL '
DCL &RCVMSGTYPE *CHAR 2
DCL &SENDER *CHAR 80
DCL &SNDJOB *CHAR 10
DCL &RQS *CHAR 2 '08'
DCL &RQS_PMPT *CHAR 2 '10'
MONMSG CPF0000 EXEC( GOTO ERROR )
RTVJOBA TYPE(&JOBTYPE)
IF (&JOBTYPE *EQ '1') DO
SBMJOB CMD(CALL PGM(MONSYSOPRC)) JOB(MONSYSOPRC) +
JOBQ(QCTL)
GOTO END
ENDDO
START:
RCVMSG MSGQ(QSYSOPR) WAIT(*MAX) RMV(*NO) MSG(&MSG) +
MSGID(&MSGID) SENDER(&SENDER) +
RTNTYPE(&RCVMSGTYPE)
IF ((&MSGID *EQ CPPEA01) *OR +
(&MSGID *EQ CPPEA02) *OR +
(&MSGID *EQ CPPEA03) *OR +
(&MSGID *EQ CPPEA04) *OR +
(&MSGID *EQ CPPEA05) *OR +
(&MSGID *EQ CPPEA06) *OR +
(&MSGID *EQ CPPEA10) *OR +
(&MSGID *EQ CPPEA11) *OR +
(&MSGID *EQ CPPEA12) *OR +
(&MSGID *EQ CPPEA13) *OR +
(&MSGID *EQ CPPEA14) *OR +
(&MSGID *EQ CPPEA26) *OR +
(&MSGID *EQ CPPEA28) *OR +
(&MSGID *EQ CPP1604) *OR +
(&MSGID *EQ CPP8982) *OR +
(&MSGID *EQ CPP8983) *OR +
(&MSGID *EQ CPP8984) *OR +
(&MSGID *EQ CPP8985) *OR +
(&MSGID *EQ CPP8986) *OR +
(&MSGID *EQ CPP8987) ) DO
SNDPGMMSG MSGID(&MSGID) MSGF(QCPFMSG) TOUSR(CHANCY)
SNDDST TYPE(*LMSG) TOINTNET((vengoal@ddsc.com.tw)) +
DSTD('Emergency Event') LONGMSG(&MSGID +
*BCAT &MSG)
ENDDO
GOTO START
END:
RETURN
ERROR:
RCVMSG MSGTYPE( *EXCP ) +
MSG( &ERRMSG )
CHGVAR &ERRMSG ( 'ERROR:' |> &ERRMSG )
SNDBRKMSG MSG( &ERRMSG ) +
TOMSGQ( &SNDJOB )
ENDPGM
在執行 CALL MONSYSOPRC 後 執行測試程式 TSTMONSYSC，
File : QCLSRC
Member : TSTMONSYSC
File : CLP
Usage : CRTCLPGM TSTMONSYSC
: CALL TSTMONSYSC
PGM
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('This is +
test message') TOUSR(*SYSOPR) MSGTYPE(*INFO)
SNDPGMMSG MSGID(CPPEA12) MSGF(QCPFMSG) TOUSR(*SYSOPR) +
MSGTYPE(*DIAG)
ENDPGM
2001-12-31 如何於 CL 中作日期運算？
2001-12-31 如何於 CL 中作日期運算？
CL 中並不提供日期運算函式，但可透過 CVTDAT 指令作日期格式轉換，
以下範例將 Job Date 轉換成 Julian number( 4 位年 + 3 位數字(1-366))，
加1，並將之轉換為日期，如果這是今年最後一天，日期無法轉換，請用次年的第一天。
File : QCLSRC
Member : CLDATEC
Type : CLP
PGM
DCL VAR(&TODAY) TYPE(*CHAR) LEN(6)
DCL VAR(&TOMORROW) TYPE(*CHAR) LEN(6)
DCL VAR(&WORKDATE) TYPE(*CHAR) LEN(7)
DCL VAR(&YEAR) TYPE(*DEC) LEN(4)
DCL VAR(&DAY) TYPE(*DEC) LEN(3)
RTVJOBA DATE(&TODAY)
CVTDAT DATE(&TODAY) TOVAR(&WORKDATE) FROMFMT(*JOB) +
TOFMT(*LONGJUL) TOSEP(*NONE)
/* Find tomorrow's date */
CHGVAR &DAY %SST(&WORKDATE 5 3)
CHGVAR &DAY (&DAY + 1)
CHGVAR %SST(&WORKDATE 5 3) &DAY
CVTDAT DATE(&WORKDATE) TOVAR(&TOMORROW) +
FROMFMT(*LONGJUL) TOFMT(*JOB) TOSEP(*NONE)
MONMSG CPF0555 EXEC(DO)
CHGVAR &YEAR %SST(&WORKDATE 1 4)
CHGVAR &YEAR (&YEAR + 1)
CHGVAR %SST(&WORKDATE 1 4) &YEAR
CHGVAR %SST(&WORKDATE 5 3) '001'
CVTDAT DATE(&WORKDATE) TOVAR(&TOMORROW) +
FROMFMT(*LONGJUL) TOFMT(*JOB) TOSEP(*NONE)
ENDDO
/* Tomorrow's date is now in &TOMORROW */
ENDPGM
2001-12-15 工具: CHGSCDTIM 更改工作排程時間
工具: CHGSCDTIM 更改工作排程時間
The following source code was provided by Randy Gish .
It is the reader's responsibility to ensure that procedures and techniques
used from this code are accurate and appropriate for the user's installation.
No warranty is implied or expressed. Please back up your files before you run
a new procedure or program or make significant changes to disk files, and be
sure to test all procedures and programs before putting them into production.
CHGSCDTIM Command Source:
CMD PROMPT('Change Job Schedule Time')
PARM KWD(JOBNAM) TYPE(*NAME) LEN(10) MIN(1) +
PROMPT('Scheduled Job Name')
PARM KWD(INCREMENT) TYPE(*CHAR) LEN(6) MIN(1) +
PROMPT('Increment Time (HHMMSS)')
PARM KWD(CUTOFF) TYPE(*CHAR) LEN(6) +
PROMPT('Cutoff Time (HHMMSS)')
PARM KWD(RESET) TYPE(*CHAR) LEN(6) +
PROMPT('Reset Time (HHMMSS)')
PARM KWD(TIMVAL) TYPE(*CHAR) LEN(4) RSTD(*YES) +
DFT(*SCD) VALUES(*SCD *SYS) PROMPT('Time +
Value to Increment')
CHGSCDTIM Command Processing Program Source:
/* This program increments the scheduled time for a Job Schedule Entry. The */
/* increment, cutoff, and reset times should be passed as 'HHMMSS'. */
PGM PARM(&JOBSCDNAM &INCREMENT &CUTOFF &RESET &TIMVAL)
DCL VAR(&JOBSCDNAM) TYPE(*CHAR) LEN(10)
DCL VAR(&INCREMENT) TYPE(*CHAR) LEN(6)
DCL VAR(&CUTOFF) TYPE(*CHAR) LEN(6)
DCL VAR(&RESET) TYPE(*CHAR) LEN(6)
DCL VAR(&TIMVAL) TYPE(*CHAR) LEN(4)
DCL VAR(&USRSPC) TYPE(*CHAR) LEN(20) +
VALUE('CHGSCDTIM QTEMP ') /* USER +
SPACE NAME FOR APIS */
DCL VAR(&CNTHDL) TYPE(*CHAR) LEN(16) +
VALUE(' ') /* CONTINUATION +
HANDLE */
DCL VAR(&NUMENTB) TYPE(*CHAR) LEN(4) /* NUMBER +
OF ENTRIES FROM LIST JOB SCHEDULE ENTRIES +
IN BINARY FORM */
DCL VAR(&NUMENT) TYPE(*DEC) LEN(8 0) /* NUMBER +
OF ENTRIES FROM LIST JOB SCHEDULE ENTRIES +
IN DECIMAL FORM */
DCL VAR(&GENHDR) TYPE(*CHAR) LEN(140) /* GENERIC +
HEADER INFORMATION FROM THE USER SPACE */
DCL VAR(&LSTSTS) TYPE(*CHAR) LEN(1) /* STATUS OF +
THE LIST IN THE USER SPACE */
DCL VAR(&OFFSETB) TYPE(*CHAR) LEN(4) /* OFFSET +
TO THE LIST PORTION OF THE USER SPACE IN +
BINARY FORM */
DCL VAR(&STRPOSB) TYPE(*CHAR) LEN(4) /* STARTING +
POSITION IN THE USER SPACE IN BINARY FORM */
DCL VAR(&ELENB) TYPE(*CHAR) LEN(4) /* LIST JOB +
ENTRY LENGTH IN BINARY 4 FORM */
DCL VAR(&LENTRY) TYPE(*CHAR) LEN(1156) /* +
RETRIEVE AREA FOR LIST JOB SCHEDULE ENTRY */
DCL VAR(&INCHH) TYPE(*CHAR) LEN(2)
DCL VAR(&INCMM) TYPE(*CHAR) LEN(2)
DCL VAR(&INCSS) TYPE(*CHAR) LEN(2)
DCL VAR(&INCHH#) TYPE(*DEC) LEN(2 0)
DCL VAR(&INCMM#) TYPE(*DEC) LEN(2 0)
DCL VAR(&INCSS#) TYPE(*DEC) LEN(2 0)
DCL VAR(&SCDHH) TYPE(*CHAR) LEN(2)
DCL VAR(&SCDMM) TYPE(*CHAR) LEN(2)
DCL VAR(&SCDSS) TYPE(*CHAR) LEN(2)
DCL VAR(&SCDHH#) TYPE(*DEC) LEN(2 0)
DCL VAR(&SCDMM#) TYPE(*DEC) LEN(2 0)
DCL VAR(&SCDSS#) TYPE(*DEC) LEN(2 0)
DCL VAR(&SCDTIME) TYPE(*CHAR) LEN(6)
DCL VAR(&NEWHH#) TYPE(*DEC) LEN(3 0)
DCL VAR(&NEWMM#) TYPE(*DEC) LEN(3 0)
DCL VAR(&NEWSS#) TYPE(*DEC) LEN(3 0)
DCL VAR(&NEWTIME) TYPE(*CHAR) LEN(6)
DCL VAR(&SYSTIME) TYPE(*CHAR) LEN(6)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(07)
DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGL) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(132)
MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(ERROR))
/* Delete the user space if it already exists. */
DLTUSRSPC USRSPC(QTEMP/CHGSCDTIM)
MONMSG MSGID(CPF0000)
/* Create the user space. The user space will be 256 bytes and */
/* will be initialized to blanks. */
CALL PGM(QUSCRTUS) PARM(&USRSPC 'CHGSCDTIM ' +
X'00000100' ' ' '*ALL ' 'TEMPORARY +
USER SPACE ')
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
/* List the job schedule entry of the name specified. */
CALL PGM(QWCLSCDE) PARM(&USRSPC 'SCDL0200' +
&JOBSCDNAM &CNTHDL 0)
/* Retrieve the generic header from the user space. */
CALL PGM(QUSRTVUS) PARM(&USRSPC X'00000001' +
X'0000008C' &GENHDR)
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
/* Get the information status for the list from the generic header. */
CHGVAR VAR(&LSTSTS) VALUE(%SST(&GENHDR 104 1))
IF COND(&LSTSTS = 'I') THEN(GOTO CMDLBL(ENDPGM))
/* Get the number of entries returned and convert to decimal. */
/* If zero, go to ENDPGM. */
CHGVAR VAR(&NUMENTB) VALUE(%SST(&GENHDR 133 4))
CHGVAR VAR(&NUMENT) VALUE(%BIN(&NUMENTB))
IF COND(&NUMENT = 0) THEN(GOTO CMDLBL(ENDPGM))
/* Get the list entry length and offset. These values are used to */
/* set up the starting position. */
CHGVAR VAR(&ELENB) VALUE(%SST(&GENHDR 137 4))
CHGVAR VAR(&OFFSETB) VALUE(%SST(&GENHDR 125 4))
CHGVAR VAR(%BIN(&STRPOSB)) VALUE(%BIN(&OFFSETB) + 1)
/* Retrieve the list entry. */
CALL PGM(QUSRTVUS) PARM(&USRSPC &STRPOSB &ELENB +
&LENTRY)
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
/* Retrieve the scheduled time if TIMVAL = *SCD */
IF COND(&TIMVAL = '*SCD') +
THEN(DO)
CHGVAR VAR(&SCDHH) VALUE(%SST(&LENTRY 102 2))
CHGVAR VAR(&SCDMM) VALUE(%SST(&LENTRY 104 2))
CHGVAR VAR(&SCDSS) VALUE(%SST(&LENTRY 106 2))
CHGVAR VAR(&SCDHH#) VALUE(&SCDHH)
CHGVAR VAR(&SCDMM#) VALUE(&SCDMM)
CHGVAR VAR(&SCDSS#) VALUE(&SCDSS)
CHGVAR VAR(&SCDTIME) VALUE(&SCDHH || &SCDMM || +
&SCDSS)
ENDDO
/* Parse current time if TIMVAL = *SYS */
IF COND(&TIMVAL = '*SYS') +
THEN(DO)
RTVSYSVAL SYSVAL(QTIME) RTNVAR(&SYSTIME)
CHGVAR VAR(&SCDHH) VALUE(%SST(&SYSTIME 1 2))
CHGVAR VAR(&SCDMM) VALUE(%SST(&SYSTIME 3 2))
CHGVAR VAR(&SCDSS) VALUE(%SST(&SYSTIME 5 2))
CHGVAR VAR(&SCDHH#) VALUE(&SCDHH)
CHGVAR VAR(&SCDMM#) VALUE(&SCDMM)
CHGVAR VAR(&SCDSS#) VALUE(&SCDSS)
CHGVAR VAR(&SCDTIME) VALUE(&SCDHH || &SCDMM || +
&SCDSS)
ENDDO
/* Parse increment time */
CHGVAR VAR(&INCHH) VALUE(%SST(&INCREMENT 1 2))
CHGVAR VAR(&INCMM) VALUE(%SST(&INCREMENT 3 2))
CHGVAR VAR(&INCSS) VALUE(%SST(&INCREMENT 5 2))
CHGVAR VAR(&INCHH#) VALUE(&INCHH)
CHGVAR VAR(&INCMM#) VALUE(&INCMM)
CHGVAR VAR(&INCSS#) VALUE(&INCSS)
/* Calculate new scheduled time */
CHGVAR VAR(&NEWHH#) VALUE(&SCDHH# + &INCHH#)
CHGVAR VAR(&NEWMM#) VALUE(&SCDMM# + &INCMM#)
CHGVAR VAR(&NEWSS#) VALUE(&SCDSS# + &INCSS#)
IF COND(&NEWSS# >= 60) +
THEN(DO)
CHGVAR VAR(&NEWSS#) VALUE(&NEWSS# - 60)
CHGVAR VAR(&NEWMM#) VALUE(&NEWMM# + 1)
ENDDO
IF COND(&NEWMM# >= 60) +
THEN(DO)
CHGVAR VAR(&NEWMM#) VALUE(&NEWMM# - 60)
CHGVAR VAR(&NEWHH#) VALUE(&NEWHH# + 1)
ENDDO
IF COND(&NEWHH# >= 24) +
THEN(DO)
CHGVAR VAR(&NEWHH#) VALUE(&NEWHH# - 24)
ENDDO
CHGVAR VAR(&SCDHH#) VALUE(&NEWHH#)
CHGVAR VAR(&SCDMM#) VALUE(&NEWMM#)
CHGVAR VAR(&SCDSS#) VALUE(&NEWSS#)
CHGVAR VAR(&SCDHH) VALUE(&SCDHH#)
CHGVAR VAR(&SCDMM) VALUE(&SCDMM#)
CHGVAR VAR(&SCDSS) VALUE(&SCDSS#)
CHGVAR VAR(&NEWTIME) VALUE(&SCDHH || &SCDMM || +
&SCDSS)
/* Check if new time exceeds cutoff time */
IF COND(&CUTOFF *NE ' ' *AND &RESET *NE ' ' +
*AND (&NEWTIME *LT &SCDTIME *OR &NEWTIME +
*GE &CUTOFF)) THEN(CHGVAR VAR(&NEWTIME) +
VALUE(&RESET))
/* Update job schedule entry */
CHGJOBSCDE JOB(&JOBSCDNAM) SCDTIME(&NEWTIME)
GOTO CMDLBL(ENDPGM)
ERROR: RCVMSG MSGDTA(&MSGDTA) MSGID(&MSGID) MSGF(&MSGF) +
MSGFLIB(&MSGL)
MONMSG MSGID(CPF0000)
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGL/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
MONMSG MSGID(CPF0000)
ENDPGM: DLTUSRSPC USRSPC(QTEMP/CHGSCDTIM)
MONMSG MSGID(CPF0000)
ENDPGM
CHGSCDTIM Command Validity Checker Source:
/* This program is the validity checker for the CHGSCDTIM (Change Schedule */
/* Time) command. It verifies that the job exists and that the increment, */
/* cutoff, and reset times are valid. */
PGM PARM(&JOBSCDNAM &INCREMENT &CUTOFF &RESET &TIMVAL)
DCL VAR(&JOBSCDNAM) TYPE(*CHAR) LEN(10)
DCL VAR(&INCREMENT) TYPE(*CHAR) LEN(6)
DCL VAR(&CUTOFF) TYPE(*CHAR) LEN(6)
DCL VAR(&RESET) TYPE(*CHAR) LEN(6)
DCL VAR(&TIMVAL) TYPE(*CHAR) LEN(4)
DCL VAR(&USRSPC) TYPE(*CHAR) LEN(20) +
VALUE('CHGSCDTIM QTEMP ') /* USER +
SPACE NAME FOR APIS */
DCL VAR(&CNTHDL) TYPE(*CHAR) LEN(16) +
VALUE(' ') /* CONTINUATION +
HANDLE */
DCL VAR(&NUMENTB) TYPE(*CHAR) LEN(4) /* NUMBER +
OF ENTRIES FROM LIST JOB SCHEDULE ENTRIES +
IN BINARY FORM */
DCL VAR(&NUMENT) TYPE(*DEC) LEN(8 0) /* NUMBER +
OF ENTRIES FROM LIST JOB SCHEDULE ENTRIES +
IN DECIMAL FORM */
DCL VAR(&GENHDR) TYPE(*CHAR) LEN(140) /* GENERIC +
HEADER INFORMATION FROM THE USER SPACE */
DCL VAR(&LSTSTS) TYPE(*CHAR) LEN(1) /* STATUS OF +
THE LIST IN THE USER SPACE */
DCL VAR(&OFFSETB) TYPE(*CHAR) LEN(4) /* OFFSET +
TO THE LIST PORTION OF THE USER SPACE IN +
BINARY FORM */
DCL VAR(&STRPOSB) TYPE(*CHAR) LEN(4) /* STARTING +
POSITION IN THE USER SPACE IN BINARY FORM */
DCL VAR(&ELENB) TYPE(*CHAR) LEN(4) /* LIST JOB +
ENTRY LENGTH IN BINARY 4 FORM */
DCL VAR(&LENTRY) TYPE(*CHAR) LEN(1156) /* +
RETRIEVE AREA FOR LIST JOB SCHEDULE ENTRY */
DCL VAR(&HH) TYPE(*CHAR) LEN(2)
DCL VAR(&MM) TYPE(*CHAR) LEN(2)
DCL VAR(&SS) TYPE(*CHAR) LEN(2)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(07)
DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGL) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(132)
MONMSG MSGID(CPF0000 MCH0000) EXEC(GOTO CMDLBL(ERROR))
/* Delete the user space if it already exists. */
DLTUSRSPC USRSPC(QTEMP/CHGSCDTIM)
MONMSG MSGID(CPF0000)
/* Create the user space. The user space will be 256 bytes and */
/* will be initialized to blanks. */
CALL PGM(QUSCRTUS) PARM(&USRSPC 'CHGSCDTIM ' +
X'00000100' ' ' '*ALL ' 'TEMPORARY +
USER SPACE ')
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
/* List the job schedule entry of the name specified. */
CALL PGM(QWCLSCDE) PARM(&USRSPC 'SCDL0200' +
&JOBSCDNAM &CNTHDL 0)
/* Retrieve the generic header from the user space. */
CALL PGM(QUSRTVUS) PARM(&USRSPC X'00000001' +
X'0000008C' &GENHDR)
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
/* Get the information status for the list from the generic header. */
CHGVAR VAR(&LSTSTS) VALUE(%SST(&GENHDR 104 1))
IF COND(&LSTSTS = 'I') THEN(GOTO CMDLBL(ENDPGM))
/* Get the number of entries returned and convert to decimal. */
/* If zero, send error message and exit. */
CHGVAR VAR(&NUMENTB) VALUE(%SST(&GENHDR 133 4))
CHGVAR VAR(&NUMENT) VALUE(%BIN(&NUMENTB))
IF COND(&NUMENT = 0) +
THEN(DO)
SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 +
Job name ' *CAT &JOBSCDNAM *TCAT ' not found +
on Job Schedule.') MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
GOTO CMDLBL(ENDPGM)
ENDDO
/* Get the list entry length and offset. These values are used to */
/* set up the starting position. */
CHGVAR VAR(&ELENB) VALUE(%SST(&GENHDR 137 4))
CHGVAR VAR(&OFFSETB) VALUE(%SST(&GENHDR 125 4))
CHGVAR VAR(%BIN(&STRPOSB)) VALUE(%BIN(&OFFSETB) + 1)
/* Retrieve the list entry. */
CALL PGM(QUSRTVUS) PARM(&USRSPC &STRPOSB &ELENB +
&LENTRY)
MONMSG MSGID(CPF3C00) EXEC(GOTO CMDLBL(ERROR))
IF COND(%SST(&LENTRY 2 10) *NE &JOBSCDNAM) +
THEN(DO)
SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 +
Job name ' *CAT &JOBSCDNAM *TCAT ' not found +
on Job Schedule.') MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
GOTO CMDLBL(ENDPGM)
ENDDO
/* Check increment time */
CHGVAR VAR(&HH) VALUE(%SST(&INCREMENT 1 2))
CHGVAR VAR(&MM) VALUE(%SST(&INCREMENT 3 2))
CHGVAR VAR(&SS) VALUE(%SST(&INCREMENT 5 2))
IF COND(&HH *LT '00' *OR &HH *GT '23' *OR +
&MM *LT '00' *OR &MM *GT '59' *OR +
&SS *LT '00' *OR &SS *GT '59') +
THEN(DO)
SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 +
Increment time is not valid.') MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
ENDDO
/* Check cutoff time */
IF COND(&CUTOFF *NE ' ') +
THEN(DO)
CHGVAR VAR(&HH) VALUE(%SST(&CUTOFF 1 2))
CHGVAR VAR(&MM) VALUE(%SST(&CUTOFF 3 2))
CHGVAR VAR(&SS) VALUE(%SST(&CUTOFF 5 2))
IF COND(&HH *LT '00' *OR &HH *GT '24' *OR +
&MM *LT '00' *OR &MM *GT '59' *OR +
&SS *LT '00' *OR &SS *GT '59') +
THEN(DO)
SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 +
Cutoff time is not valid.') MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
ENDDO
/* Check reset time */
CHGVAR VAR(&HH) VALUE(%SST(&RESET 1 2))
CHGVAR VAR(&MM) VALUE(%SST(&RESET 3 2))
CHGVAR VAR(&SS) VALUE(%SST(&RESET 5 2))
IF COND(&HH *LT '00' *OR &HH *GT '23' *OR +
&MM *LT '00' *OR &MM *GT '59' *OR +
&SS *LT '00' *OR &SS *GT '59') +
THEN(DO)
SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 +
Reset time is not valid.') MSGTYPE(*DIAG)
SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE)
ENDDO
ENDDO
GOTO CMDLBL(ENDPGM)
ERROR:
RCVMSG MSGDTA(&MSGDTA) MSGID(&MSGID) MSGF(&MSGF) +
MSGFLIB(&MSGL)
MONMSG MSGID(CPF0000)
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGL/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
MONMSG MSGID(CPF0000)
ENDPGM: DLTUSRSPC USRSPC(QTEMP/CHGSCDTIM)
MONMSG MSGID(CPF0000)
ENDPGM
CHGSCDTIM Help Panel Group Source:
:PNLGRP.
:HELP name=CHGSCDTIMP.
:P.
The "Change Job Schedule Time" (CHGSCDTIM) command increments the
schedule time for a job on the AS/400 job scheduler. This enables
you to submit a job from the scheduler on a periodic basis of less
than a day (e.g., every hour or every 15 minutes). Simply run the
CHGSCDTIM command from your program that is called by the scheduler
and specify the job name and the increment time in HHMMSS format.
The schedule time for the job will be incremented by the amount of
time you specified. You can increment the currently scheduled time
or the current system time. You can also optionally specify a cutoff
and reset time. This would enable you to run a job periodically
within certain times each day (e.g., every hour from 8:00 a.m. to
8:00 p.m.).
:EHELP.
:HELP name='CHGSCDTIMP/JOBNAM'.
:P.
Scheduled Job Name:
:LINES.
This is the name of the job as you defined it on
the job scheduler.
:ELINES.
:EHELP.
:HELP name='CHGSCDTIMP/INCREMENT'.
:P.
Increment time:
:LINES.
This is the amount of time you would like to increment
the scheduled job. The format is HHMMSS.
:ELINES.
:EHELP.
:HELP name='CHGSCDTIMP/CUTOFF'.
:P.
Cutoff time:
:LINES.
This is the time of day you would like to stop
incrementing the job. The format is HHMMSS. If a
cutoff time is specified, a reset time is required.
:ELINES.
:EHELP.
:HELP name='CHGSCDTIMP/RESET'.
:P.
Reset time:
:LINES.
This is the time of day you would like to restart the
job. The format is HHMMSS. A reset time is required
if a cutoff time is specified.
:ELINES.
:EHELP.
:HELP name='CHGSCDTIMP/TIMVAL'.
:P.
Time value:
:LINES.
This is the time value that you would like to
increment. *SCD will increment the time on the
scheduler. *SYS will set the schedule time to
the current time plus the increment.
:ELINES.
:EHELP.
:EPNLGRP.
The following CL program can be used to create the CHGSCDTIM command.
The program assumes that the source is in QGPL/CSTCMDSRC:
PGM
DCL VAR(&LIBRARY) TYPE(*CHAR) LEN(10) VALUE('QGPL')
DCL VAR(&SRCFILE) TYPE(*CHAR) LEN(10) VALUE('CSTCMDSRC')
/* Create Command Processing Program */
CRTCLPGM PGM(&LIBRARY/CHGSCDTIMC) SRCFILE(&LIBRARY/&SRCFILE)
/* Create Validity Checker Program */
CRTCLPGM PGM(&LIBRARY/CHGSCDTIMV) SRCFILE(&LIBRARY/&SRCFILE)
/* Create Help Panel Group */
CRTPNLGRP PNLGRP(&LIBRARY/CHGSCDTIMP) +
SRCFILE(&LIBRARY/&SRCFILE)
/* Create Change Job Schedule Time Command */
CRTCMD CMD(&LIBRARY/CHGSCDTIM) PGM(&LIBRARY/CHGSCDTIMC) +
SRCFILE(&LIBRARY/&SRCFILE) +
VLDCKR(&LIBRARY/CHGSCDTIMV) +
HLPPNLGRP(&LIBRARY/CHGSCDTIMP) HLPID(CHGSCDTIMP)
ENDPGM
訂閱：
文章 (Atom)