PHP-Code:
* ************************************************************************
* Service - PGM erstellen mit:
* CRTRPGMOD MODULE(DIPSRVPGM/#USRSPAPI) SRCFILE(DIPSRVPGM/QRPGLESRC)
* CRTSRVPGM SRVPGM(DIPSRVPGM/#USRSPAPI) EXPORT(*ALL)
* ************************************************************************
*
**************************************************************************
*
* Program Name: FunctUsp
* Program Title: User Space Function Procedures
* Author:
* Origin Date: 1/23/1998
* Revisions:
*
**************************************************************************
H NOMAIN
* Prototype Lists
D/COPY dipsrvpgm/QRPGLESRC,FUSPCp
* Generic Error Structure
D/COPY dipsrvpgm/QRPGLESRC,QUSEC
* User Space Generic Structure
D/COPY dipsrvpgm/QRPGLESRC,QUSGEN
D DS_Error DS
D Bytpv 1 4b 0 inz(100)
D Bytav 5 8b 0 inz(0)
D MSgid 9 15
D Resvd 16 16
D Exdta 17 256
D Exdta52 17 67
**************************************************************************
*
* Procedure Name: CrtUsrSpc
*
**************************************************************************
P CrtUsrSpc B EXPORT
D CrtUsrSpc PI 1A
D UsrSpcName 20A VALUE
D UsrSpcExtA 10A VALUE
D UsrSpcText 50A VALUE
* Local Variables
* User Space API Fields
D SpaceName S 20A
D SpaceSize S 9B 0 INZ(8388608)
D SpaceInit S 1A INZ(x'00')
D SpaceExtA S 10A
D SpaceAut S 10A INZ('*ALL')
D SpaceText S 50A
D SpaceRepl S 10A INZ('*YES')
D SpaceDom S 10A INZ('*USER')
* Set error code structure to use basic feedback
C***** EVAL QUSBPRV = 16
* Set up imported variables
C EVAL SpaceName = UsrSpcName
C EVAL SpaceExtA = UsrSpcExtA
C EVAL SpaceText = UsrSpcText
C CALL 'QUSCRTUS'
C PARM SpaceName
C PARM SpaceExtA
C PARM SpaceSize
C PARM SpaceInit
C PARM SpaceAut
C PARM SpaceText
C PARM SpaceRepl
C PARM DS_Error
C PARM SpaceDom
C SELECT
C WHEN Bytav = 0
C RETURN 'Y'
C WHEN Bytav <> 0
C Bytav DSPLY 'OS400'
C MSgid DSPLY 'OS400'
C Exdta52 DSPLY 'OS400'
C RETURN 'N'
C ENDSL
P CrtUsrSpc E
**************************************************************************
*
* Procedure Name: GetUsrSpcP
*
**************************************************************************
P GetUsrSpcP B EXPORT
D GetUsrSpcP PI *
D UsrSpcName 20A VALUE
D SpaceName S 20A
D SpacePoint S *
* Set error code structure to use basic feedback
C EVAL QUSBPRV = 16
* Set up imported variables
C EVAL SpaceName = UsrSpcName
* Get the pointer for the user space
C CALL 'QUSPTRUS'
C PARM SpaceName
C PARM SpacePoint
C PARM QUSEC
C RETURN SpacePoint
P GetUsrSpcP E
**************************************************************************
*
* Procedure Name: GetNumEnt
*
**************************************************************************
P GetNumEnt B EXPORT
D GetNumEnt PI 9B 0
D UsrSpcName 20A VALUE
* Local Variables
D UsrSpcPntr S *
D BigField S 32767A BASED(UsrSpcPntr)
* Get the pointer for the user space
C EVAL UsrSpcPntr = GetUsrSpcP(UsrSpcName)
* Move the based on pointer to
C MOVEL BigField QUSH0100
* Return number of list entries
C RETURN QUSNBRLE
P GetNumEnt E
**************************************************************************
*
* Procedure Name: GetSpcEnt
*
**************************************************************************
P GetSpcEnt B EXPORT
D GetSpcEnt PI 32767A
D UsrSpcName 20A VALUE
D EntNumber 9B 0 VALUE
* Local Variables
D UsrSpcPntr S *
D ListPointr S *
D BigField S 32767A BASED(ListPointr)
D BigFldOut S 32767A
* Get the pointer for the user space
C EVAL UsrSpcPntr = GetUsrSpcP(UsrSpcName)
* Move the based on pointer to get header information
C EVAL ListPointr = UsrSpcPntr
C MOVEL BigField QUSH0100
* Check to see if entry requested is <= user space number entries
* If not, return a blank field
C IF EntNumber > QUSNBRLE
C EVAL BigFldOut = *BLANKS
C RETURN BigFldOut
C ENDIF
* Return specific list entry
C EVAL EntNumber = EntNumber - 1
C EVAL ListPointr = ListPointr + QUSOLD +
C (QUSSEE * EntNumber)
C EVAL BigFldOut = %SUBST(BigField:1:QUSSEE)
C RETURN BigFldOut
P GetSpcEnt E
**************************************************************************
*
* Procedure Name: DltUsrSpc
*
**************************************************************************
P DltUsrSpc B EXPORT
D DltUsrSpc PI 1A
D UsrSpcName 20A VALUE
* Local Variables
* User Space API Fields
D SpaceName S 20A
* Set error code structure to use basic feedback
C EVAL QUSBPRV = 16
* Set up imported variables
C EVAL SpaceName = UsrSpcName
C CALL 'QUSDLTUS'
C PARM SpaceName
C PARM QUSEC
C SELECT
C WHEN QUSBAVL = 0
C RETURN 'Y'
C WHEN QUSBAVL <> 0
C RETURN 'N'
C ENDSL
P DltUsrSpc E
PHP-Code:
/IF NOT DEFINED(FUSPCP)
**************************************************************************
*
* Program Name: FunctUSPcp
* Program Title: Copy Member for User Space Prototypes
* Origin Date: 10/30/97
* Author:
* Revisions:
*
**************************************************************************
* Prototype for CrtUsrSpc procedure (Create User Space)
D CrtUsrSpc PR 1A
D UsrSpcName 20A VALUE
D UsrSpcExtA 10A VALUE
D UsrSpcText 50A VALUE
* Prototype for GetUsrSpcP procedure (Get User Space Pointer)
D GetUsrSpcP PR *
D UsrSpcName 20A VALUE
* Prototype for GetNumEnt procedure (Get Number of Entries in the User Space)
D GetNumEnt PR 9B 0
D UsrSpcName 20A VALUE
* Prototype for GetSpcEnt procedure (Get Specific Entry in the User Space)
D GetSpcEnt PR 32767A
D UsrSpcName 20A VALUE
D EntNumber 9B 0 VALUE
* Prototype for DltUsrSpc procedure (Delete User Space)
D DltUsrSpc PR 1A
D UsrSpcName 20A VALUE
/DEFINE FUSPCP
/ENDIF
PHP-Code:
DQUSEC DS
D* Qus EC
D QUSBPRV 1 4B 0
D* Bytes Provided
D QUSBAVL 5 8B 0
D* Bytes Available
D QUSEI 9 15
D* Exception Id
D QUSERVED 16 16
D* Reserved
D*QUSED01 17 17
D*
D* Varying length
PHP-Code:
D*****************************************************************
D*Type Definition for the User Space Generic Header.
D*****************************************************************
DQUSH0100 DS
D* Qus Generic Header 0100
D QUSUA 1 64
D* User Area
D QUSSGH 65 68B 0
D* Size Generic Header
D QUSSRL 69 72
D* Structure Release Level
D QUSFN 73 80
D* Format Name
D QUSAU 81 90
D* Api Used
D QUSDTC 91 103
D* Date Time Created
D QUSIS 104 104
D* Information Status
D QUSSUS 105 108B 0
D* Size User Space
D QUSOIP 109 112B 0
D* Offset Input Parameter
D QUSSIP 113 116B 0
D* Size Input Parameter
D QUSOHS 117 120B 0
D* Offset Header Section
D QUSSHS 121 124B 0
D* Size Header Section
D QUSOLD 125 128B 0
D* Offset List Data
D QUSSLD 129 132B 0
D* Size List Data
D QUSNBRLE 133 136B 0
D* Number List Entries
D QUSSEE 137 140B 0
D* Size Each Entry
D QUSSIDLE 141 144B 0
D* CCSID List Ent
D QUSCID 145 146
D* Country ID
D QUSLID 147 149
D* Language ID
D QUSSLI 150 150
D* Subset List Indicator
D QUSERVED00 151 192
D* Reserved
D*****************************************************************
D*Type Definition for the User Space Generic Header, 300 format.
D*****************************************************************
DQUSH0300 DS
D* Qus Generic Header 0300
D QUSUA00 1 64
D* User Area
D QUSSGH00 65 68B 0
D* Size Generic Header
D QUSSRL00 69 72
D* Structure Release Level
D QUSFN00 73 80
D* Format Name
D QUSAU00 81 90
D* Api Used
D QUSDTC00 91 103
D* Date Time Created
D QUSIS00 104 104
D* Information Status
D QUSSUS00 105 108B 0
D* Size User Space
D QUSOIP00 109 112B 0
D* Offset Input Parameter
D QUSSIP00 113 116B 0
D* Size Input Parameter
D QUSOHS00 117 120B 0
D* Offset Header Section
D QUSSHS00 121 124B 0
D* Size Header Section
D QUSOLD00 125 128B 0
D* Offset List Data
D QUSSLD00 129 132B 0
D* Size List Data
D QUSNBRLE00 133 136B 0
D* Number List Entries
D QUSSEE00 137 140B 0
D* Size Each Entry
D QUSSIDLE00 141 144B 0
D* CCSID List Ent
D QUSCID00 145 146
D* Country ID
D QUSLID00 147 149
D* Language ID
D QUSSLI00 150 150
D* Subset List Indicator
D QUSRSV1 151 192
D* Reserved 1
D QUSEPN 193 448
D* Entry Point Name
D QUSRSV2 449 576
D* Reserved 2
MSGINFO
PHP-Code:
* ==================================================================
* = Program....... CBX007T =
* = Description... Sample code using procedure GetLogMsg =
* = =
* = CrtRPGMod Module( MSGINFO ) srcfile(dipsrvpgm/qrpglesrc) dbgview(*all)
* = CrtPgm Pgm( MSGINFO ) Module( MSGINFO ) BndSrvPgm( CBX007 )=
* ==================================================================
H Option( *SrcStmt )
*-- API error data structure
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0
D AeExcpId 7a
D 1a
D AeExcpDta 128a
*-- Get joblog message prototype
D GetLogMsg Pr 512a Varying
D PxJobId 26a Const
D PxMsgOpt 6a Const
D PxMsgKey 4a Options( *NoPass )
*-- Data definitions
D JobId s 26a
D Msg s 256a
D MsgKey s 4a
C *Entry PList
c Parm JobId
c Parm Msg
C Eval Msg = GetLogMsg( JobId
C : '*LAST'
c
C )
C Eval *InLr = *On
CBX007
PHP-Code:
* ==================================================================
* = Service program... CBX007 =
* = Description....... Job log message routines =
* = =
* = CrtRPGMod Module( CBX007 ) srcfile(dipsrvpgm/qrpglesrc) dbgview(*all)
* = CrtSrvPgm SrvPgm( CBX007 ) Module( CBX007 ) Export( *All ) =
* ==================================================================
H NoMain Option( *SrcStmt )
*-- API error data structure
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0
D AeExcpId 7a
D 1a
D AeExcpDta 128a
*-- Get joblog message procedure prototype
D GetLogMsg Pr 512a Varying
D PxJobId 26a Const
D PxMsgOpt 6a Const
D PxMsgKey 4a Options( *NoPass )
*-- Get joblog message procedure
P GetLogMsg B Export
D Pi 512a Varying
D PxJobId 26a Const
D PxMsgOpt 6a Const
D PxMsgKey 4a Options( *NoPass )
*-- API parameters
D JlMsgInfLen s 10i 0 Inz( %Size( JlMsgInf ))
D JlSltInfLen s 10i 0 Inz( %Size( JlSltInf ))
D JlGetRcdNbr s 10i 0
D JlRtnRcdNbr s 10i 0
D JlSltInf Ds
D SiRtvDrc 10a
D SiJobId 26a Inz( '*' )
D SiIntJobId 16a
D SiStrKey 4a
D SiStrKeyN 10i 0 Overlay( SiStrKey )
D SiMsgLenMax 10i 0 Inz( -1 )
D SiHlpLenMax 10i 0 Inz( 0 )
D SiFldIdsOfs 10i 0 Inz( 84 )
D SiFldIdsNbr 10i 0 Inz( %Elem( SiFldIds ))
D SiCalMsqOfs 10i 0 Inz( 88 )
D SiCalMsqLen 10i 0 Inz( 1 )
D 4a
D SiFldIds 10i 0 Dim( 1 ) Inz( 302 )
D SiCalMsq 10a Inz( '*' )
D JlLstInf Ds
D LiRcdNbrTot 10i 0
D LiRcdNbrRtn 10i 0
D LiHandle 4a
D LiRcdLen 10i 0
D LiInfSts 1a
D LiDts 13a
D LiLstSts 1a
D 1a
D LiInfLen 10i 0
D LiRcd1 10i 0
D 40a
D JlMsgInf Ds
D MiNxtMsgOfs 10i 0
D MiFldDtaOfs 10i 0
D MiFldNbrOfs 10i 0
D MiMsgSev 10i 0
D MiMsgId 7a
D MiMsgTyp 2a
D MiMsgKey 4a
D MiMsgF 10a
D MiMsgFlib 10a
D MiDatSnt 7a
D MiTimSnt 6a
D MiFldDta 32767a
D JlFldDta Ds Based( pJlFldDta )
D FdNxtFldOfs 10i 0
D FdFldDtaLen 10i 0
D FdFldId 10i 0
D FdDtaTyp 1a
D FdDtaSts 1a
D 14a
D FdDtaLen 10i 0
D FdDta 1024a
*-- Get joblog message
C Eval SiJobId = PxJobId
C Eval SiStrKey = x'00000000'
C Select
C When PxMsgOpt = '*FIRST'
C Eval SiRtvDrc = '*NEXT'
C When PxMsgOpt = '*LAST'
C Eval SiRtvDrc = '*PRV'
C Eval SiStrKey = x'FFFFFFFF'
C When PxMsgOpt = '*NEXT' Or
C PxMsgOpt = '*PRV'
C Eval SiRtvDrc = PxMsgOpt
C If %Parms = 3
C Eval SiStrKey = PxMsgKey
C EndIf
C EndSl
C Select
C When PxMsgOpt = '*NEXT'
C Eval SiStrKeyN = SiStrKeyN + 1
C When PxMsgOpt = '*PRV'
C Eval SiStrKeyN = SiStrKeyN - 1
C EndSl
C Call 'QGYOLJBL'
C Parm JlMsgInf
C Parm JlMsgInfLen
C Parm JlLstInf
C Parm 1 JlGetRcdNbr
C Parm JlSltInf
C Parm JlSltInfLen
C Parm ApiError
C If AeBytAvl = *Zero And
C LiRcdNbrRtn = 1
C Eval pJlFldDta = %Addr( JlMsgInf ) +
C MiFldDtaOfs
C If %Parms = 3
C Eval PxMsgKey = MiMsgKey
C EndIf
C Else
C Eval FdDta = *Blanks
C EndIf
C Call 'QGYCLST'
C Parm LiHandle
C Parm ApiError
C Return FdDta
P GetLogMsg E
Dann ein SBMJOB des PGM CL_LSTMSGW ins QCTL
PHP-Code:
pgm
dcl &Empaenger1 *char 30
dcl &Empaenger2 *char 30
dcl &Empaenger3 *char 30
dcl &Empaenger4 *char 30
dcl &Empaenger5 *char 30
chgvar &Empaenger1 'Name@web.de'
START:
call listmsgw (&Empaenger1 +
&Empaenger2 +
&Empaenger3 +
&Empaenger4 +
&Empaenger5 )
dlyjob dly(300)
goto START
endpgm
Gruß
Ronald
![[NEWSboard IBMi Forum]](images/duke/nblogo.gif)
[professional_User]
Mit Zitat antworten
Bookmarks