如何於 RPG中 針對所定義的資料結構(DataStructure)排序？(C API QSORT)
於 RPG 中，若要針對矩陣排序相信大家都會使用 SORTA ，但 SORTA 並無法針對
D spec 資料結構的特定欄位排序，若要針對資料結構排序須使用 C API QSORT，V5R1 後，
ILE RPG 支援指定(Qualified)資料結構的欄位範例如下：
File : QRPGLESRC
Member: QSORTR
Type : RPGLE
Usage : CRTBNDRPG QSORTR
CALL QSORTR
OS Version: V5R1
H DFTACTGRP(*NO) BNDDIR('QC2LE')
D qsort PR ExtProc('qsort')
D base * value
D num 10U 0 value
D width 10U 0 value
D compare * procptr value
D SortByItem PR 10I 0
D parm1 likeds(Order)
D parm2 likeds(Order)
D SortByQty PR 10I 0
D parm1 likeds(Order)
D parm2 likeds(Order)
D Order DS based(prototype_only)
D Qualified
D DtlItem 12A
D DtlOrdQty 5S 0
D Order1 DS likeds(Order) dim(99)
D numitems s 10I 0
D idx s 10I 0
D tmpstr s 50
D tmpnbr s 10I 0
** Throw some sample data into array to test it.
c eval order1(1).DtlItem = 'ZZ123'
c eval order1(1).DtlOrdQty = 5
c eval order1(2).DtlItem = 'BB321'
c eval order1(2).DtlOrdQty = 17
c eval order1(3).DtlItem = 'RR826'
c eval order1(3).DtlOrdQty = 14
c eval order1(4).DtlItem = 'AA000'
c eval order1(4).DtlOrdQty = 3
c eval numitems = 4
** Sort the array by DtlItem
c callp qsort(%addr(Order1): numitems:
c %size(Order): %paddr('SORTBYITEM'))
c For idx= 1 to numitems
c eval tmpstr = order1(idx).DtlItem
c Dsply tmpstr
c Endfor
** Sort the array by DtlOrdQty
c callp qsort(%addr(Order1): numitems:
c %size(Order): %paddr('SORTBYQTY'))
c For idx= 1 to numitems
c eval tmpnbr = order1(idx).DtlOrdQty
c Dsply tmpnbr
c Endfor
c eval *inlr = *on
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P SortByItem B
D SortByItem PI 10I 0
D parm1 likeds(Order)
D parm2 likeds(Order)
c select
c when parm1.DtlItem < parm2.DtlItem
c return -1
c when parm1.DtlItem > parm2.DtlItem
c return 1
c other
c return 0
c endsl
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P SortByQty B
D SortByQty PI 10I 0
D parm1 likeds(Order)
D parm2 likeds(Order)
c select
c when parm1.DtlOrdQty < parm2.DtlOrdQty
c return -1
c when parm1.DtlOrdQty > parm2.DtlOrdQty
c return 1
c other
c return 0
c endsl
P E
星期一, 11月 06, 2023
2003-12-09 如何於 RPG中 針對所定義的資料結構(DataStructure)排序？(C API QSORT)
2003-08-26 如何於 CLP 中列出 PF 的 Member ? (API QUSLMBR)
如何於 CLP 中列出 PF 的 Member ? (API QUSLMBR)
有二種方式：
1.
PGM
DCLF QAFDMBRL
DSPFD FILE(lib/file) TYPE(*MBRLIST) OUTPUT(*OUTFILE) OUTFILE(lib/MBRLIST)
OVRDBF FILE(QAFDMBRL) TOFILE(lib/MBRLIST)
LOOP:
RCVF
MONMSG CPF0864 EXEC(GOTO END)
SNDPGMMSG MSG(&MLNAME)
GOTO LOOP
END:
DLTOVR FILE(*ALL)
ENDPGM
2. API QUSLMBR
Usage: CRTCLPGM LSTMBRC
CALL LSTMBRC('lib' 'file')
/*-------------------------------------------------------------------*/
/* LSTMBRC - List processing for file members - Example Pgm */
/* */
/* This program was done as an example of working with APIs in */
/* a CL program. */
/* */
/*-------------------------------------------------------------------*/
/* Program Summary: */
/* */
/* Initialize binary values */
/* Create user space (API CALL) */
/* Load user space with member names (API CALL) */
/* Extract entries from user space (API CALL) */
/* Loop until all entries have been processed */
/* */
/*-------------------------------------------------------------------*/
/* API (application program interfaces) used: */
/* */
/* QUSCRTUS create user space */
/* QUSLMBR list file members */
/* QUSRTVUS retrieve user space */
/* See SYSTEM PROGRAMMER'S INTERFACE REFERENCE for API detail. */
/* */
/*-------------------------------------------------------------------*/
PGM (&LIB &FILE)
DCL &LIB *CHAR 10
DCL &FILE *CHAR 10
/*-------------------------------------------------------------------*/
/* $POSIT - binary fields to control calls to APIs. */
/* #START - get initial offset, # of elements, length of element. */
/*-------------------------------------------------------------------*/
DCL &STARTC *CHAR 4 /* $POSIT */
DCL &LENGTC *CHAR 4 /* $POSIT */
DCL &STARTN *CHAR 16
DCL &OFSET *DEC (7 0)
DCL &ELEMS *DEC (7 0)
DCL &LENGT *DEC (7 0)
/*-------------------------------------------------------------------*/
/* Error return code parameter for the APIs */
/*-------------------------------------------------------------------*/
DCL &DSERR *CHAR 256
DCL &BYTPV *CHAR 4
DCL &BYTAV *CHAR 4
DCL &MSGID *CHAR 7
DCL &RESVD *CHAR 1
DCL &EXDTA *CHAR 240
/*-------------------------------------------------------------------*/
/* Define the fields used by the create user space API. */
/*-------------------------------------------------------------------*/
DCL &SPACE *CHAR 20 ('LSTOBJR QTEMP ')
DCL &EXTEN *CHAR 10 ('TEST')
DCL &INIT *CHAR 1 (X'00')
DCL &AUTHT *CHAR 10 ('*ALL')
DCL &APITX *CHAR 50
DCL &REPLA *CHAR 10 ('*NO')
/*-------------------------------------------------------------------*/
/* various other fields */
/*-------------------------------------------------------------------*/
DCL &FORMAT *CHAR 8 ('MBRL0200') /* QUSLMBR */
DCL &FIELD *CHAR 30 /* QUSRTVUS */
DCL &MEMBR *CHAR 10
DCL &FILLB *CHAR 20 ('QCLSRC QGPL ')
DCL &MBRNM *CHAR 10 ('*ALL ')
DCL &MTYPE *CHAR 10
DCL &COUNT *DEC (5 0)
CHGVAR %SST(&FILLB 1 10) &FILE
CHGVAR %SST(&FILLB 11 10) &LIB
/*-------------------------------------------------------------------*/
/* Initialize Binary fields and build error return code variable */
/*-------------------------------------------------------------------*/
CHGVAR %BIN(&STARTC) 0
CHGVAR %BIN(&LENGTC) 50000
CHGVAR %BIN(&BYTPV) 8
CHGVAR %BIN(&BYTAV) 0
CHGVAR &DSERR +
( &BYTPV || &BYTAV || &MSGID || &RESVD || &EXDTA)
/*-- Create user space. ---------------------------------------------*/
CALL PGM(QUSCRTUS) PARM(&SPACE &EXTEN &INIT +
&LENGTC &AUTHT &APITX &REPLA &DSERR)
/*-------------------------------------------------------------------*/
/* Call API to load the member names to the user space. */
/*-------------------------------------------------------------------*/
A: CALL PGM(QUSLMBR) PARM(&SPACE &FORMAT &FILLB +
&MBRNM '0' &DSERR)
CHGVAR %BIN(&STARTC) 125
CHGVAR %BIN(&LENGTC) 16
/*-------------------------------------------------------------------*/
/* Call API to return the starting position of the first block, the */
/* length of each data block, and the number of blocks are returned. */
/*-------------------------------------------------------------------*/
CALL PGM(QUSRTVUS) PARM(&SPACE &STARTC &LENGTC +
&STARTN &DSERR)
CHGVAR &ELEMS %BIN(&STARTN 9 4) /* # OF ENTRIES */
IF (&ELEMS = 0) GOTO C /* NO OBJECTS */
CHGVAR &OFSET %BIN(&STARTN 1 4) /* TO 1ST OFFSET */
CHGVAR &LENGT %BIN(&STARTN 13 4) /* LEN OF ENTRIES */
CHGVAR %BIN(&STARTC) (&OFSET + 1)
CHGVAR %BIN(&LENGTC) &LENGT
/*-------------------------------------------------------------------*/
/* Call API to retrieve the data from the user space. &ELEMS */
/* is the number of data blocks to retrieve. Each block contains a */
/* the name of a member. */
/*-------------------------------------------------------------------*/
CHGVAR &COUNT 0
B: CHGVAR &COUNT (&COUNT + 1)
IF (&COUNT *LE &ELEMS) DO
CALL PGM(QUSRTVUS) PARM(&SPACE &STARTC &LENGTC +
&FIELD &DSERR)
CHGVAR &MTYPE %SST(&FIELD 11 10) /* MEMBER TYPE */
CHGVAR &MBRNM %SST(&FIELD 1 10) /* EXTRACT MEMBER NAME */
/* IF (&MTYPE = 'PRTF ') DO */
/* DO YOUR CODE HERE */
SNDPGMMSG MSG(&MBRNM)
/* ENDDO */
CHGVAR &OFSET %BIN(&STARTC)
CHGVAR %BIN(&STARTC) (&OFSET + &LENGT)
GOTO B
ENDDO
C:
DLTUSRSPC USRSPC(QTEMP/LSTOBJR)
ENDPGM
2003-08-06 TCPIP SOCKET RPG 程式範例(Echo server)
TCPIP SOCKET RPG 程式範例(Echo server)
前期電子報介紹 RPG SOCKET 程式的參考資訊，各位先進應該看完了吧。
本期我以一個 Echo server 來當作範例，並提供一隻 echo client rpg 程式讓您測試，
當然您也可以直接利用 telnet 程式測試。
此 Echo server socket 程式啟動後會依照所傳參數(AS/400 host ip 及 port number)，
將之 bind 連結到 socket 中，然後 listen 傾聽所指定的 port 有無 client 端連線
需求，如果有就 accept 接受連結，接著傳送連結訊息至 client 端，接著等待 client
輸入任何字串，當 client 端輸入訊息並傳送出去後，Echo server 收到厚利即將原字串
傳回 client 端。當 client 輸入 QUIT 字串時，Echo server 會將此連線中斷，並等待
下一個 client 提出連線需求。
整個流程如下：
Echo Server Echo Client
Create socket Create socket
Bind Bind(可有可無)
Listen
--> Accept <--------- Connect
|
| Send ---------> Receive
| /\ ||
| || \/
| Receive <---------- Send
| "QUIT" "QUIT"
| || ||
| \/ \/
| Close Close
| Client socket
| ||
| \/
------
File : QRPGLESRC
Member: SOCKETSVRR (Echo Server)
Type : RPGLE
Usage : CRTBNDRPG SOCKETSVRR
OS version: V4R1
H DFTACTGRP(*NO) ACTGRP(*NEW) BNDDIR('QC2LE')
H Debug
D Cmd PR ExtPgm('QCMDEXC')
D command 200A const
D length 15P 5 const
*-------------------------------------------------------------------
* prototype definitions
*-------------------------------------------------------------------
D @__errno PR * ExtProc('__errno')
D strerror PR * ExtProc('strerror')
D errnum 10I 0 value
D perror PR ExtProc('perror')
D comment * value options(*string)
D errno PR 10I 0
*-------------------------------------------------------------------
* socket C API prototype definitions
*-------------------------------------------------------------------
D getservbyname PR * ExtProc('getservbyname')
D service_name * value options(*string)
D protocol_name * value options(*string)
D p_servent S *
D servent DS based(p_servent)
D s_name *
D s_aliases *
D s_port 10I 0
D s_proto *
D inet_addr PR 10U 0 ExtProc('inet_addr')
D address_str * value options(*string)
D INADDR_NONE C CONST(4294967295)
D* any address available
D INADDR_ANY C CONST(0)
D inet_ntoa PR * ExtProc('inet_ntoa')
D internet_addr 10U 0 value
D p_hostent S *
D hostent DS Based(p_hostent)
D h_name *
D h_aliases *
D h_addrtype 10I 0
D h_length 10I 0
D h_addr_list *
D p_h_addr S * Based(h_addr_list)
D h_addr S 10U 0 Based(p_h_addr)
D p_linger S *
D linger DS BASED(p_linger)
D l_onoff 10I 0
D l_linger 10I 0
D gethostbyname PR * extproc('gethostbyname')
D host_name * value options(*string)
D socket PR 10I 0 ExtProc('socket')
D addr_family 10I 0 value
D type 10I 0 value
D protocol 10I 0 value
D AF_INET C CONST(2)
D SOCK_STREAM C CONST(1)
D IPPROTO_IP C CONST(0)
D bind PR 10I 0 ExtProc('bind')
D Sock_Desc 10I 0 Value
D p_Address * Value
D AddressLen 10I 0 Value
D Select PR 10I 0 extproc('select')
D max_desc 10I 0 VALUE
D read_set * VALUE
D write_set * VALUE
D except_set * VALUE
D wait_Time * VALUE
D listen PR 10I 0 ExtProc('listen')
D SocketDesc 10I 0 Value
D Back_Log 10I 0 Value
D accept PR 10I 0 ExtProc('accept')
D Sock_Desc 10I 0 Value
D p_Address * Value
D p_AddrLen 10I 0
D connect PR 10I 0 ExtProc('connect')
D sock_desc 10I 0 value
D dest_addr * value
D addr_len 10I 0 value
D p_sockaddr S *
D sockaddr DS based(p_sockaddr)
D sa_family 5I 0
D sa_data 14A
D sockaddr_in DS based(p_sockaddr)
D sin_family 5I 0
D sin_port 5U 0
D sin_addr 10U 0
D sin_zero 8A
D send PR 10I 0 ExtProc('send')
D sock_desc 10I 0 value
D buffer * value
D buffer_len 10I 0 value
D flags 10I 0 value
D recv PR 10I 0 ExtProc('recv')
D sock_desc 10I 0 value
D buffer * value
D buffer_len 10I 0 value
D flags 10I 0 value
D close PR 10I 0 ExtProc('close')
D sock_desc 10I 0 value
D setsockopt PR 10I 0 ExtProc('setsockopt')
D SocketDesc 10I 0 Value
D Opt_Level 10I 0 Value
D Opt_Name 10I 0 Value
D Opt_Value * Value
D Opt_Len 10I 0 Value
D translate PR ExtPgm('QDCXLATE')
D length 5P 0 const
D data 32766A options(*varsize)
D table 10A const
D die PR
D peMsg 256A const
D* socket layer
D SOL_SOCKET C CONST(-1)
D* re-use local address
D SO_REUSEADDR C 55
D* linger upon close
D SO_LINGER C 30
D msg S 50A
D sock S 10I 0
D port S 5U 0
D addrlen S 10I 0
D ch S 1A
D local s 32A
D localportc s 5A
D IPLocal s 10U 0
D p_bindto S *
D p_Connfrom S *
D lsock S 10I 0
D csock S 10I 0
D RC S 10I 0
D Request S 50A
D ReqLen S 10I 0
D RecBuf S 50A
D RecLen S 10I 0
D on S 10I 0 inz(1)
D err S 10I 0
D clientip S 17A
D line S 80A
D ling S *
D linglen S 10I 0
C*************************************************
C* The user will supply a hostname and port
C* for client connect
C*************************************************
c *entry plist
c parm local
c parm localportc
c eval *inlr = *on
c exsr MakeListener
c dow 1 = 1
c exsr AcceptConn
c exsr TalkToClient
c callp close(csock)
c enddo
C*===============================================================
C* This subroutine sets up a socket to listen for connections
C* include socket, bind, listen API
C*===============================================================
CSR MakeListener begsr
*
C* Get the 32-bit network IP address for
C* local that was supplied by the user:
*
c If local <> *blanks
c eval IPLocal = inet_addr(%trim(local))
c if IPLocal = INADDR_NONE
c eval p_hostent = gethostbyname(%trim(local))
c if p_hostent = *NULL
c callp die('Unable to find that local!')
c return
c endif
c eval IPLocal = h_addr
c endif
c Else
c eval IPlocal = INADDR_ANY
c EndIf
c
c if localportc <> *blanks
c move localportc port
c else
c callp die('Wrong port specified !')
c return
c endif
C* Create a socket
c eval sock = socket(AF_INET: SOCK_STREAM:
c IPPROTO_IP)
c if sock < 0
c callp die('socket(): ' + %str(strerror(errno)))
c return
c endif
C*** Tell socket that we want to be able to re-use the server
C*** port without waiting for the MSL timeout:
c callp setsockopt(sock: SOL_SOCKET:
c SO_REUSEADDR: %addr(on): %size(on))
C* create space for a linger structure
c eval linglen = %size(linger)
c alloc linglen ling
c eval p_linger = ling
C* tell socket to only linger for 2 minutes, then discard:
c eval l_onoff = 1
c eval l_linger = 1
c callp setsockopt(lsock: SOL_SOCKET: SO_LINGER:
c ling: linglen)
C* bind the socket to local port , of any IP address
C* Allocate some space for some socket addresses
c eval addrlen = %size(sockaddr_in)
c alloc addrlen p_bindto
c alloc addrlen p_connfrom
c eval p_sockaddr = p_bindto
c move localportc port
c eval sin_family = AF_INET
c eval sin_addr = IPLocal
c eval sin_port = port
c eval sin_zero = *ALLx'00'
c if bind(sock: p_bindto: addrlen) < 0
c eval err = errno
c callp close(sock)
c callp die('bind(): ' + %str(strerror(err)))
c return
c endif
C* Indicate that we want to listen for connections
c if listen(sock: 5) < 0
c eval err = errno
c callp close(sock)
c callp die('listen(): ' + %str(strerror(err)))
c return
c endif
C
CSR endsr
C*===============================================================
C* This subroutine accepts a new socket connection
C*===============================================================
CSR AcceptConn begsr
C*------------------------
c dou addrlen = %size(sockaddr_in)
C* Accept the next connection.
c eval addrlen = %size(sockaddr_in)
c eval csock = accept(sock: p_connfrom: addrlen)
c if csock < 0
c eval err = errno
c callp close(sock)
c callp die('accept(): ' + %str(strerror(err)))
c return
c endif
C* tell socket to only linger for 2 minutes, then discard:
c eval l_onoff = 1
c eval l_linger = 120
c callp setsockopt(csock: SOL_SOCKET: SO_LINGER:
c ling: linglen)
C* If socket length is not 16, then the client isn't sending the
C* same address family as we are using... that scares me, so
C* we'll kick that guy off.
c if addrlen <> %size(sockaddr_in)
c callp close(csock)
c endif
c enddo
c eval p_sockaddr = p_connfrom
c eval clientip = %str(inet_ntoa(sin_addr))
c clientip dsply
C*------------------------
CSR endsr
C*===============================================================
C* This does a quick little conversation with the connecting
c* client.
C*===============================================================
CSR TalkToClient begsr
C*------------------------
c eval line ='Connection from ' +
c %trim(clientip)
c exsr WrLine
c eval line ='Please enter your name now!'
c exsr WrLine
c eval recbuf = *blanks
c Dow %SubSt(recbuf : 1 : 4) <> 'QUIT'
c exsr RdLine
c If reclen > 0
c eval line = 'Server response: ' + recbuf
c exsr WrLine
c EndIf
c Enddo
c eval line ='Goodbye '
c exsr WrLine
c dealloc(E) p_connfrom
c callp Cmd('DLYJOB DLY(1)': 200)
C*------------------------
CSR endsr
C*===============================================================
C* This subroutine send data to socket client with CRLF
C*===============================================================
CSR WrLine begsr
c eval reqlen = %len(%trim(line))
c callp Translate(reqlen: line: 'QTCPASC')
c eval line = %trim(line) + X'0D0A'
c eval reqlen = %len(%trim(line))
c* 'dmptxt' dump
c eval rc= send(csock: %addr(line): reqlen:0)
c if rc < reqlen
c callp close(csock)
c callp die('Unable to send entire request!')
c return
c endif
CSR endsr
C*===============================================================
C* This subroutine receives what we send to server and
C* displays it on the screen using the DSPLY op-code
C*===============================================================
CSR RdLine begsr
C*------------------------
C*************************************************
C* Receive one line of text from the socket client
C* note that "lines of text" vary in length,
C* but always end with the ASCII values for CR
C* and LF. CR = x'0D' and LF = x'0A'
C*
C* The easiest way for us to work with this data
C* is to receive it one byte at a time until we
C* get the LF character. Each time we receive
C* a byte, we add it to our receive buffer.
C*************************************************
c eval reclen = 0
c eval recbuf = *blanks
c dou reclen = 80 or ch = x'0A'
c eval rc = recv(csock: %addr(ch): 1: 0)
c if rc < 1
c 'rcvfail' dsply
c callp close(csock)
c callp die('Unable to receive data !')
c return
c endif
c if ch<>x'0D' and ch<>x'0A'
c eval reclen = reclen + 1
c eval %subst(recbuf:reclen:1) = ch
c endif
c enddo
C*************************************************
C* translate the line of text into EBCDIC
C* (to make it readable) and display it
C*************************************************
c if reclen > 0
c callp Translate(reclen: recbuf: 'QTCPEBC')
c recbuf dsply
c endif
C*------------------------
Csr endsr
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* This ends this program abnormally, and sends back an escape.
* message explaining the failure.
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P die B
D die PI
D peMsg 256A const
D SndPgmMsg 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 32766A options(*varsize)
D dsEC DS
D dsECBytesP 1 4I 0 INZ(256)
D dsECBytesA 5 8I 0 INZ(0)
D dsECMsgID 9 15
D dsECReserv 16 16
D dsECMsgDta 17 256
D wwMsgLen S 10I 0
D wwTheKey S 4A
c eval wwMsgLen = %len(%trimr(peMsg))
c if wwMsgLen<1
c return
c endif
c callp SndPgmMsg('CPF9897': 'QCPFMSG *LIBL':
c peMsg: wwMsgLen: '*ESCAPE':
c '*PGMBDY': 1: wwTheKey: dsEC)
c return
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* This procedure return call socket C API errno
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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
File : QRPGLESRC
Member: SOCKETCLTR (Echo Client)
Type : RPGLE
Usage : CRTBNDRPG SOCKETCLTR
OS version: V4R1
H DFTACTGRP(*NO) ACTGRP(*NEW) BNDDIR('QC2LE')
H Debug
*-------------------------------------------------------------------
* prototype definitions
*-------------------------------------------------------------------
D @__errno PR * ExtProc('__errno')
D strerror PR * ExtProc('strerror')
D errnum 10I 0 value
D perror PR ExtProc('perror')
D comment * value options(*string)
D errno PR 10I 0
*-- Sleep --- Sleep function (delay job) ------------------------
* unsigned int sleep( unsigned int seconds );
D sleep Pr 10U 0 ExtProc('sleep')
D 10U 0 Value
* socket C API prototype definitions
*-------------------------------------------------------------------
D getservbyname PR * ExtProc('getservbyname')
D service_name * value options(*string)
D protocol_name * value options(*string)
D p_servent S *
D servent DS based(p_servent)
D s_name *
D s_aliases *
D s_port 10I 0
D s_proto *
D inet_addr PR 10U 0 ExtProc('inet_addr')
D address_str * value options(*string)
D INADDR_NONE C CONST(4294967295)
D inet_ntoa PR * ExtProc('inet_ntoa')
D internet_addr 10U 0 value
D p_hostent S *
D hostent DS Based(p_hostent)
D h_name *
D h_aliases *
D h_addrtype 10I 0
D h_length 10I 0
D h_addr_list *
D p_h_addr S * Based(h_addr_list)
D h_addr S 10U 0 Based(p_h_addr)
D gethostbyname PR * extproc('gethostbyname')
D host_name * value options(*string)
D socket PR 10I 0 ExtProc('socket')
D addr_family 10I 0 value
D type 10I 0 value
D protocol 10I 0 value
D AF_INET C CONST(2)
D SOCK_STREAM C CONST(1)
D IPPROTO_IP C CONST(0)
D bind PR 10I 0 ExtProc('bind')
D Sock_Desc 10I 0 Value
D p_Address * Value
D AddressLen 10I 0 Value
D connect PR 10I 0 ExtProc('connect')
D sock_desc 10I 0 value
D dest_addr * value
D addr_len 10I 0 value
D p_sockaddr S *
D sockaddr DS based(p_sockaddr)
D sa_family 5I 0
D sa_data 14A
D sockaddr_in DS based(p_sockaddr)
D sin_family 5I 0
D sin_port 5U 0
D sin_addr 10U 0
D sin_zero 8A
D send PR 10I 0 ExtProc('send')
D sock_desc 10I 0 value
D buffer * value
D buffer_len 10I 0 value
D flags 10I 0 value
D recv PR 10I 0 ExtProc('recv')
D sock_desc 10I 0 value
D buffer * value
D buffer_len 10I 0 value
D flags 10I 0 value
D close PR 10I 0 ExtProc('close')
D sock_desc 10I 0 value
D setsockopt PR 10I 0 ExtProc('setsockopt')
D SocketDesc 10I 0 Value
D Opt_Level 10I 0 Value
D Opt_Name 10I 0 Value
D Opt_Value * Value
D Opt_Len 10I 0 Value
D translate PR ExtPgm('QDCXLATE')
D length 5P 0 const
D data 32766A options(*varsize)
D table 10A const
D die PR
D peMsg 256A const
D* socket layer
D SOL_SOCKET C CONST(-1)
D* re-use local address
D SO_REUSEADDR C 55
D msg S 50A
D sock S 10I 0
D port S 5U 0
D addrlen S 10I 0
D ch S 1A
D host s 32A
D hostportc s 5A
D local s 32A
D localportc s 5A
D IPHost s 10U 0
D IPLocal s 10U 0
D p_bindto S *
D p_Connto S *
D RC S 10I 0
D Request S 50A
D ReqLen S 10I 0
D RecBuf S 50A
D RecLen S 10I 0
D on S 10I 0 inz(1)
D err S 10I 0
C*************************************************
C* The user will supply a hostname and file
C* name as parameters to our program...
C*************************************************
c *entry plist
c parm host
c parm hostportc
c parm local
c parm localportc
c eval *inlr = *on
c exsr SktCnn
c exsr TalkToSktSvr
C*************************************************
C* SOCKET CONNECTION
C*************************************************
C SktCnn BegSr
C*************************************************
C* Get the 32-bit network IP address for the host
C* & local that was supplied by the user:
C*************************************************
c eval IPHost = inet_addr(%trim(host))
c if IPHost = INADDR_NONE
c eval p_hostent = gethostbyname(%trim(host))
c if p_hostent = *NULL
c callp die('Unable to find that host!')
c return
c endif
c eval IPHost = h_addr
c endif
c If local <> *blanks
c eval IPLocal = inet_addr(%trim(local))
c if IPLocal= INADDR_NONE
c eval p_hostent = gethostbyname(%trim(local))
c if p_hostent = *NULL
c callp die('Unable to find that local!')
c return
c endif
c eval IPLocal = h_addr
c endif
c endif
C*************************************************
C* Create a socket
C*************************************************
c eval sock = socket(AF_INET: SOCK_STREAM:
c IPPROTO_IP)
c if sock < 0
c callp die('socket(): ' + %str(strerror(errno)))
c return
c endif
C*** Tell socket that we want to be able to re-use the server
C*** port without waiting for the MSL timeout:
c callp setsockopt(sock: SOL_SOCKET:
c SO_REUSEADDR: %addr(on): %size(on))
C if local <> *blanks And
C localportc <> *blanks
C* bind the socket to local port , of any IP address
C* Allocate some space for some socket addresses
c eval addrlen = %size(sockaddr_in)
c alloc addrlen p_bindto
c eval p_sockaddr = p_bindto
c move localportc port
c eval sin_family = AF_INET
c eval sin_addr = IPLocal
c eval sin_port = port
c eval sin_zero = *ALLx'00'
c if bind(sock: p_bindto: addrlen) < 0
c eval err = errno
c callp close(sock)
c callp die('bind(): ' + %str(strerror(err)))
c return
c endif
c endif
C*************************************************
C* Create a socket address structure that
C* describes the host & port we wanted to
C* connect to
C*************************************************
c eval addrlen = %size(sockaddr)
c alloc addrlen p_connto
c eval p_sockaddr = p_connto
c move hostportc port
c eval sin_family = AF_INET
c eval sin_addr = IPHost
c eval sin_port = port
c eval sin_zero = *ALLx'00'
C*************************************************
C* Connect to the requested host
C*************************************************
C if connect(sock: p_connto: addrlen) < 0
c eval err = errno
c callp close(sock)
c callp die('Connect(): ' + %str(strerror(err)))
c return
c endif
C EndSr
C*************************************************
C* TALK TO SOCKET SERVER
C*************************************************
C TalktoSktSvr BegSr
C*************************************************
C* Format a request and tralslate to ASCII and
C* send to socket server depend on your purpose
C*************************************************
C Dow *In99 = *Off
* once connect , receive socket server
* two welcome message
c N90 do 2
C exsr RecvResponse
c eval *In90 = *on
c enddo
* input anything you want
c clear request
c 'Input String'Dsply
c Dsply request
c eval reqlen = %len(%trim(request))
c If reqlen = 0
c iter
c EndIf
c If %SubSt(request : 1 : 4) = 'QUIT'
c eval *In99 = *On
c EndIf
c* eval request = 'Any data to send to socket server'
c callp Translate(reqlen: request: 'QTCPASC')
C*************************************************
c* Append ASCII X'0D0A' to request means end of
C* line and send the request to the socket server
C*************************************************
c eval request = %trim(request) + X'0D0A'
c eval reqlen = %len(%trim(request))
c eval rc = send(sock: %addr(request): reqlen:0)
c if rc < reqlen
c callp close(sock)
c callp die('Unable to send entire request!')
c return
c endif
c* 'sended' dsply
C exsr RecvResponse
C*************************************************
C* Get back the server's response
C*************************************************
C enddo
* get 'GoodBye' message
C exsr RecvResponse
C*************************************************
C* We're done, so close the socket.
C* do a dsply with input to pause the display
C* and then end the program
C*************************************************
c callp close(sock)
c dsply pause 1
c return
C EndSr
C*===============================================================
C* This subroutine receives what we send to server and
C* displays it on the screen using the DSPLY op-code
C*===============================================================
CSR RecvResponse begsr
C*------------------------
C*************************************************
C* Receive one line of text from the socket server.
C* note that "lines of text" vary in length,
C* but always end with the ASCII values for CR
C* and LF. CR = x'0D' and LF = x'0A'
C*
C* The easiest way for us to work with this data
C* is to receive it one byte at a time until we
C* get the LF character. Each time we receive
C* a byte, we add it to our receive buffer.
C*************************************************
c eval reclen = 0
c eval recbuf = *blanks
c dou reclen = 50 or ch = x'0A'
c eval rc = recv(sock: %addr(ch): 1: 0)
c if rc < 1
c leave
c endif
c if ch<>x'0D' and ch<>x'0A'
c eval reclen = reclen + 1
c eval %subst(recbuf:reclen:1) = ch
c endif
c enddo
C*************************************************
C* translate the line of text into EBCDIC
C* (to make it readable) and display it
C*************************************************
c if reclen > 0
c callp Translate(reclen: recbuf: 'QTCPEBC')
c endif
c recbuf dsply
C*------------------------
Csr endsr
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* This ends this program abnormally, and sends back an escape.
* message explaining the failure.
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P die B
D die PI
D peMsg 256A const
D SndPgmMsg 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 32766A options(*varsize)
D dsEC DS
D dsECBytesP 1 4I 0 INZ(256)
D dsECBytesA 5 8I 0 INZ(0)
D dsECMsgID 9 15
D dsECReserv 16 16
D dsECMsgDta 17 256
D wwMsgLen S 10I 0
D wwTheKey S 4A
c eval wwMsgLen = %len(%trimr(peMsg))
c if wwMsgLen<1
c return
c endif
c callp SndPgmMsg('CPF9897': 'QCPFMSG *LIBL':
c peMsg: wwMsgLen: '*ESCAPE':
c '*PGMBDY': 1: wwTheKey: dsEC)
c return
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* This procedure return call socket C API errno
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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
執行方式：
1. 執行 Echo server
SBMJOB CMD(CALL SOCKETSVRR('your-as/400-ip' 'port')) JOB(SOCKETSVR)
or
SBMJOB CMD(CALL PGM(SOCKETSVRR) PARM('172.16.15.35' '04000')) JOB(SOCKETSR)
2. 執行 Echo client
CALL PGM(SOCKETcltR) PARM('your-as/400 ip' 'port' 'local-as/400 ip' 'local port')
or
CALL PGM(SOCKETCLTR) PARM('172.16.15.35' '04000' '172.16.15.35' '21000')
or
在 PC DOS 視窗上執行 telnet AS/400IPAddress PORT
telnet AS/400IP PORT
telnet 172.16.15.35 4000
本 Echo server 範例程式目前僅做 ASCII, EBCDIC 轉換，位支援 big5 中文轉換，
你可以使用 API iconv() 或 API QDCXLATE 轉換，或自行轉碼。 相關轉碼請參閱：
http://publib.boulder.ibm.com/iseries/v5r1/ic2924/info/apis/iconv.htm
http://publib.boulder.ibm.com/iseries/v5r1/ic2924/index.htm?info/apis/QDCXLATE.htm
2003-07-29 如何利用 RPG 寫 TCP/IP Socket 程式 ?
如何利用 RPG 寫 TCP/IP Socket 程式 ?
要利用 RPG 寫 TCP/IP socket 程式，則需要透過呼叫 C 的相關 API，與 TCP/IP 相關的
C API 詳細表列於
https://www.ibm.com/docs/en/i/7.5?topic=communications-socket-programming
Sockets APIs system functions
https://www.ibm.com/docs/en/i/7.5?topic=ssw_ibm_i_75/apis/unix8a.html
Sockets APIs network functions
https://www.ibm.com/docs/en/i/7.5?topic=ssw_ibm_i_75/apis/unix8b.html
若想要了解 Socket 程式設計請參考 Sockets Programming，此連結文件包含所有相關紅皮書及 Socket 的觀念。
紅皮書 Who Knew You Could Do That with RPG IV? A Sorcerer's Guide to System Access and More.
http://www.redbooks.ibm.com/abstracts/sg245402.html
章節 5.5 詳細說明如何利用 RPG 撰寫 Socket 程式。請自行下載參考。
一個非常好的 RPG socket 工具：
RPG IV Sockets Tutorial
https://www.scottklement.com/rpg/socktut/index.html
內含教育手冊及 SAVF 範例。可以將 SAVF 上傳至 AS/400，
再 restore，內含許多範例。
2003-06-10 如何動態選取要儲存的物件或原始檔成員(TFROBJ) ?
如何動態選取要儲存的物件或原始檔成員(TFROBJ) ?
有時候由於檔案或原始檔某些成員需要傳至另一個 AS/400(iSeries) 系統，
所以需要使用 SAVOBJ 的方式儲存，但是又須麻煩的一個一個輸入指定物件或原
始檔成員，所以我寫一個程式針對同一個 Library 中的物件或原始檔中
成員讓使用者選取，並將所選儲存至同一 Library SAVF 中，然後你可以
使用此 SAVF 利用 FTP 或 SNDNETF 或 SAVRSTOBJ 傳輸至另一系統中。
此程式中使用 Source-Library -> 欲儲存的 Library
Targrt-Library -> 欲 Restored 到目的地 Library，目前未使用，若需要將傳輸及自動 Restored 時，你可以利用此參數。
二個參數，並將選取的物件存至 Source-Library 中以同 Source-Library 為名的 SAVF。
File : QCLSRC
Member: TFROBJC
Type : CLP
Usage : CRTCLPGM TFROBJC
PGM (&SRCLIB &TOLIB)
DCL VAR(&SRCLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&TOLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&SAVOBJTYP) TYPE(*CHAR) LEN(10)
DCL VAR(&CURRCD) TYPE(*DEC) LEN(10 0)
DCLF QAFDBASI
/* OUTPUT OBJ DESCRIPTION TO OUTFILE */
DSPOBJD OBJ(&SRCLIB/*ALL) OBJTYPE(*ALL) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPOBJ)
/* OUTPUT FILE DESCRIPTION TO OUTFILE */
DSPFD FILE(&SRCLIB/*ALL) TYPE(*BASATR) +
OUTPUT(*OUTFILE) OUTFILE(QTEMP/DSPFD)
OVRDBF FILE(QAFDBASI) TOFILE(QTEMP/DSPFD)
DLTF DSPMBRLIST
MONMSG CPF0000
NEXT:
RCVF
MONMSG CPF0864 EXEC(GOTO MBRLISTEND)
IF (&ATDTAT = 'S') +
DSPFD FILE(&ATLIB/&ATFILE) TYPE(*MBRLIST) +
OUTPUT(*OUTFILE) +
OUTFILE(QTEMP/DSPMBRLIST) OUTMBR(*FIRST *ADD)
GOTO NEXT
MBRLISTEND:
DLTF QTEMP/SAVMBRLIST
MONMSG CPF0000
/* CREATE TEMP FILE TO SAVE SAVED MEMBER NAME AND OBJ */
CRTDUPOBJ OBJ(QAFDMBRL) FROMLIB(*LIBL) OBJTYPE(*FILE) +
TOLIB(QTEMP) NEWOBJ(SAVMBRLIST)
ADDPFM FILE(QTEMP/SAVMBRLIST) MBR(SAVMBRLIST)
/* SELECT OBJECT TO SAVED */
CALL TFROBJR
/* CONSTRUCT SAVRST COMMAND */
RTVMBRD FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD)
IF (&CURRCD > 0) +
CALL TFROBJC1 (&SRCLIB &TOLIB)
ENDPGM
File : QCLSRC
Member: TFROBJC1
Type : CLP
Usage : CRTCLPGM TFROBJC1
PGM (&SRCLIB &TOLIB)
DCL VAR(&SRCLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&TOLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&SAVOBJTYP) TYPE(*CHAR) LEN(10)
DCL VAR(&CMDSTR) TYPE(*CHAR) LEN(3000) +
VALUE('SAVOBJ OBJ(')
DCL VAR(&MLFILES) TYPE(*CHAR) LEN(10) +
VALUE(' ')
DCL VAR(&SAVFILE) TYPE(*CHAR) LEN(10)
DCL VAR(&SAVOBJS) TYPE(*CHAR) LEN(7) +
VALUE('SAVOBJ ')
DCL VAR(&OBJS) TYPE(*CHAR) LEN(4) VALUE('OBJ(')
DCL VAR(&OBJSS) TYPE(*CHAR) LEN(150)
DCL VAR(&LIBS) TYPE(*CHAR) LEN(4) VALUE('LIB(')
DCL VAR(&DEVS) TYPE(*CHAR) LEN(11) +
VALUE('DEV(*SAVF) ')
DCL VAR(&OBJTYPS) TYPE(*CHAR) LEN(14) +
VALUE('OBJTYPE(*ALL) ')
DCL VAR(&SAVFS) TYPE(*CHAR) LEN(15) VALUE('SAVF(')
DCL VAR(&FILEMBRS) TYPE(*CHAR) LEN(15) +
VALUE('FILEMBR(')
DCL VAR(&LEFT) TYPE(*CHAR) LEN(1) VALUE('(')
DCL VAR(&RIGHT) TYPE(*CHAR) LEN(2) VALUE(') ')
DCL VAR(&SLASH) TYPE(*CHAR) LEN(1) VALUE('/')
DCL VAR(&MBRS) TYPE(*CHAR) LEN(300)
DCL VAR(&WITHMBRS) TYPE(*CHAR) LEN(1)
DCLF QAFDMBRL
CHGVAR &SAVFILE &SRCLIB
DLTF &SRCLIB/&SAVFILE
MONMSG CPF0000
CRTSAVF FILE(&SRCLIB/&SAVFILE)
OVRDBF FILE(QAFDMBRL) TOFILE(QTEMP/SAVMBRLIST)
NEXT:
RCVF
MONMSG CPF0864 EXEC(GOTO MBRLISTEND)
IF (&MLFILES *NE &MLFILE) DO
/* SAVOBJ +
OBJ(FILE) LIB(SRCLIB) DEV(*SAVF) +
OBJTYPE(*FILE) SAVF(SRCLIB/SAVF) +
FILEMBR((FILE1 (MBR1 MBR2)) (FILE2 (MBR1 +
MBR2))) */
IF (&MLFILES *NE ' ' *AND +
&MLNAME *NE ' ') DO
CHGVAR &MBRS +
(&MBRS *TCAT &RIGHT *TCAT &RIGHT)
ENDDO
CHGVAR &MLFILES &MLFILE
CHGVAR &OBJSS (&OBJSS *BCAT &MLFILE)
IF (&MLNAME *NE ' ') DO
CHGVAR &MBRS +
(&MBRS *BCAT &LEFT *CAT &MLFILE *BCAT &LEFT)
CHGVAR &WITHMBRS '1'
ENDDO
ENDDO
IF (&MLNAME *NE ' ') +
CHGVAR &MBRS +
(&MBRS *BCAT &MLNAME)
GOTO NEXT
MBRLISTEND:
DLTOVR FILE(*ALL)
CHGVAR &CMDSTR +
(&SAVOBJS *CAT +
&OBJS *TCAT &OBJSS *TCAT &RIGHT *CAT +
&LIBS *TCAT &MLLIB *TCAT &RIGHT *CAT +
&DEVS *CAT +
&OBJTYPS *CAT +
&SAVFS *TCAT &SRCLIB *TCAT &SLASH *CAT +
&SAVFILE *TCAT &RIGHT)
CHGVAR &MBRS +
(&MBRS *TCAT &RIGHT *TCAT &RIGHT *TCAT &RIGHT)
IF (&WITHMBRS = '1') DO
CHGVAR &CMDSTR +
(&CMDSTR *BCAT &FILEMBRS *CAT &MBRS)
ENDDO
CALL QCMDEXC (&CMDSTR 3000)
SNDPGMMSG MSG('SAVF' *BCAT &SAVFILE *BCAT 'created in' +
*BCAT &SRCLIB *TCAT '.') TOPGMQ(*PRV +
(TFROBJC))
ENDPGM
File : QDDSSRC
Member: TFROBJD
Type : DSPF
Usage : CRTDSPF TFROBJD
*===============================================================
*
* To compile:
*
* CRTDSPF FILE(XXX/TFROBJD) SRCFILE(XXX/QDDSSRC)
*
*===============================================================
A*
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A ERRSFL
A CA03
A CA12
A*
A R SFL1 SFL
A*
A SELECT 1 B 6 2
A MLFILE 10 O 6 4
A MLNAME 10 O 6 15
A MLCDAT 6 O 6 26
A MLCHGD 6 O 6 33
A ODOBNM 10 O 6 40
A ODOBTP 8 O 6 51
A ODOBOW 10 O 6 60
A ODLDAT 6 O 6 71
A ODCDAT 6 H
A*
A*
A R SF1CTL SFLCTL(SFL1)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A SFLCSRRRN(&CSRRRN1)
A RRN1 4S 0H SFLRCDNBR
A CSRRRN1 5S 0H
A 1 2'TFROBJR '
A 1 28'Your Company name'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 29'Select Object or SRC Member to save'
A COLOR(WHT)
A 2 71TIME
A 3 1'X'
A 4 3'LIBRARY:'
A SAVLIB 10 O 4 12
A 5 4'FILE'
A COLOR(WHT)
A 5 15'MEMBER'
A COLOR(WHT)
A 4 26'CRT'
A COLOR(WHT)
A 5 26'DATE'
A COLOR(WHT)
A 3 33'LAST'
A COLOR(WHT)
A 4 33'CHANGE'
A COLOR(WHT)
A 5 33'DATE'
A COLOR(WHT)
A 5 40'OBJECT'
A COLOR(WHT)
A 5 51'TYPE'
A COLOR(WHT)
A 5 60'OWNER'
A COLOR(WHT)
A 3 71'LAST'
A COLOR(WHT)
A 4 71'CHANGED'
A COLOR(WHT)
A 5 71'DATE'
A COLOR(WHT)
A*
A R SFL2 SFL
A*
A SELECT 1 B 6 2
A ODLBNM 10 O 6 4
A ODOBNM 10 O 6 15
A ODOBTP 8 O 6 26
A ODOBAT 10 O 6 37
A ODCDAT 6 O 6 48
A ODLDAT 6 O 6 55
A ODOBOW 10 O 6 62
A R SF2CTL SFLCTL(SFL2)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A RRN2 4S 0H
A 1 2'TFROBJR '
A 1 28'Your Company name'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 34''
A COLOR(WHT)
A 2 71TIME
A 3 1'X'
A 5 4'LIBRARY'
A COLOR(WHT)
A 5 15'OBJECT '
A COLOR(WHT)
A 5 26'OBJTYPE'
A COLOR(WHT)
A 5 37'ATTR'
A COLOR(WHT)
A 4 48'CRT'
A COLOR(WHT)
A 5 48'DATE'
A COLOR(WHT)
A 4 48'CHG'
A COLOR(WHT)
A 5 55'DATE'
A COLOR(WHT)
A 5 62'OWNER'
A COLOR(WHT)
A R SFL3 SFL
A SAVOBJ 10 O 6 4
A SAVMBR 10 O 6 15
A MLCDAT 6 O 6 27
A MLCHGD 6 O 6 34
A ODOBOW 10 O 6 41
*
A R SF3CTL SFLCTL(SFL3)
A SFLSIZ(0017)
A SFLPAG(0016)
A OVERLAY
A N32 SFLDSP
A N31 SFLDSPCTL
A 31 SFLCLR
A 90 SFLEND(*MORE)
A RRN3 4S 0H
A 1 2'TFROBJR '
A 1 28'Your Company Name'
A COLOR(WHT)
A 1 71DATE
A EDTCDE(Y)
A 2 34'Confirm Selection'
A 2 71TIME
A 3 1'Please press Enter to confirm'
A 4 3'LIBRARY:'
A SAVLIB 10 O 4 12
A 5 4'OBJECT MEMBER'
A COLOR(WHT)
A 4 27'CRT'
A COLOR(WHT)
A 5 27'DATE'
A COLOR(WHT)
A 3 34'LAST'
A COLOR(WHT)
A 4 34'CHG'
A COLOR(WHT)
A 5 34'DATE'
A COLOR(WHT)
A 5 41'OWNER'
A COLOR(WHT)
A R FKEY1
A*
A 23 2'F3=Exit'
A COLOR(BLU)
A 23 12'F12=Cancel'
A COLOR(BLU)
File : QRPGLESRC
Member: TFROBJR
Type : RPGLE
Usage : CRTBNDRPG TFROBJR
*===============================================================
*
* To compile:
*
* CRTBNDRPG PGM(XXX/TFROBJR) SRCFILE(XXX/QRPGLESRC)
*
*===============================================================
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO)
H DftActGrp(*NO) ActGrp(*CALLER)
FTFROBJD cf e workstn
F sfile(sfl1:rrn1)
F sfile(sfl2:rrn2)
F sfile(sfl3:rrn3)
F infds(info)
FDSPOBJ if e disk
FDSPMBRLISTif e disk
FSAVMBRLISTO e disk rename(QWHFDML : SAVMBRR)
* Information data structure to hold attention indicator (AID) byte.
* AID byte contains a code identifying the function
* key used to return control to the program from the display file.
* For more information see the DATA MANAGEMENT GUIDE.
Dinfo ds
D cfkey 369 369
* Constants to compare to AID - F3, F12, F6, and ENTER keys.
* Other values documented in DATA MANAGEMENT GUIDE.
Dexit C const(X'33')
Dcancel C const(X'3C')
Dadd C const(X'36')
Denter C const(X'F1')
* Input parameter: Source Type or not
D savrrn S 5S 0
D confirm S 1
* Clear the subfile, then call the recursive NextLevel procedure
C ExSr clrsfl
C Exsr loadsfl
C Eval *In90 = *on
C If rrn1 = 0
C Eval *in32 = *on
C EndIf
C* Eval csrrrn1 = 1
* Simply redisplay subfile until user hits Exit or Cancel
C DoU (cfkey = exit) or (cfkey = cancel)
C Write fkey1
C ExFmt sf1ctl
C Exsr prcsfl
C If confirm = '1'
C leave
C EndIf
C EndDo
* Close files and terminate.
C Eval *inlr = *on
*********************************************************************
C ClrSfl BegSr
* Clear the subfile by activating SFLCLR and writing the subfile control
* format. Reset the subfile relative record number.
C Eval *in31 = *on
C Eval rrn1 = 0
C Write sf1ctl
C Eval *in31 = *off
*
C EndSr
*********************************************************************
C Loadsfl Begsr
* Loop until EOF is encountered.
* read DSPMBRLIST
C Read DSPMBRLIST
C DoW not %eof
C Eval select = ' '
* Update the global RRN counter, and write the new subfile record.
C Eval rrn1 = rrn1 + 1
C Write sfl1
C Read DSPMBRLIST
C EndDo
C Eval SAVLIB = MLLIB
* read DSPOBJ
C Reset SFL1
C Read DSPOBJ
C DoW not %eof
C Eval select = ' '
* Update the global RRN counter, and write the new subfile record.
C Eval rrn1 = rrn1 + 1
C Write sfl1
C Read DSPOBJ
C EndDo
C Eval savrrn = rrn1
C Eval rrn1 = 1
C EndSr
*********************************************************************
C PrcSfl Begsr
* clear sfl3
C Eval *in31 = *on
C Eval rrn3 = 0
c Write sf3ctl
C Eval *in31 = *off
C z-add 1 idx 5 0
C Eval confirm = '0'
C DoW idx < savrrn
C idx Chain sfl1
C If select = 'X'
C If MLFILE <> *blanks
C Eval SavLIB = SAVLIB
C Eval SavOBJ = MLFILE
C Eval SavMBR = MLNAME
C Else
C Eval SavLIB = SAVLIB
C Eval SavOBJ = ODOBNM
C Eval SavMBR = *BLANKS
C Eval MLCDAT = ODCDAT
C Eval MLCHGD = ODLDAT
C EndIf
C Z-add idx strrrn 4 0
C Eval rrn3 = rrn3 + 1
C Write sfl3
C Eval select = ' '
C update sfl1
C EndIf
C Eval idx = idx + 1
C EndDo
C
C If rrn3 > 0
C z-add rrn3 savrrn3 4 0
C Write fkey1
C ExFmt sf3ctl
C If (cfkey <> exit) and (cfkey <> cancel)
C Eval confirm = '1'
C Eval idx = 1
C Reset SAVMBRR
C DoW idx <= savrrn3
C idx Chain sfl3
C Eval MLLIB = SAVLIB
C Eval MLFILE= SAVOBJ
C EVAL MLNAME= SAVMBR
C EVAL MLSEU2= ODOBOW
C Write SAVMBRR
C Eval idx = idx + 1
C EndDo
C EndIf
C EndIf
C If strrrn > 0
C Z-add strrrn rrn1
C Else
C Z-add csrrrn1 rrn1
C EndIf
C EndSr
由於此程式利用 QTEMP 暫存檔處理，所以安裝程序須照下列方式，否則無法編譯完成：
1. 將 TFROBJC 程式後段修改如下：
/* SELECT OBJECT TO SAVED */
/* CALL TFROBJR */
/* CONSTRUCT SAVRST COMMAND */
/* RTVMBRD FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD) */
/* IF (&CURRCD > 0) + */
/* CALL TFROBJC1 (&SRCLIB &TOLIB) */
儲存，執行編譯 CRTCLPGM TFROBJC完成後，
執行 CALL TFROBJC ('QGPL' 'QGPL' '*ALL')產生暫存檔 QTEMP/SAVMBRLIST 供 TFROBJR 使用。
2. CRTDSPF TFROBJD
3. CRTBNDRPG TFROBJR
4. CRTCLPGM TFROBJC1
5. 回復 TFROBJC 後段為：
/* SELECT OBJECT TO SAVED */
CALL TFROBJR
/* CONSTRUCT SAVRST COMMAND */
RTVMBRD FILE(QTEMP/SAVMBRLIST) NBRCURRCD(&CURRCD)
IF (&CURRCD > 0) +
CALL TFROBJC1 (&SRCLIB &TOLIB)
儲存，執行編譯 CRTCLPGM TFROBJC 完成安裝。
執行程式語法：
CALL TFROBJC ('source-library' 'target-library')
2003-05-30 如何取得系統現在有幾個線上使用者(Users currently signed on)？
如何取得系統現在有幾個線上使用者(Users currently signed on)？
可以利用 System API QWCRSSTS 取得系統現有狀態，此 API 包含的資訊與 DSPSYSSTS
指令所顯示的資訊是類似的，更包括記憶體區塊的使用情形。
詳細請參考 :
Retrieve System Status (QWCRSSTS) API
http://publib.boulder.ibm.com/iseries/v5r2/ic2924/info/apis/qwcrssts.htm
File : QCLSRC
Member: RTVSIGNONC
Type : CLP
Usage : CRTCLPGM RTVSIGNONC
CALL RTVSIGNONC
/* Program : RTVSIGNONC */
/* System : iSeries */
/* */
/* Description : retrieve the number of users signed on */
/* */
PGM
DCL VAR(&SIGNON) TYPE(*DEC) LEN(9 0)
DCL VAR(&SIGNON_CHR) TYPE(*CHAR) LEN(9)
DCL VAR(&RECEIVER) TYPE(*CHAR) LEN(100)
DCL VAR(&RCV_LEN) TYPE(*CHAR) LEN(4)
DCL var(&RESET) TYPE(*CHAR) LEN(10)
CHGVAR VAR(%BIN(&RCV_LEN)) VALUE(100)
CHGVAR VAR(&RESET) VALUE('*NO')
CALL PGM(QWCRSSTS) PARM(&RECEIVER &RCV_LEN +
'SSTS0100' &RESET X'00000000')
CHGVAR VAR(&SIGNON) VALUE(%BIN(&RECEIVER 25 4))
CHGVAR VAR(&SIGNON_CHR) VALUE(&SIGNON)
SNDPGMMSG MSG('The number of users signed on = ' *CAT +
&SIGNON_CHR)
END: ENDPGM
2003-05-14 如何跨 AS/400 系統間快速即時傳送原始檔成員(source member)？(SNDSRC)
2003-05-14 如何跨 AS/400 系統間快速即時傳送原始檔成員(source member)？(SNDSRC)
由於一般公司有可能將開發測試與應用軟體正式運行的環境分成不同的機器，所以時常
會有傳送程式或畫面原始檔需求，一般若是要傳送的原始檔成員很多時均是使用磁帶，Send
Network File(SNA網路) 或 FTP(TCP/IP網路)方式，但是若要傳送的原始檔成員不多時，
可考慮使用 DDMF 方式，DDMF 支援 SNA(適合所有 OS/400 版本) 及 TCP/IP網路(適合
所有 OS/400 V4R4 以後版本) 。 您可依自己系統的需求設定採用哪一種方式。在此範例
採用 TCP/IP 網路。
File : QCLSRC
Member: SNDSRCD
Type : DSPF
Usage : CRTDSPF SNDSRCD
A DSPSIZ(24 80 *DS3)
A PRINT
A R SNDFMT
A CF03(03 'EXIT')
A CF12(12 'CANCEL')
A OVERLAY
A 1 32'Send Source Member'
A DSPATR(HI)
A 3 2'From File . . . . . . . :'
A FRMFIL 10A O 3 30
A 4 4'From Library. . . . . :'
A FRMLIB 10A O 4 32
A 7 2'Type the file name, library, and s-
A ystem to receive the source member.'
A COLOR(BLU)
A 9 4'To File . . . . . . . :'
A TOFIL 10A B 9 30
A 50 DSPATR(PC)
A 50 DSPATR(RI)
A 10 6'To Library . . . . :'
A TOLIB 10A B 10 32
A 51 DSPATR(RI)
A 51 DSPATR(PC)
A 5 8'From System . . . :'
A TOSYS 8A B 11 34
A 52 DSPATR(RI)
A 52 DSPATR(PC)
A 13 2'To rename copied member, type New -
A Name, press Enter.'
A COLOR(BLU)
A 15 2'Member'
A DSPATR(HI)
A 15 17'New Name'
A DSPATR(HI)
A FRMMBR 10A O 16 2
A TOMBR 10A B 16 17
A 53 DSPATR(RI)
A 53 DSPATR(PC)
A 11 8'To System . . . . :'
A FRMSYS 8A O 5 34
A R MSGSFL SFL
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
A PGMQ SFLPGMQ(10)
A*/
A R MSGCTL SFLCTL(MSGSFL)
A OVERLAY
A SFLSIZ(0050)
A SFLPAG(0001)
A SFLDSP
A SFLDSPCTL
A SFLINZ
A N99 SFLEND
A PGMQ SFLPGMQ(10)
A 23 2'F3=Exit'
A COLOR(BLU)
A 23 11'F12=Cancel'
A COLOR(BLU)
File : QCLSRC
Member: SNDSRCC
Type : CLP
Usage :
1. 修改此程式參數 SYSTEM1 及 SYSTEM2 為 AS/400 的系統名稱(SNA device remote location)
或 IP 主機名稱或 IP 位址。此範例是使用 IP IP 主機名稱(定義於 CFGTCP 選項 10 中)
2. CRTCLPGM SNDSRCC
3. STRPDM 選 9 --> 執行鍵 --> 執行鍵 --> 按 F6 --> 指定
Option : SS
Command : CALL SNDSRCC (&F &L &N) --> 執行鍵儲存。
即可於 PDM 中直接於選項處輸入 SS 集會出現以下畫面：
Send Source Member
From File . . . . . . . : QDDSSRC
From Library. . . . . : VENGOAL
From System . . . : SYSTEM1
Type the file name, library, and system to receive the source member.
To File . . . . . . . : QDDSSRC
To Library . . . . : VENGOAL
To System . . . . : SYSTEM2
To rename copied member, type New Name, press Enter.
Member New Name
GETDSPX GETDSPX
F3=Exit F12=Cancel
程式原始碼如下，記得要更改原始及目的主機名稱。
/*------------------------------------------------------------------*/
/* PROGRAM NAME: SNDSRCC */
/* DATE WRITTEN: 05/14/2003 */
/* FUNCTION....: THIS IS USED TO SEND A SOURCE FILE FROM A */
/* SOURCE SYSTEM TO A TARGET SYSEM */
/* */
/* NOTE........: THIS IS CALLED FROM PDM USER OPTION. */
/* EX: CALL PGM(QGPL/SNDSRC) PARM(&F &L &N) */
/* THE TARGET SOURCE FILE MUST HAVE QUSER *AUTHORITY */
/*------------------------------------------------------------------*/
PGM PARM(&FRMFIL &FRMLIB &FRMMBR)
DCLF FILE(SNDSRCD) RCDFMT(*ALL)
/*------------------------------------------------------------------*/
/* DEFINE ERROR VARIABLES */
/*------------------------------------------------------------------*/
DCL VAR(&ERRORSW) TYPE(*LGL)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(7)
DCL VAR(&MSGDTA) TYPE(*CHAR) LEN(100)
DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGFLIB) TYPE(*CHAR) LEN(10)
/* Variables needed to determine program name */
DCL VAR(&MSGKEY) TYPE(*CHAR) LEN(4)
DCL VAR(&SENDER) TYPE(*CHAR) LEN(80)
/*------------------------------------------------------------------*/
/* DEFINE AS400 SYSTEM NAMES VARIABLES (PUT YOUR AS400 SYSTEM NAMES HERE)*/
/*------------------------------------------------------------------*/
DCL VAR(&SYSNM1) TYPE(*CHAR) LEN(8) +
VALUE('SYSTEM1')
DCL VAR(&SYSNM2) TYPE(*CHAR) LEN(8) +
VALUE('SYSTEM2')
/*------------------------------------------------------------------*/
/* GLOBAL MESSAGE MONITOR TO TRAP ANY UNMONITORED ERRORS */
/*------------------------------------------------------------------*/
MONMSG (CPF9999 CPF0000 MCH0000) EXEC(GOTO ERROR)
/*------------------------------------------------------------------*/
/* SET DEFAULT VALUES */
/*------------------------------------------------------------------*/
CHGVAR VAR(&TOFIL) VALUE(&FRMFIL)
CHGVAR VAR(&TOLIB) VALUE(&FRMLIB)
CHGVAR VAR(&TOMBR) VALUE(&FRMMBR)
RTVNETA SYSNAME(&FRMSYS)
IF COND(&FRMSYS *EQ &SYSNM1) THEN(CHGVAR +
VAR(&TOSYS) VALUE(&SYSNM2))
IF COND(&FRMSYS *EQ &SYSNM2) THEN(CHGVAR +
VAR(&TOSYS) VALUE(&SYSNM1))
/*------------------------------------------------------------------*/
/* BEGIN PROGRAM LOGIC */
/*------------------------------------------------------------------*/
/* Determine the name of the program */
SNDPGMMSG MSG('Dummy message') TOPGMQ(*SAME) +
MSGTYPE(*INFO) KEYVAR(&MSGKEY)
RCVMSG PGMQ(*SAME) MSGTYPE(*INFO) MSGKEY(&MSGKEY) +
RMV(*YES) SENDER(&SENDER)
CHGVAR VAR(&PGMQ) VALUE(%SST(&SENDER 27 10))
/* CHGVAR VAR(&PGMQ) VALUE('SNDSRCC') */
RMVMSG PGMQ(*SAME (&PGMQ)) CLEAR(*ALL)
LOOP: SNDF RCDFMT(MSGCTL)
SNDRCVF RCDFMT(SNDFMT)
RMVMSG PGMQ(*SAME (&PGMQ)) CLEAR(*ALL)
IF COND((&IN03 *EQ '1') *OR (&IN12 *EQ '1')) +
THEN(GOTO CMDLBL(ENDPGM))
/*------------------------------------------------------------------*/
/* CREATE DDMF TO REMOTE SYSTEM */
/*------------------------------------------------------------------*/
CRTDDMF FILE(QTEMP/DDMF) RMTFILE(&TOLIB/&TOFIL) +
RMTLOCNAME(&TOSYS *IP)
/*------------------------------------------------------------------*/
/* COPY SOURCE MEMBER TO DDMF */
/*------------------------------------------------------------------*/
CPYF FROMFILE(&FRMLIB/&FRMFIL) TOFILE(QTEMP/DDMF) +
FROMMBR(&FRMMBR) TOMBR(&TOMBR) +
MBROPT(*REPLACE) FMTOPT(*NOCHK)
/*------------------------------------------------------------------*/
/* DELETE THE TEMPORARY DDMFILE */
/*------------------------------------------------------------------*/
DLTF FILE(QTEMP/DDMF)
GOTO CMDLBL(ENDPGM)
/*-------------------------------------------------------------------*/
/* GLOBAL ERROR HANDLING ROUTINE */
/*-------------------------------------------------------------------*/
ERROR:
STDERR1:
IF COND(&ERRORSW) THEN(SNDPGMMSG MSGID(CPF9999) +
MSGF(QCPFMSG) MSGTYPE(*ESCAPE))
CHGVAR VAR(&ERRORSW) VALUE('1')
STDERR2: RCVMSG MSGTYPE(*DIAG) MSGDTA(&MSGDTA) MSGID(&MSGID) +
MSGF(&MSGF) MSGFLIB(&MSGFLIB)
IF COND(&MSGID *EQ ' ') THEN(GOTO +
CMDLBL(STDERR3))
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*DIAG)
GOTO CMDLBL(LOOP)
STDERR3: RCVMSG MSGTYPE(*EXCP) MSGDTA(&MSGDTA) MSGID(&MSGID) +
MSGF(&MSGF) MSGFLIB(&MSGFLIB)
SNDPGMMSG MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
GOTO CMDLBL(LOOP)
/*-------------------------------------------------------------------*/
/* END PROGRAM */
/*-------------------------------------------------------------------*/
ENDPGM: RETURN
ENDPGM
2003-03-25 如何讓系統操作人員將使用者設定為可以進入系統？(Command EBLUSRPRF Enabled User Profile)
如何讓系統操作人員將使用者設定為可以進入系統？(Command EBLUSRPRF Enabled User Profile)
當使用者的 SignOn 錯誤次數超過系統值 QMAXSIGN 的設定值時，若另一系統值
QMAXSGNACN設為 2 或 3 時，此時系統會將使用者狀態設為失效(disabled)。所已有需要讓系統操
作人員能將該失效使用者重新設定為有效，該使用者才可以進入系統。
但在開發此工具時，需要注意不得讓系統操作人員將具有 *ALLOBJ, *SECADM, *SERVICE
高級權限的人員，執行啟用（enabled）使用者的動作。
此程式需以 QSECOFR 使用者產生，並指定繼承程式擁有者的權限，系統操作人員執行此
程式時，才能間接取得 QSECOFR 的權限，更改使用者狀態，同時亦排除更改具有高級權
限的使用者。
這裡也提供 Command EBLUSRPRF 使系統操作人員便於使用。
File : QCLSRC
Member: EBLUSRPRF
Type : CLP
Usage : 此程式需以 QSECOFR 使用者產生
CRTCLPGM EBLUSRPRF USRPRF(*OWNER)
/* Program : EBLUSRPRF */
/* Version : 1.00 */
/* System : iSeries */
/* */
/* Compile the program with user QSECOFR */
/* and adopt authority : */
/* CHGPGM PGM(EBLUSRPRF) USRPRF(*OWNER) */
RSETUSRPRF: PGM PARM(&USRPRF &PASSWORD &PWDEXP &STATUS)
DCL VAR(&USRPRF) TYPE(*CHAR) LEN(10)
DCL VAR(&PASSWORD) TYPE(*CHAR) LEN(10)
DCL VAR(&PWDEXP) TYPE(*CHAR) LEN(10)
DCL VAR(&STATUS) TYPE(*CHAR) LEN(10)
DCL VAR(&CURUSER) TYPE(*CHAR) LEN(10)
DCL VAR(&GRPPRF) TYPE(*CHAR) LEN(10)
DCL VAR(&SPCAUT) TYPE(*CHAR) LEN(100)
DCL VAR(&ALLOBJ) TYPE(*LGL)
/* Parameters for QCLSCAN */
DCL VAR(&STRINGLEN) TYPE(*DEC) LEN(3 0) VALUE(100)
DCL VAR(&STRPOS) TYPE(*DEC) LEN(3 0) VALUE(1)
DCL VAR(&PATTERN) TYPE(*CHAR) LEN(10)
DCL VAR(&PATTERNLEN) TYPE(*DEC) LEN(3 0) VALUE(10)
DCL VAR(&TRANSLATE) TYPE(*CHAR) LEN(1) VALUE('1')
DCL VAR(&TRIM) TYPE(*CHAR) LEN(1) VALUE('1')
DCL VAR(&WILD) TYPE(*CHAR) LEN(1) VALUE(' ')
DCL VAR(&RESULT) TYPE(*DEC) LEN(3 0)
/* Check userprofile existence */
CHKOBJ OBJ(QSYS/&USRPRF) OBJTYPE(*USRPRF)
MONMSG MSGID(CPF0000) EXEC(DO)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('***** +
Error ****** invalid userprofile') +
TOPGMQ(*PRV) MSGTYPE(*ESCAPE)
ENDDO
/* new password same as userprofile */
IF COND(&PASSWORD *EQ *USRPRF) THEN(CHGVAR +
VAR(&PASSWORD) VALUE(&USRPRF))
/* retrieve current user */
RTVJOBA USER(&CURUSER)
/* Retrieve userprofile attributes */
RTVUSRPRF USRPRF(&USRPRF) SPCAUT(&SPCAUT) GRPPRF(&GRPPRF)
/* Check if the userprofile to be changed has */
/* *ALLOBJ authority. */
CHGVAR VAR(&PATTERN) VALUE('*ALLOBJ')
CALL PGM(QCLSCAN) PARM(&SPCAUT &STRINGLEN &STRPOS +
&PATTERN &PATTERNLEN &TRANSLATE &TRIM +
&WILD &RESULT)
/* String *ALLOBJ was found */
IF COND(&RESULT *NE 0) THEN(CHGVAR VAR(&ALLOBJ) +
VALUE('1'))
/* Do not allow to let userprofile QSECOFR, QSRV or */
/* any userprofile with *ALLOBJ authority or group */
/* profile QSECOFR to be changed. */
/* */
IF COND(&USRPRF = QSECOFR *OR &USRPRF = QSRV +
*OR &ALLOBJ *OR &GRPPRF *EQ QSECOFR) THEN(DO)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('*** +
Error *** not authorised to change this +
user profile') TOPGMQ(*PRV) MSGTYPE(*ESCAPE)
ENDDO
/* Before resetting the userprofile, let the current */
/* user authenticate by typing his own password. */
/* This prevents changing a userprofile on a terminal */
/* where the normal user went for dinner. */
?CHKPWD
MONMSG MSGID(CPF0000) EXEC(RETURN)
/* Change userprofile */
CHGUSRPRF USRPRF(&USRPRF) PASSWORD(&PASSWORD) +
PWDEXP(&PWDEXP) STATUS(&STATUS)
MONMSG MSGID(CPF0000) EXEC(DO)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('*** +
Error occurred *** see joblog') +
TOPGMQ(*PRV) MSGTYPE(*ESCAPE)
ENDDO
/* Log the changes into the History log */
SNDPGMMSG MSG('Userprofile ' *CAT &USRPRF *TCAT ' +
reset by user ' *CAT &CURUSER) TOMSGQ(QHST)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) +
MSGDTA('Userprofile ' *CAT &USRPRF *BCAT +
'reset') TOPGMQ(*PRV) MSGTYPE(*COMP)
END: ENDPGM
File : QCMDSRC
Member: RSETUSRPRF
Type : CMD
Usage : CRTCMD CMD(your-lib/EBLUSRPRF) PGM(your-lib/EBLUSRPRF)
/* Command : EBLUSRPRF */
/* Version : 1.00 */
/* System : iSeries */
/* Description : Enable userprofile and password */
RSETUSRPRF: CMD PROMPT('Enable userprofile and password')
PARM KWD(USRPRF) TYPE(*NAME) LEN(10) MIN(1) +
PROMPT('User profile')
PARM KWD(PASSWORD) TYPE(*CHAR) LEN(10) +
DFT(*USRPRF) SPCVAL((*USRPRF) (*SAME)) +
DSPINPUT(*PROMPT) PROMPT('User password')
PARM KWD(PWDEXP) TYPE(*CHAR) LEN(10) RSTD(*YES) +
DFT(*YES) VALUES(*SAME *NO *YES) +
PROMPT('Set password to expired')
PARM KWD(STATUS) TYPE(*CHAR) LEN(10) RSTD(*YES) +
DFT(*ENABLED) VALUES(*ENABLED *DISABLED +
*SAME) PROMPT('Status')
2003-03-12 如何於 CL 中轉換字串中每個英文單字的第一個字為大寫？
如何於 CL 中轉換字串中每個英文單字的第一個字為大寫？
File : QCLSRC
Member: CVTCASEC
Type : CLP
Usage : CRTCLPGM CVTCASEC
CALL CVTCASEC 'AS/400 IS VERY GOOD.'
pgm (&CvtText) /* Convert this text */
/*--------------------------------------------------------*/
/* declaration */
/*--------------------------------------------------------*/
dcl &CvtText *char 80
dcl &ReqUpper *char 22
dcl &ReqLower *char 22
dcl &Pos *dec 3 1
dcl &Posl *dec 3 0
dcl &Len *dec 3 0
dcl &upper *lgl
dcl &CCSIDReq *char 4 x'00000001'
dcl &CCSIDInp *char 4 x'00000000'
dcl &Uppercase *char 4 x'00000000'
dcl &Lowercase *char 4 x'00000001'
dcl &Reserved *char 10 x'00000000000000000000'
/*----------------------------------------------*/
/* QLGCNVCS - Convert Case QlgConvertCase */
/*----------------------------------------------*/
dcl &Input *char 80
dcl &Output *char 80
dcl &DataLen *char 4 x'00000050'
dcl &ErrCde *char 4 x'00000000'
/*--------------------------------------------------------*/
/* Setup Request Control Block */
/*--------------------------------------------------------*/
chgvar &ReqUpper (&CCSIDReq || +
&CCSIDInp || +
&Uppercase || +
&Reserved)
chgvar &ReqLower (&CCSIDReq || +
&CCSIDInp || +
&Lowercase || +
&Reserved)
chgvar &upper '1'
/*--------------------------------------------------------*/
/* Convert Upper (First letter), then lower case */
/*--------------------------------------------------------*/
loop:
if (&Pos *ge 80) goto endloop
/*----------------------------------------------*/
/* Convert to Lower */
/*----------------------------------------------*/
if (%sst(&CvtText &Pos 1) = ' ') do
if (*Not &Upper) do
chgvar &output ' '
chgvar %bin(&Datalen) &len
Call Pgm(QLGCNVCS) +
parm(&Reqlower +
&input +
&output +
&Datalen +
&ErrCde )
chgvar %sst(&CvtText &Posl &len) &Output
enddo
chgvar &upper '1'
chgvar &Pos (&Pos + 1)
enddo
/*----------------------------------------------*/
/* Convert to Upper */
/*----------------------------------------------*/
if (%sst(&CvtText &Pos 1) *ne ' ') do
if &upper do
chgvar &input %sst(&CvtText &Pos 1)
chgvar &output ' '
chgvar %bin(&Datalen) 1
Call Pgm(QLGCNVCS) +
parm(&ReqUpper +
&input +
&output +
&Datalen +
&ErrCde )
chgvar %sst(&CvtText &Pos 1) %sst(&Output 1 1)
chgvar &Pos (&Pos + 1)
chgvar &Posl &Pos
chgvar &upper '0'
chgvar &len 0
enddo
else do
chgvar &len (&len + 1)
chgvar %sst(&input &len 1) %sst(&CvtText &Pos 1)
chgvar &Pos (&Pos + 1)
enddo
enddo
goto loop
endloop:
SndPgmMsg Msg(&Cvttext) Msgtype(*Comp)
EndPgm
2003-02-19 如何於 CLP 中傳送著色的訊息？(Send colored message in CLP)
如何於 CLP 中傳送著色的訊息？(Send colored message in CLP)
File : QCLSRC
Member: SNDCOLMSGC
Type : CLP
Usage : CRTCLPGM SNDCOLMSGC
OS Version: All
/* TO COMPILE : */
/* */
/* CRTCLPGM PGM(XXX/SNDCOLMSG) SRCFILE(XXX/QCLSRC) */
SNDCOLMSG: PGM PARM(&MSG &COLOR &MSGTYPE)
DCL VAR(&MSG) TYPE(*CHAR) LEN(80)
DCL VAR(&COLOR) TYPE(*CHAR) LEN(1)
DCL VAR(&MSGTYPE) TYPE(*CHAR) LEN(10)
DCL VAR(&LASTBYTE) TYPE(*CHAR) LEN(1) VALUE(X'20')
DCL VAR(&TEXT) TYPE(*CHAR) LEN(82)
CHGVAR VAR(&TEXT) VALUE(&COLOR *CAT &MSG *TCAT +
&LASTBYTE)
SNDPGMMSG MSG(&TEXT) TOPGMQ(*EXT) MSGTYPE(&MSGTYPE)
SNDPGMMSG MSG(&TEXT) MSGTYPE(&MSGTYPE)
END: ENDPGM
此程式中有二個 SNDPGMMSG 指令，你可以選取一種顯示方式或二者。
二者顯示方式稍有不同，可以自行比較一下。
File : QCMDSRC
Member: SNDCOLMSG
Type : CMD
Usage : CRTCMD CMD(SNDCOLMSG) PGM(SNDCOLMSGC)
OS Version: All
/* Description : Send a colored message */
/* */
/* To compile : */
/* */
/* CRTCMD CMD(XXX/SNDCOLMSG) PGM(XXX/SNDCOLMSG) + */
/* SRCFILE(XXX/QCMDSRC) */
/* */
SNDCOLMSG: CMD PROMPT('Send colored message')
PARM KWD(MSG) TYPE(*CHAR) LEN(80) PROMPT('Message')
PARM KWD(COLOR) TYPE(*CHAR) LEN(1) RSTD(*YES) +
DFT(*GREEN) SPCVAL( +
(*GREEN X'20') +
(*GREEN_REVERSE X'21') +
(*WHITE X'22') +
(*WHITE_REVERSE X'23') +
(*GREEN_UNDERSCORE X'24') +
(*GREEN_UNDERSCORE_REVERSE X'25') +
(*WHITE_UNDERSCORE X'26') +
(*RED X'28') +
(*RED_REVERSE X'29') +
(*RED_BLINK X'2A') +
(*RED_REVERSE_BLINK X'2B') +
(*RED_UNDERSCORE X'2C') +
(*RED_UNDERSCORE_REVERSE X'2D') +
(*RED_UNDERSCORE_BLINK X'2E') +
(*TURQUOISE X'30') +
(*TURQUOISE_REVERSE X'31') +
(*YELLOW X'32') +
(*YELLOW_REVERSE X'33') +
(*TURQUOISE_UNDERSCORE X'34') +
(*TURQUOISE_UNDERSCORE_REVERSE X'35') +
(*YELLOW_UNDERSCORE X'36') +
(*PINK X'38') +
(*PINK_REVERSE X'39') +
(*BLUE X'3A') +
(*BLUE_REVERSE X'3B') +
(*PINK_UNDERSCORE X'3C') +
(*PINK_UNDERSCORE_REVERSE X'3D') +
(*BLUE_UNDERSCORE X'3E') +
) PROMPT('Color')
PARM KWD(MSGTYPE) TYPE(*CHAR) LEN(10) RSTD(*YES) +
DFT(*INFO) VALUES(*INFO *COMP) +
PROMPT('Message type')
執行範例：
SNDCOLMSG MSG('Hello World') COLOR(*PINK)
SNDCOLMSG MSG('Error') COLOR(*RED_REVERSE_BLINK)
訂閱：
文章 (Atom)