Refer to shipped RPG source file QRPGLRSRC and CRTDEMO program source in QCLSRC source file.
This example requires an adjustment to the code and for server, user, password, folder and file values to be supplied.
H OPTION(*SRCSTMT : *NODEBUGIO) DFTACTGRP(*NO) ACTGRP(*CALLER)
H BNDDIR('JSMBNDDIR')
*
D JSMHDL S 4A INZ(*BLANKS)
D JSMSRV S 50A INZ(*BLANKS)
D JSMSTS S 20A INZ(*BLANKS)
D JSMMSG S 512A INZ(*BLANKS)
D JSMCMD S 512A INZ(*BLANKS)
D ZEROLENGTH S 10I 0 INZ(0)
*
* JSMX_BEGIN
*
C CALLB(D) 'JSMX_BEGIN'
C PARM *OMIT
C PARM ZEROLENGTH
*
* JSMX_OPEN - USE JSMCLTDTA FOR SERVER
*
C CLEAR JSMSRV
C EVAL JSMSRV = ''
C CALLB(D) 'JSMX_OPEN'
C PARM JSMHDL
C PARM JSMSRV
C PARM JSMSTS
C PARM JSMMSG
C CALLP checkSTS(JSMSTS:JSMMSG)
*
* SERVICE_LOAD
*
C CLEAR JSMCMD
C EVAL JSMCMD = 'SERVICE_LOAD' +
C ' SERVICE(FTPService)' +
C ' TRACE(*YES)'
C CALLB(D) 'JSMX_COMMAND'
C PARM JSMHDL
C PARM JSMCMD
C PARM JSMSTS
C PARM JSMMSG
C CALLP checkSTS(JSMSTS:JSMMSG)
*
* CONNECT HOST
*
C CLEAR JSMCMD
C EVAL JSMCMD = 'CONNECT' +
C ' HOST(LANSA01)'
C CALLB(D) 'JSMX_COMMAND'
C PARM JSMHDL
C PARM JSMCMD
C PARM JSMSTS
C PARM JSMMSG
C CALLP checkSTS(JSMSTS:JSMMSG)
*
* LOGIN
*
C CLEAR JSMCMD
C EVAL JSMCMD = 'LOGIN' +
C ' USER(NAME)' +
C ' PASSWORD(XXXX)'
C CALLB(D) 'JSMX_COMMAND'
C PARM JSMHDL
C PARM JSMCMD
C PARM JSMSTS
C PARM JSMMSG
C CALLP checkSTS(JSMSTS:JSMMSG)
*
* PUT
*
C CLEAR JSMCMD
C EVAL JSMCMD = 'PUT' +
C ' FROM(PATH1)' +
C ' TO(PATH2)'
C CALLB(D) 'JSMX_COMMAND'
C PARM JSMHDL
C PARM JSMCMD
C PARM JSMSTS
C PARM JSMMSG
C CALLP checkSTS(JSMSTS:JSMMSG)
*
* QUIT
*
C CLEAR JSMCMD
C EVAL JSMCMD = 'QUIT'
C CALLB(D) 'JSMX_COMMAND'
C PARM JSMHDL
C PARM JSMCMD
C PARM JSMSTS
C PARM JSMMSG
C CALLP checkSTS(JSMSTS:JSMMSG)
*
* SERVICE_UNLOAD
*
C CLEAR JSMCMD
C EVAL JSMCMD = 'SERVICE_UNLOAD'
C CALLB(D) 'JSMX_COMMAND'
C PARM JSMHDL
C PARM JSMCMD
C PARM JSMSTS
C PARM JSMMSG
C CALLP checkSTS(JSMSTS:JSMMSG)
*
* JSMX_CLOSE
*
C CALLB(D) 'JSMX_CLOSE'
C PARM JSMHDL
C PARM JSMSTS
C PARM JSMMSG
C CALLP checkSTS(JSMSTS:JSMMSG)
*
* JSMX_END
*
C CALLB(D) 'JSMX_END'
*
C SETON LR
********************************
* Procedure to check JSM status
********************************
P checkSTS B
D checkSTS PI N
D csJSMSTS CONST LIKE(JSMSTS)
D csJSMMSG CONST LIKE(JSMMSG)
D csMSGTXT S 512A
C IF csJSMSTS <> 'OK'
C EVAL csMSGTXT = %TRIM(csJSMSTS) + ' ' +
C %TRIM(csJSMMSG)
C CALLP sendMSG(csMSGTXT)
C RETURN *OFF
C ENDIF
C RETURN *ON
P E
**************************************
* Procedure to send a program message
**************************************
P sendMSG B
D sendMSG PI
D smMSGTXT 512A VALUE
D smMSGT S 10A INZ('*DIAG')
D smMSGI S 7A INZ('CPF9897')
D smMSGF S 20A INZ('QCPFMSG *LIBL ')
D smMSGL S 10I 0 INZ(%SIZE(smMSGTXT))
D smSTKE S 10A INZ('*')
D smSTKC S 10I 0 INZ(1)
D smMSGK S 4A INZ(*BLANK)
D smERRC S 10I 0 INZ(0)
C CALL 'QMHSNDPM'
C PARM smMSGI
C PARM smMSGF
C PARM smMSGTXT
C PARM smMSGL
C PARM smMSGT
C PARM smSTKE
C PARM smSTKC
C PARM smMSGK
C PARM smERRC
P E
