擷取系統時間至微秒單位(Get system timesatmp with a precision in microseconds by API QWCCVTDT)
範例含 CLP, RPGLE, COBOL。
File : QCLSRC
Member: GETSYSTIMC
Type : CLP
Usage : CRTCLPGM PGM(GETSYSTIMC)
PGM
/* For Convert Date & Time... */
dcl &CDT_I_FORM *char 10 value( '*CURRENT' )
dcl &CDT_I_VAR *char 8
dcl &CDT_O_FORM *char 10 value( '*YYMD' )
dcl &CDT_O_VAR *char 20
dcl &CDT_I_TZ *char 10 value( '*SYS' )
dcl &CDT_O_TZ *char 10 value( '*SYS' )
dcl &CDT_O_TZi *char 111 value( ' ' )
dcl &CDT_O_TZl *int value( 0 )
dcl &CDT_O_Pi *char 1 value( '1' )
/* And we'll need to specify an errcode receiver at one point... */
dcl &ERRCODE *char 116 value( x'00000074' )
dcl &ERRLEN *int value( 0 )
call QWCCVTDT ( +
&CDT_I_FORM +
&CDT_I_VAR +
&CDT_O_FORM +
&CDT_O_VAR +
&ERRCODE +
&CDT_I_TZ +
&CDT_O_TZ +
&CDT_O_TZi +
&CDT_O_TZl +
&CDT_O_Pi +
)
SndPgmMsg MsgId(CPF9898) MsgF(*LIBL/QCPFMSG) +
MsgDta(&CDT_O_VAR)
Return
ENDPGM
File : QRPGLESRC
Member: GETSYSTIMR
Type : RPGLE
Usage : CRTBNDRPG PGM(GETSYSTIMR)
**-- API error data structure:
D ERRC0100 Ds Qualified
D BytPrv 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0
D MsgId 7a
D 1a
D MsgDta 128a
DOutputVar DS
D CurCentury 2
D CurYear 2
D CurMonth 2
D CurDay 2
D CurHour 2
D CurMinute 2
D CurSecond 2
D CurMicroSec 6
D TimeZoneInfL 10i 0
C Move *On *InLr
C Call 'QWCCVTDT'
C Parm '*CURRENT' InputFmt 10
C Parm InputVar 1
C Parm '*YYMD' OutputFmt 10
C Parm OutputVar
C Parm ERRC0100
C Parm InpTimeZone 10
C Parm '*SYS' OutTimeZone 10
C Parm TimeZineInf 1
C Parm 0 TimeZoneInfL
C Parm '1' PrcInd 1
C OutputVar dsply
File : QCBLLESRC
Member: GETSYSTIME
Type : COBOL
Usage : CRTCBLPGM PGM(GETSYSTIME)
IDENTIFICATION DIVISION.
PROGRAM-ID. SAMPLE07.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 DATES.
05 INPUT-DATE PIC X(10).
05 OUTPUT-DATE17 PIC X(17).
05 OUTPUT-DATE20 PIC X(20).
05 INPUT-DATE-FORMAT PIC X(10).
05 OUTPUT-DATE-FORMAT PIC X(10).
05 INPUT-TIME-ZONE PIC X(10) VALUE '*SYS'.
05 OUTPUT-TIME-ZONE PIC X(10) VALUE '*SYS'.
05 TIME-ZONE-INFO PIC X(10).
05 TIME-ZONE-INFO-LEN PIC S9(9) BINARY VALUE ZERO.
05 PRECISION-INDICATOR PIC X(01) VALUE '1'.
01 CURRENTTIME.
05 CUR-YEAR PIC X(04).
05 CUR-MONTH PIC X(02).
05 CUR-DAY PIC X(02).
05 CUR-HH PIC X(02).
05 CUR-MM PIC X(02).
05 CUR-SS PIC X(02).
05 CUR-MICROSECOND PIC X(06).
01 ERRPARM.
05 INPUT-L PIC S9(9) BINARY VALUE 116.
05 OUTPUT-L PIC S9(9) BINARY VALUE ZERO.
05 EXCEPTION-ID PIC X(7).
05 RESERVED PIC X(1).
05 EXCEPTION-DATA PIC X(100).
PROCEDURE DIVISION.
MAINLINE.
PERFORM GET-DATE-08
GOBACK.
GET-DATE-08.
MOVE SPACES TO EXCEPTION-ID.
MOVE "*CURRENT" TO INPUT-DATE-FORMAT.
MOVE "*YYMD " TO OUTPUT-DATE-FORMAT.
CALL "QWCCVTDT" USING INPUT-DATE-FORMAT ,
INPUT-DATE ,
OUTPUT-DATE-FORMAT,
CURRENTTIME ,
ERRPARM ,
INPUT-TIME-ZONE ,
OUTPUT-TIME-ZONE ,
TIME-ZONE-INFO ,
TIME-ZONE-INFO-LEN,
PRECISION-INDICATOR.
DISPLAY 'TIMESTAMP FROM COBOL: ' CURRENTTIME.
參照: Convert Date and Time Format (QWCCVTDT) API
星期四, 11月 09, 2023
2016-04-06 擷取系統時間至微秒單位(Get system timesatmp with a precision in microseconds by API QWCCVTDT)
2012-12-27 如何於 AS400 系統中建立一個文字型態的序號產生器？(NumericToAlpha sequence generator)
如何於 AS400 系統中建立一個文字型態的序號產生器？(NumericToAlpha sequence generator)
下列範例為二位文字型態的序號產生器，其產生順序為
00,01,...,09,0A,...0Z,10,11...,A0,A1,...,ZZ
二位文字型態的序號可以產生 1296 個序號。
File : QRPGLESRC
Member: SEQGENRT
Type : RPGLE
Usage : CRTBNDRPG SEQGENRT
CALL SEQGENRT
會產生一份報表，前段為 1296 個序號列，後段為取下依序號測試。
**
** Program . . : SEQGENRT
** Description : 2 byte NumericToAlpha sequence generator demo
**
** Author . . : Vengoal Chang
**
** Date . . : 2012/12/27
**
** Modified . :
**
** Compile and setup instructions:
** CrtBndRpg Pgm( SEQGENRT )
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt: *NoDebugIo ) DftActGrp(*NO) Debug
FQSYSPRT O F 132 printer
*00,01,...,09,0A,...0Z,10,11...,A0,A1,...,ZZ
D NumericToAlpha C '1'
D keyCode S 2
D currCode S 2
D nextCode S 2
D code S 2
D CodeLen S 2 0 Inz(2)
D currNbr S 20U 0
D codeNbr S 20U 0
D nextNbr S 20U 0
D nextNbrC S 20
D Mul S 20U 0
D divBase S 20U 0
D divNbr S 20U 0
D remNbr S 2 0
D i S 2 0
D pos S 2 0
D count S 2 0
D oneChar S 1
D idx S 5U 0
D SequenceType S 1
D TABCHA1 S 1 DIM(36) CTDATA PERRCD(1) Hex Cnv Tbl
D TABDEC1 S 2 0 DIM(36) ALT(TABCHA1)
D TABDEC2 S 2 0 DIM(36) CTDATA PERRCD(1) ASCEND Hex Cnv Tbl
D TABCHA2 S 1 DIM(36) ALT(TABDEC2)
D tmpStr S 52
C eval *InLr = *On
C eval currCode = 'ZZ'
C eval code = currCode
C exSr GetCodeNbr
C codeNbr dsply
* code list
C For idx = 0 to 1295
C eval currNbr = idx
C eval tmpStr = %Char(currNbr)
C exSr GetCode
C eval tmpStr = %trim(tmpStr) + ' ' +
C Code
C eval currCode = Code
C exSr GetCodeNbr
C eval tmpStr = %trim(tmpStr) + ' ' +
C %Char(codeNbr)
C except output1
C EndFor
* next code list
C eval keyCode = '00'
C For idx = 0 to 1295
C exSr GetNextCode
C eval tmpStr = %char(idx) +' '+currCode + ' ' +
C nextCode
C except output1
C eval keyCode = nextCode
C EndFor
C return
C*=====================================================================
C GetNextCode BegSr
C eval currCode = keyCode
C exSr GetCodeNbr
C eval codeNbr = codeNbr + 1
C eval currNbr = codeNbr
C exSr GetCode
C eval nextCode = code
C EndSr
C*=====================================================================
C GetCodeNbr BegSr
C eval code = currCode
* convert to number base 36
C eval mul = 0
C For pos = CodeLen downto 1
C eval oneChar = %SubSt(code:pos:1)
C oneChar lookup TabCha1 TabDec1 50
C 50 z-Add TabDec1 tempNbr 2 0
C If pos <> CodeLen
C If pos = (CodeLen - 1)
C eval mul = 36
C Else
C eval mul = mul * 36
C EndIf
C Else
C eval codeNbr = tempNbr
C iter
C EndIf
C eval codeNbr = codeNbr + mul * tempNbr
C EndFor
C EndSr
C*=====================================================================
C GetCode BegSr
C eval codeNbr = currNbr
C eval divBase = 36
C For pos = CodeLen downto 1
C eval divNbr = %DIV(codeNbr: divBase)
C eval remNbr = %REM(codeNbr: divBase)
C remNbr lookup TABDEC2 TABCHA2 50
C move TabCha2 oneChar
C eval %SubSt(Code :pos:1) = oneChar
C eval codeNbr = divNbr
C EndFor
C EndSr
*
O
OQSYSPRT E OUTPUT1 1
O TmpStr
*
**
000
101
202
303
404
505
606
707
808
909
A10
B11
C12
D13
E14
F15
G16
H17
I18
J19
K20
L21
M22
N23
O24
P25
Q26
R27
S28
T29
U30
V31
W32
X33
Y34
Z35
**
000
011
022
033
044
055
066
077
088
099
10A
11B
12C
13D
14E
15F
16G
17H
18I
19J
20K
21L
22M
23N
24O
25P
26Q
27R
28S
29T
30U
31V
32W
33X
34Y
35Z
範例執行結果:
前段為編碼列表如下:
第一欄為數字序號，第二欄為數字序號編碼結果，第三欄為第二欄編碼解回為數字與第一欄檢核一致。
0 00 0
1 01 1
2 02 2
3 03 3
4 04 4
5 05 5
6 06 6
7 07 7
8 08 8
9 09 9
10 0A 10
11 0B 11
12 0C 12
13 0D 13
14 0E 14
15 0F 15
16 0G 16
17 0H 17
18 0I 18
19 0J 19
20 0K 20
21 0L 21
22 0M 22
23 0N 23
24 0O 24
25 0P 25
26 0Q 26
27 0R 27
28 0S 28
29 0T 29
30 0U 30
31 0V 31
32 0W 32
33 0X 33
34 0Y 34
35 0Z 35
36 10 36
37 11 37
38 12 38
39 13 39
40 14 40
41 15 41
42 16 42
43 17 43
44 18 44
45 19 45
46 1A 46
47 1B 47
....
1287 ZR 1287
1288 ZS 1288
1289 ZT 1289
1290 ZU 1290
1291 ZV 1291
1292 ZW 1292
1293 ZX 1293
1294 ZY 1294
1295 ZZ 1295
後段為使用初始編號去取下一位編號，
第一欄為序號，第二欄為初始編號，第三欄為下一位編號。
0 00 01
1 01 02
2 02 03
3 03 04
4 04 05
5 05 06
6 06 07
7 07 08
8 08 09
9 09 0A
10 0A 0B
11 0B 0C
12 0C 0D
13 0D 0E
14 0E 0F
15 0F 0G
16 0G 0H
17 0H 0I
18 0I 0J
19 0J 0K
20 0K 0L
21 0L 0M
22 0M 0N
23 0N 0O
24 0O 0P
25 0P 0Q
26 0Q 0R
27 0R 0S
28 0S 0T
29 0T 0U
30 0U 0V
31 0V 0W
32 0W 0X
33 0X 0Y
34 0Y 0Z
35 0Z 10
36 10 11
37 11 12
38 12 13
39 13 14
40 14 15
........
1280 ZK ZL
1281 ZL ZM
1282 ZM ZN
1283 ZN ZO
1284 ZO ZP
1285 ZP ZQ
1286 ZQ ZR
1287 ZR ZS
1288 ZS ZT
1289 ZT ZU
1290 ZU ZV
1291 ZV ZW
1292 ZW ZX
1293 ZX ZY
1294 ZY ZZ
1295 ZZ 00
星期三, 11月 08, 2023
2012-06-06 如何於 AS400 系統中因應個資法，紀錄使用者何時取得機密敏感的資訊？
如何於 AS400 系統中因應個資法，紀錄使用者何時取得機密敏感的資訊？
於 OS400 V6R1 以前，要利用系統所提供的 Trigger read 事件功能來達成。
詳細資訊請參照：Creating trigger programs
從 OS400 V7R1 以後，還可以使用 V7R1 新增加的 Field Procedure 功能來完成，可以透過程式運作來達到指定欄位的加解密或遮罩。
詳細資訊請參照：Defining field procedures
此次範例使用系統所提供的 Trigger read 事件功能來達成。並將讀取的資訊紀錄於日誌中。
File : QRPGLESRC
Member: TRGREADJRN
Type : RPGLE
Usage : CRTBNDRPG QGPL/TRGREADJRN
於使用前須建立所要使用的日誌 DVMJRN 設定如下:
1. CRTJRNRCV JRNRCV(QGPL/DVMJRNRCV)
2. CRTJRN JRN(QGPL/DVMJRN) JRNRCV(QGPL/DVMJRNRCV)
3. 將 Trigger 程式連結至檔案
ADDPFTRG FILE(lib/file) TRGTIME(*AFTER) TRGEVENT(*READ) PGM(QGPL/TRGREADJRN) TRG(TRGREADJRN)
DSPFD lib/file 檢視所加入的 Trigger Description。
若要移除 Trigger 程式連結
RMVPFTRG FILE(LIB/FILE) TRGTIME(*AFTER) TRGEVENT(*READ)
5. 使用 STRDFU 或其他程式讀取 lib/file
6. DSPJRN JRN(QGPL/DVMJRN) 會得到類似如下的畫面:
===============================================================================
Display Journal Entries
Journal . . . . . . : DVMJRN Library . . . . . . : QGPL
Largest sequence number on this screen . . . . . . : 00000000000000000012
Type options, press Enter.
5=Display entire entry
Opt Sequence Code Type Object Library Job Time
1 J PR QPADEV000F 11:40:08
2 U DV QPADEV000F 11:41:08
3 U DV QPADEV000F 11:41:08
4 U DV QPADEV000F 11:41:09
5 5 U DV QPADEV000F 11:41:09
6 U DV QPADEV000F 11:41:09
7 U DV QPADEV000F 13:41:46
8 U DV QPADEV000F 13:41:47
9 U DV QPADEV000F 13:41:47
10 U DV QPADEV000F 13:41:48
11 U DV QPADEV000F 13:41:50
12 U DV QPADEV000F 13:41:50
==============================================================================
Display Journal Entry
Object . . . . . . . : Library . . . . . . :
Member . . . . . . . :
Incomplete data . . : No Minimized entry data : *NONE
Sequence . . . . . . : 50
Code . . . . . . . . : U - User generated entry
Type . . . . . . . . : DV
Entry specific data
Column *...+....1....+....2....+....3....+....4....+....5
00001 'QPADEV000FVENGOAL 941887VENGOAL QCUSTCDTC VENG'
00051 'OAL QCUSTCDTC 000000000520120604161956QDZTD00001'
00101 'QTEMP 397267Tyron W E13 Myrtle Dr HectorNY14'
00151 '84110001000000000000 < < '
Bottom
===============================================================================
所記錄的資訊目前是定義如下:
D JrnEntDtaDs Ds 32767
D jjob 10
D juser 10
D jjobnbr 6
D jcurusr 10
D jfile 10
D jfilelib 10
D jfileMbr 10
D jrrn 10S 0
D jdate 8
D jtime 6
D jpgm 10
D jpgmlib 10
D* filedata
前 110 位資訊如上，111位以後目前為所讀取的檔案資訊，可以依照需求修改紀錄檔案中那些資訊。
**
** Program . . : TRGREADJRN
** Description : Trigger read event to jiurnal
** Author . . : Vengoal Chang
** Published . : AS400 ePaper
** Date . . . : June 4, 2012
**
**
** Program summary
** ---------------
**
** Journal & commit API:
** QJOSJRNE Send journal entry Writes a single journal entry to a
** specific journal. The entry can
** contain any information. You can
** assign an entry type to the
** journal entry.
**
**
** Compile and setup instructions:
** CrtBndRpg Pgm( TRGREADJRN )
**
**
**-- Control specifications: -------------------------------------------**
H Debug Option(*SrcStmt:*NoDebugIo) DftActGrp(*NO)
**-- API error information:
D ERRC0100 Ds Qualified
D BytPro 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0
D MsgId 7a
D 1a
D MsgDta 256a
**-- System information:
D PgmSts SDs Qualified
D PgmNam *Proc
D MsgId 7a Overlay( PgmSts: 40 )
D Msg 80a Overlay( PgmSts: 91 )
D CurJob 10a Overlay( PgmSts: 244 )
D UsrPrf 10a Overlay( PgmSts: 254 )
D JobNbr 6a Overlay( PgmSts: 264 )
D CurUsr 10a Overlay( PgmSts: 358 )
**-- 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 )
**-- Send journal entry:
D SndJrnE Pr ExtPgm( 'QJOSJRNE' )
D SjJrnNamQ 20a Const
D SjJrnEntInf 4096a Const Options( *VarSize )
D SjEntDta 32766a Const Options( *VarSize )
D SjEntDtaLen 10i 0 Const
D SjError 32767a Options( *VarSize )
**
D JrnEntInf Ds Qualified
D InfEntRcds 10i 0 Inz( 1 )
D InfKey1 10i 0 Inz( 1 )
D InfLen1 10i 0 Inz( %Size( JrnEntInf.InfDta1))
D InfDta1 2a
D* InfKey2 10i 0 Inz( 2 )
D* InfLen2 10i 0 Inz( %Size( JrnEntInf.InfDta2))
D* InfDta2 20a
D* InfKey3 10i 0 Inz( 3 )
D* InfLen3 10i 0 Inz( %Size( JrnEntInf.InfDta3))
D* InfDta3 10a
**
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Trigger buffer:
D trgBuffer DS 32767
D tbFile 10
D tbLib 10
D tbMbr 10
D tbEvnt 1
D tbTime 1
D tbComt 1
D tbFill01 3
D tbCCSID 10I 0
D tbRRN 10I 0
D tbFill02 4
D tbOldOffset 10I 0
D tbOldLength 10I 0
D tbOldNullOff 10I 0
D tbOldNullLen 10I 0
D tbNewOffset 10I 0
D tbNewLength 10I 0
D tbNewNullOff 10I 0
D tbNewNullLen 10I 0
**
D JrnEntDtaDs Ds 32767
D jjob 10
D juser 10
D jjobnbr 6
D jcurusr 10
D jfile 10
D jfilelib 10
D jfileMbr 10
D jrrn 10S 0
D jdate 8
D jtime 6
D jpgm 10
D jpgmlib 10
**
** Trigger Buffer Length Field
D trgBufferLen S 10I 0
** Constants
** Possible values for Event
D DbActIns C '1'
D DbActDlt C '2'
D DbActUpd C '3'
D DbActRead C '4'
** Possible values for Time
D DbTimBfr C '1'
D DbTimAft C '2'
** Possible values for Commitlocklev
D Cmtnone C '0'
D Cmtchange C '1'
D Cmtcs C '2'
D Cmtall C '3'
**
D GetCaller PR Extpgm('QWVRCSTK')
D Var 2000
D VarLen 10I 0
D CStkFmt 8 CONST
D JobIdInfo 56
D JobIdFmt 8 CONST
D ApiErr 15
**
D Var DS 2000
D BytAvl 10I 0
D BytRtn 10I 0
D Entries 10I 0
D Offset 10I 0
** Stand Alone variables
D VarLen S 10I 0 Inz(%size(Var))
D ApiErr S 15
D Doffset S 10I 0
**
D JobIdInf DS
D JIDQName 26 Inz('*')
D JIDIntID 16
D JIDRes3 2 Inz(*loval)
D JIDThreadInd 10I 0 Inz(1)
D JIDThread 8 Inz(*loval)
**
D Entry DS 256
D EntryLen 10I 0
D PgmNam 10 Overlay(Entry:25)
D PgmLib 10 Overlay(Entry:35)
**
D i S 5 0
D JIDUser S 10 inz(*user)
D JIDDate S D Inz(*sys)
D JIDTime S t inz(*sys)
D MsgKey s 4a
**********************************************************************
*
* PLISTS
*
**********************************************************************
C *Entry plist
C parm trgBuffer
C parm trgBufferLen
**********************************************************************
*
* Main lines
*
**********************************************************************
/free
ExSr GetCallerID;
if tbEvnt = DbActRead;
jjob = PgmSts.CurJob;
jUser = PgmSts.UsrPrf;
jJobNbr = PgmSts.JobNbr;
jCurUsr = PgmSts.CurUsr;
jfile = tbFile;
jfilelib = tbLib;
jfileMbr = tbMbr;
jrrn = tbRRN;
jdate = %char(JIDDate:*iso0) ;
jtime = %char(JIDTime:*hms0) ;
jpgm = PgmNam ;
jpgmlib = PgmLib ;
JrnEntInf.InfDta1 = 'DV';
// JrnEntInf.InfDta2 = tbFile + tbLib;
// JrnEntInf.InfDta3 = tbMbr;
%SubSt(JrnEntDtaDS : 111) =
%SubSt(trgBuffer : tbOldOffset + 1 : tbOldLength);
SndJrnE( 'DVMJRN *LIBL '
: JrnEntInf
: JrnEntDtaDs
: tbOldLength + 110
: ERRC0100
);
if (ERRC0100.BytAvl > 0);
SndEscMsg( ERRC0100.MsgID + ERRC0100.MsgDta );
endIf;
endif;
return;
/end-free
*=====================================================================
*
* Get Caller ID
*
*=====================================================================
C GetCallerID begsr
C callp GetCaller(Var:VarLen:'CSTK0100':JobIdInf
C :'JIDF0100':ApiErr)
C FOR i = 1 TO Entries
C eval Entry = %subst(Var:Offset + 1)
C if pgmnam <> PgmSts.PgmNam and
C pgmlib <> 'QSYS'
C leave
C endif
C eval Offset = Offset + EntryLen
C Endfor
C* pgmnam dsply
C* pgmlib dsply
C endsr
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
/Free
SndPgmMsg( 'CPF9898'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*ESCAPE'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndEscMsg E
2011-08-12 如何將 DTS 格式的時間 與 格式為 YYYYMMDD HHMISS sss 時間互為轉換？(MI MATTOD and Convert Date and Time Format QWCCVTDT API )
如何將 DTS 格式的時間 與 格式為 YYYYMMDD HHMISS sss 時間互為轉換？(MI MATTOD and Convert Date and Time Format QWCCVTDT API )
系統時間 DTS 格式常出現在 Journal 或 系統函數中，有時就有需要將 DTS 格式轉換為可讀取格式，
指令 CVSDTS(Convert DTS to Date/Time)，CVTTODTS((Convert Date/Time DTS) 如下：
File : QCLSRC
Member: CVTDTS
Type : CLP
Usage : CRTCLPGM CVTDTS
/* =============================================================== */
/* = Command CVTDTS CPP = */
/* = Program....... CvtDts = */
/* = Description... Convert DTS to Date/Time = */
/* =============================================================== */
/* = Date : 2011/07/28 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
Pgm ( &Dts +
&RtnDate +
&RtnTime +
&RtnMillsec +
)
/*-- Parameters: ---------------------------------------------------*/
Dcl &Dts *Char 8
Dcl &RtnDate *Char 8
Dcl &RtnTime *Char 6
Dcl &RtnMillSec *Char 3
Dcl &OutDatTim *Char 20
/*-- Global error monitoring: --------------------------------------*/
MonMsg MCH3601
MonMsg CPF0000 *N GoTo Error
Call QWCCVTDT ( '*DTS' +
&Dts +
'*YYMD' +
&OutDatTim +
x'00000000' +
)
ChgVar &RtnDate %SST(&OutDatTim 1 8)
ChgVar &RtnTime %SST(&OutDatTim 9 6)
ChgVar &RtnMillSec %SST(&OutDatTim 15 3)
Return:
Return
/*-- Error processor ------------------------------------------------*/
Error:
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY ' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
EndPgm:
EndPgm
File : QCLSRC
Member: CVTTODTS
Type : CLP
Usage : CRTCLPGM CVTTODTS
/* =============================================================== */
/* = Command CVTTODTS CPP = */
/* = Program....... CvtToDts = */
/* = Description... Convert Date/Time to DTS = */
/* =============================================================== */
/* = Date : 2011/07/28 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
Pgm ( &Date +
&Time +
&Millsec +
&RtnDts +
)
/*-- Parameters: ---------------------------------------------------*/
Dcl &Date *Char 8
Dcl &Time *Char 6
Dcl &MillSec *Char 3
Dcl &RtnDts *Char 8
Dcl &InpDatTim *Char 20
/*-- Global error monitoring: --------------------------------------*/
MonMsg CPF0000 *N GoTo Error
ChgVar %SST(&InpDatTim 1 8) &Date
ChgVar %SST(&InpDatTim 9 6) &Time
ChgVar %SST(&InpDatTim 15 3) &MillSec
ChgVar %SST(&InpDatTim 18 3) '000'
Call QWCCVTDT ( '*YYMD' +
&InpDatTim +
'*DTS' +
&RtnDts +
x'00000000' +
)
Return:
Return
/*-- Error processor ------------------------------------------------*/
Error:
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY ' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
EndPgm:
EndPgm
File : QCMDSRC
Member: CVTDTS
Type : CMD
Usage : CRTCMD CMD(CVTDTS) PGM(CVTDTS) ALLOW(*IPGM *BPGM)
/* =============================================================== */
/* = Command....... CVTDTS = */
/* = CPP........... CVTDTS CLP = */
/* = Description... Convert DTS to date/time = */
/* = = */
/* = Compile options: = */
/* = = */
/* = CrtCmd Cmd( CVTDTS ) = */
/* = Pgm( CVTDTS ) = */
/* = SrcMbr( CVTDTS ) = */
/* = Allow( = */
/* = *IREXX = */
/* = *BREXX = */
/* = *BPGM = */
/* = *IPGM = */
/* = ) = */
/* =============================================================== */
/* = Date : 2011/07/14 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
Cmd Prompt( 'Convert DTS to Date/Time' )
Parm DTS *Char 8 +
Min( 1 ) +
Expr( *YES ) +
Prompt( 'DTS' )
Parm RTNDATE *Char 8 +
RTNVAL(*YES) +
Prompt( 'Return date format YYYYMMDD(8)')
Parm RTNTIME *Char 6 +
RTNVAL(*YES) +
Prompt( 'Return time format HHMMSS (6)')
Parm RTNMILLSEC *Char 3 +
RTNVAL(*YES) +
Prompt( 'Return millsec format sss (3)')
File : QCMDSRC
Member: CVTTODTS
Type : CMD
Usage : CRTCMD CMD(CVTTODTS) PGM(CVTTODTS) ALLOW(*IPGM *BPGM)
/* =============================================================== */
/* = Command....... CVTTODTS = */
/* = CPP........... CVTTODTS CLP = */
/* = Description... Convert date/time to DTS = */
/* = = */
/* = Compile options: = */
/* = = */
/* = CrtCmd Cmd( CVTTODTS ) = */
/* = Pgm( CVTTODTS ) = */
/* = SrcMbr( CVTTODTS ) = */
/* = Allow( = */
/* = *IREXX = */
/* = *BREXX = */
/* = *BPGM = */
/* = *IPGM = */
/* = ) = */
/* =============================================================== */
/* = Date : 2011/07/14 = */
/* = Author: Vengoal Chang = */
/* =============================================================== */
Cmd Prompt( 'Convert Date/time to DTS' )
Parm DATE *Char 8 +
Min( 1 ) +
Expr( *YES ) +
Prompt( 'The date format YYYYMMDD')
Parm TIME *Char 6 +
Min( 1 ) +
Expr( *YES ) +
Prompt( 'The time format HHMMSS')
Parm MILLSEC *Char 3 +
Dft( 000 ) +
Range('000' '999') +
Expr( *YES ) +
Prompt( 'The millsec format sss')
Parm DTS *Char 8 +
RTNVAL(*YES) +
Prompt( 'CL var for DTS (8)')
File : QCLSRC
Member: CVTDTST
Type : CCL
Usage : CRTCLPGM CVTDTST
CALL CVTDTST
PGM
/*-- Parameters: ---------------------------------------------------*/
Dcl &Dts *Char 8
Dcl &Dts2 *Char 8
Dcl &RtnDate *Char 8
Dcl &RtnTime *Char 6
Dcl &RtnMillSec *Char 3
Dcl &RtnDate2 *Char 8
Dcl &RtnTime2 *Char 6
Dcl &RtnMillSe2 *Char 3
Dcl &RtnDts *Char 8
Dcl &RtnDts2 *Char 8
callprc 'mattod' parm(&DTS)
CVTDTS DTS(&DTS) RTNDATE(&RTNDATE) +
RTNTIME(&RTNTIME) RTNMILLSEC(&RTNMILLSEC)
CVTTODTS DATE(&RTNDATE) TIME(&RTNTIME) +
MILLSEC(&RTNMILLSEC) DTS(&RTNDTS)
CVTDTS DTS(&RTNDTS) RTNDATE(&RTNDATE2) +
RTNTIME(&RTNTIME2) RTNMILLSEC(&RTNMILLSE2)
CVTTODTS DATE(&RTNDATE2) TIME(&RTNTIME2) +
MILLSEC(&RTNMILLSE2) DTS(&RTNDTS2)
DMPCLPGM
DSPSPLF FILE(QPPGMDMP) SPLNBR(*LAST)
ENDPGM
Convert Date and Time Format (QWCCVTDT) API
2011-07-19 如何取得含有 micro second 的系統時間 ？(MI MATTOD, API QWCCVTDT and Qp0zCvtToTimeval to get timestamp)
如何取得含有 micro second 的系統時間 ？(MI MATTOD, API QWCCVTDT and Qp0zCvtToTimeval to get timestamp)
File : QRPGLESRC
Member: MATTODR2
Type : RPGLE
Usage : CRTBNDRPG MATTODR2
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO) DFTACTGRP(*NO) ACTGRP(*CALLER)
H BNDDIR('QC2LE')
**-- Display long text: ------------------------------------------------**
D DspLngTxt Pr ExtPgm( 'QUILNGTX' )
D DtLngTxt 1024a Const Options( *VarSize )
D DtLngTxtLen 10i 0 Const
D DtMsgId 7a Const
D DtMsgF 20a Const
D DtError 10i 0 Const
D*-- GetErrNo ---- Get error number ----------------------------------
D* extern int * __errno(void);
D @__ERRNO PR * EXTPROC('__errno')
D
D*-- StrError ---- Get error text ------------------------------------
D* char *strerror(int errnum);
D STRERROR PR * EXTPROC('strerror')
D ERRNUM 10I 0 VALUE
D
D ERRNO PR 10I 0
**-- Convert date & time: ----------------------------------------------**
D CvtDtf Pr ExtPgm( 'QWCCVTDT' )
D CdInpFmt 10a Const
D CdInpVar 17a Const Options( *VarSize )
D CdOutFmt 10a Const
D CdOutVar 20a Options( *VarSize )
D CdError 10i 0 Const
**-- Qp0zCvtToTimeval()-Convert _MI_Time to Timeval Structure------------**
D DtsToTimeval Pr 10I 0 ExtProc( 'Qp0zCvtToTimeval' )
D toTimeVal * Value
D fromDts 8a Const
D option 10I 0 Value
D p_timeval S *
D timeval DS based(p_timeval)
D tv_sec 10I 0
D tv_usec 10I 0
D QP0Z_CVTTIME_TO_TIMESTAMP...
D C CONST(1)
D tv S *
D tvlen S 10I 0
D rc S 10I 0
D err S 10I 0
D DateOut s 20a Inz( *All'0' )
D MATTOD pr extproc('mattod')
D DTS 8a
D MsgTxt S 256
D DtsCur S 8
D tv_usec6 S 6 0
C Eval *InLr = *On
c eval tvlen = %size(timeval)
c alloc tvlen tv
c eval p_timeval = tv
* get System machine time
C callp MatTOD(DtsCur)
C CallP CvtDtf( '*DTS'
C : DtsCur
C : '*YYMD'
C : DateOut
C : 0
C )
C eval rc = DtsToTimeval (
C tv :
C DtsCur :
C QP0Z_CVTTIME_TO_TIMESTAMP
C )
C if rc < 0
C EVAL ERR = ERRNO
C Eval MsgTxt = 'error: ' + %CHAR(ERR) + ' ' +
C %STR(STRERROR(ERR))
C else
C eval tv_usec6 = tv_usec
C eval %SubSt(DateOut: 15) = %Char(tv_usec6)
C eval MsgTxt = 'Get current _MI_TIME with ' +
C 'MATTOD and converted with ' +
C 'Qp0zCvtToTimeval API -> ' +
C 'Current time is ' +
C DateOut +
C '. Timestamp is ' +
C %Char(tv_sec) + '.' +
C %Char(tv_usec6)
C endIf
**
C CallP(e) DspLngTxt( MsgTxt
C : %Len( MsgTxt )
C : *Blanks
C : *Blanks
C : *Zero
C )
P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P* This procedure return call socket C API errno
P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P ERRNO B
D ERRNO PI 10I 0
D P_ERRNO S *
D WWRETURN S 10I 0 BASED(P_ERRNO)
C EVAL P_ERRNO = @__ERRNO
C RETURN WWRETURN
P E
2011-03-22 如何取得系統 UTC 時間 (API CEEUTC, CEEDATM) ?
如何取得系統 UTC 時間 (API CEEUTC, CEEDATM) ?
File : QRPGLESRC
Member: RTVUTCR
Type : RPGLE
Usage : CRTBNDRPG RTVUTCR
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO) DFTACTGRP(*NO) ACTGRP(*CALLER)
** Convert to arbitrary timestamp API
d CEEDATM PR opdesc
d input_secs 8F const
d pic_string 26A const options(*varsize)
d output_ts 26A options(*varsize)
d feedback 12A options(*omit)
D CEEUTC PR
D output_lil 10I 0
D outptu_secs 8F
D feedback 12A options(*omit)
D
D lilian S 10I 0
D secs S 8F
D zchar S 23A based(pZ)
D pZ S *
D timestamp S Z
D utcString S 26
C callp ceeutc (lilian : secs : *omit)
C eval pZ = %addr(timestamp)
C callp ceedatm (secs :
C 'YYYY-MM-DD-HH.MI.SS.999' :
C zchar :
C *omit)
C* timestamp dsply
C zchar dsply
C return
2009-12-07 如何產生 SHA1 的檢查碼？
如何產生 SHA1 的檢查碼？
由於一般計算 MD5 或 SHA1 檢查碼均是以 ASCII 型態計算，要於 AS/400 EBCDIC 編碼下計算，均須呼叫轉碼
API QTQCVRT 先將 AS/400 EBCDIC 轉換為 ASCII 編碼，再以 ASCII 值取得檢查碼。
SHA1 檢查碼 20 byte 長，轉換為 16 進位顯示為 40 位長。
MD5 檢查碼 16 byte 長，轉換為 16 進位顯示為 32 位長。
File : QRPGLESRC
Member: SHA1R
Type : RPGLE
OS version:
Usage : CRTRPGBND (xxx/SHA1R)
* The SHA1 Algorithm
* http://php.net/manual/en/function.sha1.php
* ascii 'apple'
* SHA1= d0be2dc421be4fcd0172e5afceea3970e2f3d940
H DFTACTGRP(*NO) ACTGRP('QILE') BNDDIR('QC2LE')
DCipher PR EXTPROC('_CIPHER')
D * VALUE
D * VALUE
D * VALUE
DConvert PR EXTPROC('_XLATEB')
D * VALUE
D * VALUE
D 10u 0 VALUE
Dcvthc PR EXTPROC('cvthc')
D 1
D 1
D 10i 0 VALUE
DControls DS
D Function 5i 0 inz(5)
D HashAlg 1 inz(x'01')
D Sequence 1 inz(x'00')
D DataLngth 10i 0 inz(15)
D Unused 8 inz(*LOVAL)
D HashCtxPtr * inz(%addr(HashWorkArea))
DHashWorkArea S 96 inz(*LOVAL)
DMsg S 50
DReceiverHex S 20
DReceiverPtr S * inz(%addr(ReceiverHex))
DReceiverChr S 40
DSourcePtr S * inz(%addr(Msg))
DStartMap s 256
DTo819 s 256
DCCSID1 s 10i 0 inz(37)
DST1 s 10i 0 inz(0)
DL1 s 10i 0 inz(%size(StartMap))
DCCSID2 s 10i 0 inz(819)
DST2 s 10i 0 inz(0)
DGCCASN s 10i 0 inz(0)
DL2 s 10i 0 inz(%size(To819))
DL3 s 10i 0
DL4 s 10i 0
DFB s 12
D ds
D x 5i 0
D LowX 2 2
D* Get all single byte ebcdic hex values
C 0 do 255 x
C eval %subst(StartMap:x+1:1) = LowX
C enddo
C* Get conversion table for 819 from 37
C call 'QTQCVRT'
C parm CCSID1
C parm ST1
C parm StartMap
C parm L1
C parm CCSID2
C parm ST2
C parm GCCASN
C parm L2
C parm To819
C parm L3
C parm L4
C parm FB
C* Set message text
C eval Msg = 'apple'
C eval DataLngth = %len(%trimr(Msg))
C* Now Change Msg to 819 from 37 using MI
C callp Convert( %addr(Msg)
C :%addr(To819)
C :%size(Msg))
C* Get MD5 for Msg
C callp Cipher( %addr(ReceiverPtr)
C :%addr(Controls)
C :%addr(SourcePtr))
C* Convert nibbles to characters
C callp cvthc( ReceiverChr
C :ReceiverHex
C :%size(ReceiverChr))
C* Display the ascii "apple"
* SHA1= d0be2dc421be4fcd0172e5afceea3970e2f3d940
C ReceiverChr dsply
C eval *INLR = '1'
C return
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月 07, 2023
2006-10-11 如何判斷 Job 是 interactive 或 batch(CL command RTVJOBA, API QUSRJOBI, or MI _PCOPTR) ?
如何判斷 Job 是 interactive 或 batch(CL command RTVJOBA, API QUSRJOBI, or MI _PCOPTR) ?
可以使用 CL command RTVJOBA TYPE(&TYPE)
IF (&TYPE *EQ '1') ==> batch(批次)
If (&TYPE *EQ '0') ==> interactive(線上)
或使用 2001-02-06 如何於ＲＰＧ中判斷 Batch 或 Interactive Job -- INTERACTR(API QUSRJOBI)
請至 http://blog.xuite.net/vengoal/as400 Vengoal 日誌瀏覽
或是用本期電子報所提供更快速的系統內建函數(machine interface) _PCOPTR
File : QRPGLESRC
Member: RTVJOBTYPE
Type : RPGLE
Usage : CRTBNDRPG RTVJOBTYPE
CALL RTVJOBTYPER
==> DSPLY I (表示 interactive 線上)
SBMJOB CMD(CALL RTVJOBTYPE)
==> DSPMSG QSYSOPR
會出現 DSPLY B 訊息(表示 batch 批次)
OS version: 適用於V5R1(含)以後
H dftactgrp( *no ) debug
D PCOPTR PR * extproc( '_PCOPTR' )
D Pco DS based( Pco@ ) qualified
D JobType 1A overlay( Pco: 545 )
C eval Pco@ = PCOPTR()
C* show "I" or "B"
C Pco.JobType dsply
C eval *INLR = *on
2006-02-06 如何讓 QSYSOPR 訊息佇列於畫面上自動更新?
如何讓 QSYSOPR 訊息佇列於畫面上自動更新?
此範例是從討論區取得:
http://www.iseriesnetwork.com/isnetforums/showpost.php?p=159391&postcount=7
File : QRPGLESRC
Member : signal_h
Type : RPGLE
Desc : Copy member
/if DEFINED(SIGNAL_H_INCLUDED)
/eof
/endif
/define SIGNAL_H_INCLUDED
*--------------------------------------------------------
* Available signals
*--------------------------------------------------------
D SIGABRT C const(1)
D SIGIOT C const(1)
D SIGLOST C const(1)
D SIGFPE C const(2)
D SIGILL C const(3)
D SIGINT C const(4)
D SIGSEGV C const(5)
D SIGTERM C const(6)
D SIGUSR1 C const(7)
D SIGUSR2 C const(8)
D SIGIO C const(9)
D SIGAIO C const(9)
D SIGPTY C const(9)
D SIGALL C const(10)
D SIGOTHER C const(11)
D SIGKILL C const(12)
D SIGPIPE C const(13)
D SIGALRM C const(14)
D SIGHUP C const(15)
D SIGQUIT C const(16)
D SIGSTOP C const(17)
D SIGTSTP C const(18)
D SIGCONT C const(19)
D SIGCHLD C const(20)
D SIGCLD C const(20)
D SIGTTIN C const(21)
D SIGTTOU C const(22)
D SIGURG C const(23)
D SIGIOINT C const(23)
D SIGPOLL C const(24)
D SIGPCANCEL C const(25)
D SIGPALRM C const(26)
D SIGBUS C const(32)
D SIGDANGER C const(33)
D SIGPRE C const(34)
D SIGSYS C const(35)
D SIGTRAP C const(36)
D SIGPROF C const(37)
D SIGVTALRM C const(38)
D SIGXCPU C const(39)
D SIGXFSZ C const(40)
*--------------------------------------------------------
* flags
*--------------------------------------------------------
D SA_NOCLDSTOP c const(1)
D SA_NODEFER c const(2)
D SA_RESETHAND c const(4)
D SA_SIGINFO c const(8)
*--------------------------------------------------------
* sigprocmask() "how" argument
*--------------------------------------------------------
D SIG_BLOCK c const(0)
D SIG_UNBLOCK c const(1)
D SIG_SETMASK c const(2)
*--------------------------------------------------------
* setitimer() "which" argument
*--------------------------------------------------------
D ITIMER_REAL C 1
D ITIMER_VIRTUAL C 2
D ITIMER_PROF C 2
*--------------------------------------------------------
* sigset_t: signal set data structure
* ===================================
*
* Note: There's not much point in trying to copy the
* way this is done in the ILE C header files,
* since RPG doesn't support integers that are
* 1-bit long. Instead, I've defined the mask as
* one big field, and you can test/set bits with
* the %bitand() and %bitor() BIFs
*--------------------------------------------------------
D sigset_t s 20U 0 based(TEMPLATE)
*--------------------------------------------------------
* sigaction_t: signal action data structure
*
* Prototype for signal handler (only if not SA_SIGINFO)
* D sa_handler PR
* D signo 10I 0 value
*
* Prototype for signal action handler (only if SA_SIGINFO)
*
* D sa_sigaction PR
* D signo 10I 0 value
* D info likeds(siginfo_t)
* D context * value
*--------------------------------------------------------
D sigaction_t ds qualified
D align
D based(TEMPLATE)
D sa_handler * procptr
D sa_mask like(sigset_t)
D sa_flags 10I 0
D sa_sigaction * procptr
*--------------------------------------------------------
* siginfo_t: signal information data structure
*--------------------------------------------------------
D siginfo_t ds qualified
D align
D based(TEMPLATE)
D si_signo 10I 0
D si_bits 5U 0
D si_data_size 5I 0
D si_time 8A
D si_job 10A
D si_user 10A
D si_jobno 6A
D 4A
D si_code 10I 0
D si_errno 10I 0
D si_pid 10I 0
D si_uid 10U 0
D si_data 1A
*--------------------------------------------------------
* itimerval: interval timer value
*--------------------------------------------------------
D it_timeval ds qualified
D based(template)
D tv_sec 10I 0
D tv_usec 10I 0
D itimerval ds qualified
D based(template)
D int_tv_sec 10I 0
D int_tv_usec 10I 0
D val_tv_sec 10I 0
D val_tv_usec 10I 0
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* alarm(): Send an alarm signal after XX seconds
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D alarm PR 10U 0 extproc('alarm')
D secs 10U 0 value
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Qp0sEnableSignals(): Enable a process for signals
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D Qp0sEnableSignals...
D PR 10I 0 extproc('Qp0sEnableSignals')
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Qp0sDisableSignals(): Disable signals
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D Qp0sDisableSignals...
D PR 10I 0 extproc('Qp0sEnableSignals')
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* default signal handlers
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D C_sig_err PR extproc('_C_sig_err')
D signal 10I 0 value
D SIG_ERR S * procptr inz(%paddr(C_sig_err))
D C_sig_dfl PR extproc('_C_sig_dfl')
D signal 10I 0 value
D SIG_DFL S * procptr inz(%paddr(C_sig_dfl))
D C_sig_ign PR extproc('_C_sig_ign')
D signal 10I 0 value
D SIG_IGN S * procptr inz(%paddr(C_sig_ign))
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* sigaction(): Set signal action
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D sigaction PR extproc('sigaction')
D sig 10I 0 value
D act likeds(sigaction_t) const
D options(*omit)
D oact likeds(sigaction_t)
D options(*omit)
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* sigaddset(): add signal to signal set
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D sigaddset PR 10I 0 extproc('sigaddset')
D set like(sigset_t)
D signo 10I 0 value
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* sigdelset(): remove signal from signal set
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D sigdelset PR 10I 0 extproc('sigdelset')
D set like(sigset_t)
D signo 10I 0 value
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* sigemptyset(): initialize an empty signal set
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D sigemptyset PR 10I 0 extproc('sigemptyset')
D set like(sigset_t)
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* sigfillset(): initialize a full signal set
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D sigfillset PR 10I 0 extproc('sigfillset')
D set like(sigset_t)
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* sigismember(): test if signal is in signal set
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D sigismember PR 10I 0 extproc('sigismember')
D set like(sigset_t)
D signo 10I 0 value
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* signal(): set signal action (simplified version of
* sigaction() API)
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D signal PR * procptr
D extproc('signal')
D sig 10I 0 value
D handler * procptr value
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* sigpending(): examine pending signals
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D sigpending PR 10I 0 extproc('sigpending')
D set like(sigset_t)
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* sigprocmask(): Examine and change blocked signals
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D sigprocmask PR 10I 0 extproc('sigprocmask')
D how 10I 0 value
D set like(sigset_t)
D const
D oset like(sigset_t)
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* sigsuspend(): replace signal mask and suspend
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D sigsuspend PR 10I 0 extproc('sigsuspend')
D mask like(sigset_t) const
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* sigwait(): wait for a signal in a set
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D sigwait PR 10I 0 extproc('sigwait')
D set like(sigset_t) const
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* setitimer(): set value for interval timer
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D setitimer PR 10I 0 extproc('setitimer')
D which 10I 0 value
D value like(itimerval) const
D ovalue like(itimerval) options(*omit)
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* getitimer(): Get value of interval timer
*++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D getitimer PR 10I 0 extproc('getitimer')
D which 10I 0 value
D value like(itimerval)
File : QRPGLESRC
Member : refresh
Type : RPGLE
Desc : re-display QSYSOPR automatically
Usage : CRTBNDRPG REFRESH
OS Version: 由於此程式是 free format version 所以編譯時需要指定
TGTRLS(TARGET release) 為 V5R1M0 以上(含V5R1M0)
Usage : CALL REFRESH
此程式是預設 5 秒更新一次, 你可以更改 DISPLAY_SECS 參數預設值,
30 ==> 30 秒,600 ==> 10 分鐘, 重新編譯
*
* Sample of re-displaying the QSYSOPR message queue
* Scott Klement, January 19, 2006
*
* To Compile:
* - Make sure SIGNAL_H member is in QRPGLESRC and in your
* library list.
* - type: CRTBNDRPG REFRESH SRCFILE(xxx/QRPGLESRC) DBGVIEW(*LIST)
*
* (WARNING: Change the ACTGRP at your own risk!)
H DFTACTGRP(*NO) ACTGRP(*NEW) BNDDIR('QC2LE')
* Change the following number if you'd like to change how
* often QSYSOPR is re-displayed. 30 = 30 seconds,
* 600 = every 10 minutes, etc.
*
D DISPLAY_SECS C CONST(5)
/copy signal_h
D QCMDEXC PR extpgm('QCMDEXC')
D command 32702A const options(*Varsize)
D len 15P 5 const
D igc 3A const options(*nopass)
D CEE4RAGE PR
D procedure * procptr const
D feedback 12A options(*omit)
D displaymsg PR 1N
D killcmd PR
D stop_the_kill PR
D rmvmsgs PR
D act ds likeds(sigaction_t)
D Interval ds likeds(itimerval)
D cmd s 2000A varying
D timeout s 1N
D MsgKey s 4A
D status s 10I 0
/free
// ---------------------------------------------------
// Tell system that the killcmd() subprocedure
// should be called whenever an alarm signal is
// received.
// ---------------------------------------------------
sigemptyset(act.sa_mask);
sigaddset(act.sa_mask: SIGALRM);
act.sa_handler = %paddr(killcmd);
act.sa_flags = 0;
act.sa_sigaction = *NULL;
sigaction(SIGALRM: act: *omit);
// ---------------------------------------------------
// Tell system to send an alarm signal every minute:
// ---------------------------------------------------
Interval = *ALLx'00';
Interval.int_tv_sec = DISPLAY_SECS;
Interval.val_tv_sec = DISPLAY_SECS;
setitimer(ITIMER_REAL: Interval: *omit);
CEE4RAGE(%paddr(stop_the_kill): *omit);
// ---------------------------------------------------
// Tell system to send an alarm signal every minute:
// ---------------------------------------------------
dou displaymsg() = *OFF;
enddo;
*inlr = *on;
return;
/end-free
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* This performs a DSPMSG on the QSYSOPR message queue
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P displaymsg B
D displaymsg PI 1N
/free
timeout = *OFF;
monitor;
cmd = 'DSPMSG MSGQ(QSYSOPR) OUTPUT(*)';
QCMDEXC(cmd: %len(cmd));
on-error 202;
rmvmsgs();
endmon;
return timeout;
/end-free
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Send an escape message to the DSPMSG command in order to
* cause it to stop, so we can re-display it.
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P killcmd B
D killcmd PI
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 ErrorCode ds qualified
D BytesProv 10I 0 inz(0)
D BytesAvail 10I 0 inz(0)
/free
timeout = *on;
QMHSNDPM( 'CPF9897'
: 'QCPFMSG *LIBL'
: 'This is sent to kill the DSPMSG command'
: 256
: '*ESCAPE'
: 'DISPLAYMSG'
: 0
: MsgKey
: ErrorCode );
/end-free
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* stop_the_kill(): Disable the timer so that we no longer
* kill any active command after 1 minute.
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P stop_the_kill B
D stop_the_kill PI
/free
Interval = *ALLx'00';
setitimer(ITIMER_REAL: Interval: *omit);
/end-free
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Remove annoying error messages from job log
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P rmvmsgs B
D rmvmsgs PI
D QMHRCVPM PR extpgm('QMHRCVPM')
D RcvVar 32767A options(*varsize)
D RcvVarLen 10I 0 const
D Format 8A const
D StackEnt 10A const
D StackCount 10I 0 const
D MsgType 10A const
D MsgKey 4A const
D WaitTime 10I 0 const
D Action 10A const
D ErrorCode 32767A options(*varsize)
D ErrorCode ds qualified
D BytesProv 10I 0 inz(0)
D BytesAvail 10I 0 inz(0)
D RCVM0100 ds qualified
D BytesRtn 10I 0
D BytesAvail 10I 0
D MsgSev 10I 0
D MsgID 7A
D MsgType 2A
D MsgKey 4A
D 7A
D conv_ind 10I 0
D CCSID 10I 0
D DtaLen 10I 0
D DtaLenAvail 10I 0
D MsgDta 32719A
/free
QMHRCVPM( RCVM0100
: %Size(RCVM0100)
: 'RCVM0100'
: 'DISPLAYMSG'
: 0
: '*ESCAPE'
: MsgKey
: -1
: '*REMOVE'
: ErrorCode );
/end-free
P E
2005-11-21 如何於 RPG 中取得 Java JVM 相關系統資訊 ?
如何於 RPG 中取得 Java JVM 相關系統資訊 ?
此範例程式藉由呼叫 Java 的相關 API,列印 JVM 系統屬性
File : QRPGLESRC
Member: JAVASYSR
Type : RPGLE
Usage : CRTBNDRPG JAVASYSR
CALL JAVASYSR
相關 OS/400 設定參照程式說明
*********************************************************************
* *
* Get Java VM version System Properities *
* first check V5R2 5722SS1 PTF SI13932 *
* V5R1 5722SS1 PTF SI10069 *
* Then use following command specify run time JVM version: *
* *
* ADDENVVAR ENVVAR(QIBM_RPG_JAVA_PROPERTIES) *
* VALUE('-Djava.version=1.3;') *
* or *
* ADDENVVAR ENVVAR(QIBM_RPG_JAVA_PROPERTIES) *
* VALUE('-Djava.version=1.4;') *
* *
*********************************************************************
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
H dftactgrp(*no) thread(*serialize) bnddir('QC2LE')
*********************************************************************
*s6* * Java String method
*********************************************************************
FQSYSPRT O F 132 PRINTER
D newString PR O EXTPROC(*JAVA:
D 'java.lang.String':
D *CONSTRUCTOR)
D Class(*JAVA:'java.lang.String')
D value 65535A CONST VARYING
D stringBytes PR 100A VARYING
D EXTPROC(*JAVA
D :'java.lang.String'
D :'getBytes')
D stringLength PR 10I 0
D EXTPROC(*JAVA
D :'java.lang.String'
D :'length')
* java.lang.trim() --------------------------------------------------
D trimString PR O ExtProc(*JAVA:'java.lang.String'
D :'trim')
D Class(*JAVA:'java.lang.String')
D newProp PR O ExtProc(*JAVA:'java.util.Properties'
D :*CONSTRUCTOR)
D Class(*JAVA:'java.util.Properties')
D prop O Class(*java:'java.util.Properties')
D getSysProp PR O ExtProc(*JAVA:'java.lang.System'
D :'getProperties')
D STATIC
D Class(*java:'java.util.Properties')
D propertyNames PR O ExtProc(*JAVA:'java.util.Properties'
D :'propertyNames')
D Class(*java:'java.util.Enumeration')
D getProperty PR O ExtProc(*JAVA:'java.util.Properties'
D :'getProperty')
D Class(*java:'java.lang.String')
D O Class(*java:'java.lang.String')
D hasMoreElts PR N
D ExtProc(*JAVA:
D 'java.util.Enumeration':
D 'hasMoreElements')
D nextElement PR O
D ExtProc(*JAVA:
D 'java.util.Enumeration':
D 'nextElement')
D Class(*java:
D 'java.lang.Object')
D objToString PR O
D ExtProc(*JAVA:
D 'java.lang.Object':
D 'toString')
D Class(*java:
D 'java.lang.String')
D
D obj S O Class(*java:'java.lang.Object')
D p_String S O Class(*java:'java.lang.String')
D p_Value S O Class(*java:'java.lang.String')
D properties S O Class(*java:'java.util.Properties')
D enumeration S O Class(*java:'java.util.Enumeration')
D pname S 35
D pvalue S 97
/free
properties = getSysProp();
enumeration = propertyNames(properties);
Except Header;
dow hasMoreElts(enumeration);
obj = nextElement(enumeration);
p_string = objToString(obj);
pname = stringBytes(p_string);
p_value = getProperty(properties : p_string);
pvalue = stringBytes(p_value);
Except Detail;
enddo;
// dump;
*InLr = *On;
/end-free
****************************************************************
OQSYSPRT E Header 1
O 50 'Java System Properties'
O E Detail 1
O pname 35
O pvalue 132
星期一, 11月 06, 2023
2005-04-18 如何於 RPG 中取得 message authentication code(MAC) 碼?
如何於 RPG 中取得 message authentication code(MAC) 碼?
線上交易資料交換頻繁, 前二期, 介紹了 XOR, MD5, 此期介紹
message authentication code(MAC), 這是金融業主機資料傳輸
最常用的資料檢核方法, 於 AS/400 上, 從 V5R2起系統開始提
供產生 MAC 的 API, Calculate MAC (QC3CALMA, Qc3CalculateMAC),範例如下:
File : QRPGLESRC
Member: GENMACR
Type : RPGLE
Usage : CRTBNDRPG GENMACR
OS : V5R2 (若使用上有問題, 請確認 QSYS/QC3CALMA 程式有存在, 若不存在,
請安裝 IBM V5R2 要上 PTF#: SI10060 SI10105)
* if you want use procedure call(Qc3CalculateMAC), you need
* use option 15, create module , then
* CRTPGM PGM(lib/GENMACR) BNDSRVPGM(QC3MAC) and with following
* H Spec and D Spec
H*DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
D*GenMacPr PR ExtProc('Qc3CalculateMAC')
*
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO) DFTACTGRP(*NO) ACTGRP(*CALLER)
H BNDDIR('QC2LE')
D cvthex1To2 PR extproc('cvthc')
D longReceiver * value
D shortSource * value
D receiverBytes 10i 0 value
D cvthex2To1 PR extproc('cvtch')
D shortReceiver * value
D longSource * value
D sourceBytes 10i 0 value
D*GenMacPr PR ExtProc('Qc3CalculateMAC')
D GenMacPr PR ExtPgm('QC3CALMA')
D InpDta 1024
D InpDtaLen 10I 0
D InpDtaFmt 8
D AlgDesc like(ALGD0200)
D AlgdFmt 8
D KeyDesc like(KEYD0200)
D KeyFmt 8
D CrypSrv 1
D CrypDev 10
D MacCode 8
D errcde like(APIERR)
D
D*ALGD0200 algorithm description structure
DALGD0200 DS
D QC3BCA 1 4B 0
D* Block Cipher Alg
D QC3BL 5 8B 0
D* Block Length
D QC3MODE 9 9 inz('1')
D* Mode
D QC3PO 10 10 inz('0')
D* Pad Option
D QC3PC 11 11 inz(x'00')
D* Pad Character
D QC3ERVED 12 12 inz(x'00')
D* Reserved
D QC3MACL 13 16B 0
D* MAC Length
D QC3EKS 17 20B 0
D* Effective Key Size
D QC3IV 21 52
D* Init Vector
D*KEYD0200 key description format structure
DKEYD0200 DS
D* Qc3 Format KEYD0200
D QC3KT 1 4B 0
D* Key Type
D QC3KSL 5 8B 0
D* Key String Len
D QC3KF 9 9 inz('0')
D* Key Format
D QC3ERVED02 10 12 inz(x'000000')
D* Reserved
D QC3KS 13 20
D*
D* variable length
* API error structure
D APIERR DS
D ERRPRV 10I 0 INZ(272)
D ERRLEN 10I 0
D EXCPID 7A
D RSRVD2 1A
D EXCPDT 256A
*
D InpDta S 1024
D InpDtaLen S 10I 0
D InpDtaFmt S 8 inz('DATA0100')
D AlgdFmt S 8 inz('ALGD0200')
D KeyFmt S 8 inz('KEYD0200')
D CrypSrv S 1 inz('1')
D CrypDev S 10
D MacCode S 8
D MacCode4 S 4
D MacHexCode S 8
D DataSrc S 1024
D DataSrcLen S 10I 0
D Icv16 S 16
D Icv08 S 8
D IcvLen S 10I 0
D Key16 S 16
D Key08 S 8
D ErrorMsgId S 7
C *Entry Plist
C Parm DataSrc
C Parm Key16
C Parm Icv16
C Parm MacHexCode
C Parm ErrorMsgId
C
C eval DataSrcLen = %len(%trim(DataSrc))
C If %rem(DataSrcLen : 2) > 0
C eval DataSrc = %trim(DataSrc) + '0'
C EndIf
C
* Convert 2 Hex chars to 1 Char
C callp cvthex2To1 (%addr(InpDta)
C : %addr(DataSrc)
C : %len(%trim(DataSrc)))
C eval QC3BCA = 20
C eval QC3BL = 8
C eval QC3MACL = 8
C eval QC3EKS = 0
C eval Icv16 = %xlate(' ': '0' : icv16)
C callp cvthex2To1 (%addr(Icv08)
C : %addr(Icv16)
C : %len(%trim(Icv16)))
C
C eval QC3IV = Icv08
C eval QC3KT = 20
C eval QC3KSL = 8
C callp cvthex2To1 (%addr(Key08)
C : %addr(Key16)
C : %len(%trim(Key16)))
C eval QC3KS = Key08
C eval InpDtaLen = %len(%trim(InpDta))
C
C Callp GenMacPr(
C InpDta :
C InpDtaLen :
C InpDtaFmt :
C AlgD0200 :
C AlgdFmt :
C KeyD0200 :
C KeyFmt :
C CrypSrv :
C CrypDev :
C MacCode :
C ApiErr )
C If ERRLEN = 0
C eval MacCode4 = MacCode
* Convert 1 Char to 2 Hex chars
C callp cvthex1To2 (%addr(MacHexCode)
C : %addr(MacCode4)
C : %len(MacCode4)* 2)
C eval ErrorMsgId = *Blanks
C Else
C eval MacHexCode = *Blanks
C eval ErrorMsgId = EXCPID
C EndIf
C eval *InLr = *On
測試範例
File : QRPGLESRC
Member: GENMACTEST
Type : RPGLE
Usage : CRTBNDRPG GENMACTEST
CALL GENMACTEST
OS : V5R2
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO) DFTACTGRP(*NO) ACTGRP(*CALLER)
D DataSrc S 1024
D Icv16 S 16
D Key16 S 16
D MacHexCode S 8
D ErrorMsgId S 7
D GenMacR PR ExtPgm('GENMACR')
D DataSrc 1024
D Key16 16
D Icv16 16
D MacHexCode 8
D ErrorMsgId 7
C eval Key16 = 'E07DDB948C3F2D44'
* MACCode: 1BB5AD90
C eval DataSrc =
C '574365400000005000000456655687845'
C eval Icv16 = '20040625105948'
C ExSr GenMacSr
* MACCode: DBB695DD
C eval DataSrc =
C '546646800000010000005644651386983'
C eval Icv16 = '20040625110002'
C ExSr GenMacSr
* MACCode: 1181D5A9
C eval DataSrc =
C '689563200000015000006563232565543'
C eval Icv16 = '20040625110025'
C ExSr GenMacSr
* MACCode: 24AC4268
C eval DataSrc =
C '56989876564645646600000005000310686-
C 8542536988'
C eval Icv16 = '20040625110212'
C ExSr GenMacSr
* MACCode: 00FC6820
C eval DataSrc =
C '65523591235858665400000015000110511-
C 3235463238'
C eval Icv16 = '20040625110220'
C ExSr GenMacSr
* MACCode: FBC4650E
C eval DataSrc =
C '65522332325465384100000010000110122-
C 4323235858'
C eval Icv16 = '20040625110232'
C ExSr GenMacSr
* MACCode: 23B09440
C eval DataSrc =
C '104117700000000600000112011274664'
C eval Icv16 = '20050725101431'
C ExSr GenMacSr
* MACCode: 5E8104EC
C eval DataSrc =
C '222759300000000300002792020001542'
C eval Icv16 = '20050725101549'
C ExSr GenMacSr
C eval *InLr = *On
C**********************************************************************
C GenMacSr BegSr
C eval MacHexCode = *Blanks
C eval ErrorMsgId = *Blanks
C Callp GenMacR(
C DataSrc :
C Key16 :
C Icv16 :
C MacHexCode :
C ErrorMsgId )
C
C If ErrorMsgId = *Blanks
C MAcHexCode Dsply
C Else
C ErrorMsgId Dsply
C EndIf
C EndSr
C**********************************************************************
訂閱：
文章 (Atom)