|
#3 |
API - Table of Contents |
#5 |
|
|
|
Search System Directory
**
** Program summary
** ---------------
**
** Office API:
** QOKSCHD Search system Searches system directory based
** directory on input search criteria(s) and
** returns the requested user in-
** formation for the found entries.
**
** Sequence of events:
** 1. The API input parameters are initialized
**
** 2. The search directory API is called
**
** 3. If an error occurred calling the API or
** no entry is found blanks are returned to
** the caller
**
** 4. If an entry is found the requested SMTP-
** address is retrieved, formatted and
** returned to the caller
**
**
** Parameters:
** PxUser INPUT User-id of the directory entry searched.
** Determined by the presence of the second
** parameter this can be both a user profile
** name and the first part of the system
** directory entry user identifier.
**
** The special value *CURRENT will be replaced
** by the job's current user profile name.
**
** PxAddr INPUT The address qualifier of the directory
** entry searched.
**
** Return- OUTPUT The formatted SMTP-address of the system
** value directory entry specified by the input
** parameter(s).
**
** If no matching entry was found or an error
** occurred blanks are returned to the caller.
**
**
** Programmer's note:
** The system directory SMTP-name can be maintained using the command
** WRKDIRE USRPRF( userprofile-name ) then selecting change - option 2
** - followed by F19.
**
**
** Compile options:
** CRTRPGMOD MODULE( CBX005 )
** DBGVIEW( *LIST )
**
** CRTSRVPGM SRVPGM( CBX005 )
** MODULE( CBX005 )
** ACTGRP( QSRVPGM )
**
**-- Header specifications: --------------------------------------------**
H NoMain Option( *SrcStmt )
**-- System Info Data Structure: ---------------------------------------**
D PgmSts SDs
D PsJobUsr 10a Overlay( PgmSts: 254 )
D PsCurUsr 10a Overlay( PgmSts: 358 )
**-- Get user SMTP address: --------------------------------------------**
D GetSmtpAddr Pr 321a
D PxUser 10a
D PxAddr 8a Options( *NoPass )
**-- Get user SMTP address: --------------------------------------------**
P GetSmtpAddr B Export
D Pi 321a
D PxUser 10a
D PxAddr 8a Options( *NoPass )
**-- API error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**-- Search directory parameters: --------------------------------------**
D Sreq0100 Ds
D SrCcsId 10i 0 Inz( 0 )
D SrChrSet 10i 0 Inz
D SrCodPag 10i 0 Inz
D SrWldCrd 4a Inz
D SrCvtRcv 1a Inz( '0' )
D SrSchDta 1a Inz( '0' )
D SrRunVfy 1a Inz( '1' )
D SrConHdl 1a Inz( '0' )
D SrRscHdl 16a Inz
D SrSrqFmt 8a Inz( 'SREQ0101' )
D SrSrqOfs 10i 0 Inz( 110 )
D SrSrqNbrElm 10i 0 Inz
D SrRtnFmt 8a Inz( 'SREQ0103' )
D SrRtnOfs 10i 0 Inz( 100 )
D SrRtnNbrElm 10i 0 Inz( 1 )
D SrRcvFmt 8a Inz( 'SRCV0101' )
D SrRcvNbrElm 10i 0 Inz( 1 )
D SrUsrFmt 8a Inz( 'SRCV0111' )
D SrOrdFmt 8a Inz
D SrOrdRtnOpt 1a Inz( '0' )
D 3a
D Sr0103 Like( Sreq0103 )
D Sr0101 Like( Sreq0101 )
**
D Sreq0101 Ds Inz
D S1Entry Dim( 2 )
D S1EntLen 10i 0 Inz( %Size( S1Entry ))
D Overlay( S1Entry: 1 )
D S1CmpVal 1a Inz( '1' )
D Overlay( S1Entry: *Next )
D S1FldNam 10a Overlay( S1Entry: *Next )
D S1PrdId 7a Inz( '*IBM' )
D Overlay( S1Entry: *Next )
D S1DtaCas 1a Overlay( S1Entry: *Next )
D 1a Overlay( S1Entry: *Next )
D S1ValLen 10i 0 Inz( %Size( S1ValMtc ))
D Overlay( S1Entry: *Next )
D S1ValMtc 10a Overlay( S1Entry: *Next )
**
D Sreq0103 Ds
D S3SpcRtn 10a Inz( '*SMTP' )
**
D Srcv0100 Ds 32767
D R00BytRtn 10i 0
D R00OrdFldOfs 10i 0
D R00UsrEntOfs 10i 0
D R00DirEntNbr 10i 0
D R00ConHdl 1a
D R00RscHdl 16a
D R00UsrMtcAry Like( Srcv0101 )
**
D Srcv0101 Ds Based( pSrcv0101 )
D R01UsrDtaLen 10i 0
D R01RtnNbrFld 10i 0
D Srcv0111 Ds Based( pSrcv0111 )
D R11FldNam 10a
D R11PrdId 7a
D 3a
D R11CcsId 10i 0
D R11CodPag 10i 0
D R11RtnFldLen 10i 0
D Srcv0111v Ds Based( pSrcv0111v )
D R11RtnFld 256a
**-- Local constanst & variables: --------------------------------------**
D SmtpDmn s 256a Varying
D SmtpUsrId s 64a Varying
**
D At c '@'
**-- Search directory: -------------------------------------------------**
D SchDir Pr Extpgm( 'QOKSCHD' )
D SdRcvVar Like( Srcv0100)
D SdRcvVarLen 10i 0 Const
D SdFmtNam 8a Const
D SdFunction 10a Const
D SdKeepTmpRsc 1a Const
D SdRqsVar Const Like( Sreq0100 )
D SdRqsVarLen 10i 0 Const
D SdRqsFmtNam 8a Const
D SdError 8a
**
**-- Get SMTP address: -------------------------------------------------**
**
C If PxUser = '*CURRENT'
C Eval PxUser = PsCurUsr
C EndIf
**
C If %Parms = 1
C Eval SrSrqNbrElm = 1
C Eval S1ValMtc(1) = PxUser
C Eval S1FldNam(1) = 'USER '
**
C Else
C Eval SrSrqNbrElm = 2
C Eval S1ValMtc(1) = PxUser
C Eval S1ValMtc(2) = PxAddr
C Eval S1FldNam(1) = 'USRID '
C Eval S1FldNam(2) = 'USRADDR'
C EndIf
**
C Eval Sr0103 = Sreq0103
C Eval Sr0101 = Sreq0101
**
C Callp SchDir( Srcv0100
C : %size( Srcv0100 )
C : 'SRCV0100'
C : '*SEARCH'
C : '0'
C : Sreq0100
C : %Size( Sreq0100 )
C : 'SREQ0100'
C : ApiError
C )
**
C If AeBytAvl > 0 Or
C R00DirEntNbr = 0
**
C Return *Blanks
**
C Else
C Eval pSrcv0101 = %Addr( Srcv0100 ) +
C R00UsrEntOfs
C Eval pSrcv0111 = pSrcv0101 +
C %Size( Srcv0101 )
**
C Do R01RtnNbrFld
**
C Eval pSrcv0111v = pSrcv0111 +
C %Size( Srcv0111 )
**
C Select
C When R11FldNam = 'SMTPUSRID'
C Eval SmtpUsrId = %Subst( R11RtnFld
C : 1
C : R11RtnFldLen )
**
C When R11FldNam = 'SMTPDMN'
C Eval SmtpDmn = %Subst( R11RtnFld
C : 1
C : R11RtnFldLen )
C EndSl
**
C Eval pSrcv0111 = pSrcv0111 +
C %Size( Srcv0111 ) +
C R11RtnFldLen
C EndDo
**
C Return SmtpUsrId + At + SmtpDmn
C
C EndIf
**
P GetSmtpAddr E
And the CL:
/* */
/* Program function: Break handling exit program */
/* */
/* Program summary: */
/* Receives messages from a monitored message queue as they */
/* arrive. The SMTP-address of the current job user is then */
/* retrieved from the system directory. */
/* */
/* If an SMTP-address is found the incoming message will be */
/* forwarded to that address and subsequently removed from */
/* the message queue. */
/* */
/* To notify the user of the event the message text is also */
/* sent as a status message appearing at the bottom of the */
/* current screen. */
/* */
/* */
/* Parameters: */
/* MsgQ INPUT Name of the message queue receiving */
/* the message. */
/* */
/* MsgQlib INPUT The name of the library containing */
/* the message queue. */
/* */
/* MsgKey INPUT The message reference key of the */
/* message received. */
/* */
/* */
/* Activation of break message handling: */
/* CHGMSGQ MSGQ( message-queue-name ) */
/* DLVRY( *BREAK ) */
/* PGM( CBX005I *ALWRPY ) */
/* */
/* */
/* Compile options: */
/* CRTCLMOD MODULE( CBX005CL ) */
/* SRCFILE( QRPGLESRC ) */
/* SRCMBR( CBX005CL ) */
/* DBGVIEW( *LIST ) */
/* */
/* CRTPGM PGM( CBX005I ) */
/* MODULE( CBX005CL ) */
/* BNDSRVPGM( CBX005 ) */
/* ACTGRP( *CALLER ) */
/* */
/*-------------------------------------------------------------------*/
Pgm ( &MsgQ &MsgQlib &MsgKey )
/*-- Parameters: --*/
Dcl &MsgQ *Char 10
Dcl &MsgQlib *Char 10
Dcl &MsgKey *Char 4
/*-- Global variables: --*/
Dcl &Msg *Char 512
Dcl &MsgId *Char 7
Dcl &Sev *Dec ( 2 0 )
Dcl &Sender *Char 80
Dcl &RtnType *Char 2
Dcl &SndUser *Char 10
Dcl &SmtpAddr *Char 64
Dcl &ToCallStkE *Char 38
Dcl &ErrorFlag *Lgl 1 '0'
/*-- Global error monitoring: --------------------------------------*/
MonMsg CPF0000 *None GoTo EndPgm
/*-- Receive message and keep on queue: --*/
RcvMsg MsgQ( &MsgQlib/&MsgQ ) +
MsgKey( &MsgKey ) +
Rmv( *NO ) +
Msg( &Msg ) +
MsgId( &MsgId ) +
Sev( &Sev ) +
Sender( &Sender ) +
RtnType( &RtnType )
/*-- Get SMTP-address: --*/
CallPrc GetSmtpAddr Parm( '*CURRENT ' ) +
RtnVal( &SmtpAddr )
If ( &SmtpAddr > ' ' ) Do
/*-- Retrieve sender user-id: --*/
ChgVar &SndUser %Sst( &Sender 11 10 )
/*-- Send message to SMTP-address and remove from queue: --*/
SndDst Type( *LMSG ) +
ToIntNet(( &SmtpAddr )) +
DstD( &MsgQ *Tcat ':' *Bcat +
%SSt( &Msg 1 32 )) +
LongMsg( ':/N' *Bcat +
'Sending user . . :' *Bcat +
&SndUser *Bcat +
':/N' *Bcat +
'Target queue . . :' *Bcat +
&MsgQ *Bcat +
':/P' *Bcat +
'Message text . . :' *Bcat +
&Msg )
RmvMsg MsgQ( &MsgQlib/&MsgQ ) +
MsgKey( &MsgKey ) +
Clear( *BYKEY )
EndDo
/*-- Send message to bottom of screen: --*/
SndPgmMsg MsgId( CPF9897 ) +
MsgF( QCPFMSG ) +
MsgDta( &Msg ) +
ToPgmQ( *EXT ) +
MsgType( *STATUS )
EndPgm:
EndPgm
Thanks to Carsten Flensburg
|
|
Back
|
QGYOLJOB, QGYCTLE & QGYCLST
| |
QGYOLJOB - Open list of jobs
QGYCTLE - Get list entries
QGYCLST - Close list
QWVRCSTK - Retrieve Call Stack
**
** Description : Finds interactive CPU hogs and notifies caller
**
** Program summary
** ---------------
**
** Work management APIs:
** QGYOLJOB Open list of jobs Lists jobs on the system based on
** the specified selection criteria.
**
** Optionally a sort order for the
** returned jobs can be specified -
** in this case the processor unit
** time percentage in descending
** order - listing the jobs having
** the highest CPU usage first.
**
** The CPU processor time is measured
** for an interval of 10 seconds in
** this example.
**
** The QGYOLJOB API is found in the
** QGY library as are all other open
** list APIs.
**
** QWVRCSTK Retrieve Call Stack Lists the program call stack for
** the specified job or thread.
** The current invocation level is
** returned first.
**
** Message handling API:
** QMHSNDM Send message Sends a message to the specified
** non-program message queue - here
** an informational message is sent
** to the current user running this
** program.
**
** Open list APIs:
** QGYGTLE Get list entries To retrieve open lists entries
** from an already open list the
** QGYGTLE (Get List Entries) API
** is available.
**
** QGYCLST Close list This API closes the previously
** opened list identified by the
** request handle parameter.
** Storage allocated is freed.
**
** MI builtins:
** _MATRMD Materialize resource Retrieves processor utilization
** management data data - interactive processor time
** limit.
**
** _MEMMOVE Copy memory Copies a string from one pointer
** specified location to another.
**
** Unix Type - Signal APIs:
** Sleep Suspends program processing for
** the specified number of seconds.
**
**
** Sequence of events:
** 1. The interactive processor time limit percentage is retrieved
**
** 2. The list jobs API input parameters are initialized
**
** 3. The open list of jobs API is called to reset the job
** statistics.
**
** 4. Program is suspended for 10 seconds
**
** 5. The open list of jobs API is called to list the interactive
** jobs on the system returning the most CPU intensive jobs
** for the elapsed period first.
**
** 6. For each job having used more than 50 % of the available
** interactive processor resources a message is sent to the
** message queue of the user currently running the program.
**
** If no jobs are exceeding the above CPU limit a completion
** message is sent, specifying the interactive job having the
** highest CPU utilization.
**
** 7. The job list resources are cleaned up.
**
**
** Programmer's notes:
** Earliest release program will run: V5R1
**
** As mentioned above library QGY must be in the job library list
** to succesfully run this program.
**
** To retrieve another job's call stack *JOBCTL special authority is
** required.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX102 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX102 )
** Module( CBX102 )
**
**
**-- Control spec: -----------------------------------------------------**
H Option( *SrcStmt ) DecEdit( *JobRun ) BndDir( 'QC2LE' )
**-- System information: -----------------------------------------------**
D PgmSts SDs
D PsPgmNam *Proc
D PsSts 5a Overlay( PgmSts: 11 )
D PsCurJob 10a Overlay( PgmSts: 244 )
D PsUsrPrf 10a Overlay( PgmSts: 254 )
D PsJobNbr 6a Overlay( PgmSts: 264 )
D PsCurUsr 10a Overlay( PgmSts: 358 )
**-- 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
**-- API parameters: ---------------------------------------------------**
D JlRtnRcdNbr s 10i 0 Inz( 1 )
D JlNbrFldRtn s 10i 0 Inz( %Elem( JlKeyFld ))
D JlKeyFld s 10i 0 Dim( 3 )
**-- Job information:
D JlJobInf Ds 512
D JbJobId 26a
D JbJobUsd 10a Overlay( JbJobId: 1 )
D JbUsrUsd 10a Overlay( JbJobId: *Next )
D JbNbrUsd 6a Overlay( JbJobId: *Next )
D JbActSts 4a
D JbJobTyp 1a
D JbJobSubTyp 1a
D JbDtaLen 10i 0
D 4a
D JbDta 256a
**-- Key information:
D JlKeyInf Ds
D KiFldNbrRtn 10i 0
D KiKeyInf 20a Dim( %Elem( JlKeyFld ))
D KiFldInfLen 10i 0 Overlay( KiKeyInf : 1 )
D KiKeyFld 10i 0 Overlay( KiKeyInf : 5 )
D KiDtaTyp 1a Overlay( KiKeyInf : 9 )
D 3a Overlay( KiKeyInf : 10 )
D KiDtaLen 10i 0 Overlay( KiKeyInf : 13 )
D KiDtaOfs 10i 0 Overlay( KiKeyInf : 17 )
**-- Sort information:
D JlSrtInf Ds
D SiNbrKeys 10i 0 Inz( 1 )
D SiSrtInf 12a Dim( 10 )
D SiKeyFldOfs 10i 0 Overlay( SiSrtInf : 1 )
D SiKeyFldLen 10i 0 Overlay( SiSrtInf : 5 )
D SiKeyFldTyp 5i 0 Overlay( SiSrtInf : 9 )
D SiSrtOrd 1a Overlay( SiSrtInf : 11 )
D SiRsv 1a Overlay( SiSrtInf : 12 )
**-- List information:
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
**-- Selection information:
D JlSltInf Ds
D SiJobNam 10a Inz( '*ALL' )
D SiUsrNam 10a Inz( '*ALL' )
D SiJobNbr 6a Inz( '*ALL' )
D SiJobTyp 1a Inz( 'I' )
D 1a
D SiOfsPriSts 10i 0 Inz( 60 )
D SiNbrPriSts 10i 0 Inz( 0 )
D SiOfsActSts 10i 0 Inz( 70 )
D SiNbrActSts 10i 0 Inz( 0 )
D SiOfsJbqSts 10i 0 Inz( 78 )
D SiNbrJbqSts 10i 0 Inz( 0 )
D SiOfsJbqNam 10i 0 Inz( 88 )
D SiNbrJbqNam 10i 0 Inz( 0 )
**
D SiPriSts 10a Dim( 1 )
D SiActSts 4a Dim( 2 )
D SiJbqSts 10a Dim( 1 )
D SiJbqNam 20a Dim( 1 )
**-- Job information key fields:
D JbKeyDta Ds
D JbPrcUniTim 20u 0
D JbPrcUniPct 9b 1
D JbPrcUniTimE 20u 0
**-- General return data:
D JlGenDta Ds
D GdBytRtn 10i 0
D GdBytAvl 10i 0
D GdElpTim 20u 0
D 16a
**-- MatRmd parameters: ------------------------------------------------**
D MatRscMgDt Ds
D RdBytPrv 10i 0 Inz( %Size( MatRscMgDt ))
D RdBytAvl 10i 0
D RdTimDay 8a
D RdData
D RdPrcTimIpl 20u 0 Overlay( RdData: 1 )
D RdPrcTimScWl 20u 0 Overlay( RdData: *Next )
D RdPrcTimDb 20u 0 Overlay( RdData: *Next )
D RdPrcTimDbTh 5u 0 Overlay( RdData: *Next )
D RdPrcTimDbLm 5u 0 Overlay( RdData: *Next )
D RdRsv1 10u 0 Inz( x'00' )
D Overlay( RdData: *Next )
D RdPrcTimInt 20u 0 Overlay( RdData: *Next )
D RdPrcTimIntT 4b 1 Overlay( RdData: *Next )
D RdPrcTimIntL 4b 1 Overlay( RdData: *Next )
D RdRsv2 10u 0 Inz( x'00' )
D Overlay( RdData: *Next )
**
D MatCtlDta Ds
D CdSltOpt 1a Inz( x'01' )
D CdRsv 7a Inz( *Allx'00' )
**-- Global variables: -------------------------------------------------**
D Ix s 5i 0
D CpuLvl s 5i 0
D PgmNam s 10a
D MsgDta s 256a Varying
D MsgKey s 4a
**-- API constants: ----------------------------------------------------**
D JOB_RESET_STAT c '1'
D JOB_KEEP_STAT c '0'
**-- Open list of jobs: ------------------------------------------------**
D LstJobs Pr ExtPgm( 'QGYOLJOB' )
D LjRcvVar 65535a Options( *VarSize )
D LjRcvVarLen 10i 0 Const
D LjFmtNam 8a Const
D LjRcvVarDfn 65535a Options( *VarSize )
D LjRcvDfnLen 10i 0 Const
D LjLstInf 80a
D LjNbrRcdRtn 10i 0 Const
D LjSrtInf 1024a Const Options( *VarSize )
D LjJobSltInf 1024a Const Options( *VarSize )
D LjJobSltLen 10i 0 Const
D LjNbrFldRtn 10i 0 Const
D LjKeyFldRtn 10i 0 Const Options( *VarSize ) Dim( 32 )
D LjError 1024a Options( *VarSize )
**
D LjJobSltFmt 8a Const Options( *NoPass )
**
D LjResStc 1a Const Options( *NoPass )
D LjGenRtnDta 32a Options( *NoPass: *VarSize )
D LjGenRtnDtaLn 10i 0 Const Options( *NoPass )
**-- Get list entry: ---------------------------------------------------**
D GetLstEnt Pr ExtPgm( 'QGYGTLE' )
D GlRcvVar 65535a Options( *VarSize )
D GlRcvVarLen 10i 0 Const
D GlHandle 4a Const
D GlLstInf 80a
D GlNbrRcdRtn 10i 0 Const
D GlRtnRcdNbr 10i 0 Const
D GlError 1024a Options( *VarSize )
**-- Close list: -------------------------------------------------------**
D CloseLst Pr ExtPgm( 'QGYCLST' )
D ClHandle 4a Const
D ClError 1024a Options( *VarSize )
**-- Send message: -----------------------------------------------------**
D SndMsg Pr ExtPgm( 'QMHSNDM' )
D SmMsgId 7a Const
D SmMsgFq 20a Const
D SmMsgDta 512a Const Options( *VarSize )
D SmMsgDtaLen 10i 0 Const
D SmMsgTyp 10a Const
D SmMsgQq 1000a Const Options( *VarSize )
D SmMsgQnbr 10i 0 Const
D SmMsgQrpy 20a Const
D SmMsgKey 4a
D SmError 10i 0 Const
**
D SmCcsId 10i 0 Const Options( *NoPass )
**-- Copy memory: ------------------------------------------------------**
D memcpy Pr * ExtProc( '_MEMMOVE' )
D outmem * Value
D inpmem * Value
D memsiz 10u 0 Value
**-- Delay job: --------------------------------------------------------**
D sleep Pr 10i 0 ExtProc( 'sleep' )
D seconds 10u 0 Value
**-- Get top stack entry: ----------------------------------------------**
D GetTopStkE Pr 20a
D GtJobId 26a Const
**-- Materialize resource management data: -----------------------------**
D MatRmd Pr ExtProc( '_MATRMD' )
D Rcv Like( MatRscMgDt )
D Ctl Like( MatCtlDta )
**
**-- Mainline: ---------------------------------------------------------**
**
**-- Get interactive processor time limit:
C Callp(e) MatRmd( MatRscMgDt: MatCtlDta )
**
C If %Error
C Eval RdPrcTimIntL= 100
C EndIf
**
**-- Job information return fields:
C Eval JlKeyFld(1) = 312
C Eval JlKeyFld(2) = 314
C Eval JlKeyFld(3) = 315
**
**-- Sort field specification:
C Eval SiNbrKeys = 1
C Eval SiKeyFldOfs(1) = 49
C Eval SiKeyFldLen(1) = 4
C Eval SiKeyFldTyp(1) = 0
C Eval SiSrtOrd(1) = '2'
C Eval SiRsv(1) = x'00'
**
**-- Initialize job CPU measurement:
**-- NOTE: Statistics only reset if return records are requested
**
C CallP LstJobs( JlJobInf
C : %Size( JlJobInf )
C : 'OLJB0300'
C : JlKeyInf
C : %Size( JlKeyInf )
C : JlLstInf
C : 1
C : JlSrtInf
C : JlSltInf
C : %Size( JlSltInf )
C : JlNbrFldRtn
C : JlKeyFld
C : ApiError
C : 'OLJS0100'
C : JOB_RESET_STAT
C : JlGenDta
C : %Size( JlGenDta )
C )
**
**-- Wait 10 seconds:
C CallP sleep( 10 )
**
**-- Retrieve job list:
C CallP LstJobs( JlJobInf
C : %Size( JlJobInf )
C : 'OLJB0300'
C : JlKeyInf
C : %Size( JlKeyInf )
C : JlLstInf
C : 1
C : JlSrtInf
C : JlSltInf
C : %Size( JlSltInf )
C : JlNbrFldRtn
C : JlKeyFld
C : ApiError
C : 'OLJS0100'
C : JOB_KEEP_STAT
C : JlGenDta
C : %Size( JlGenDta )
C )
**
C If AeBytAvl = *Zero
**
C DoW LiLstSts <> '2' Or
C LiRcdNbrTot > JlRtnRcdNbr
**
C ExSr GetCpuDta
C ExSr ChkCpuPct
**
C If CpuLvl = 2
C ExSr SndCmpMsg
C EndIf
**
C If CpuLvl >= 2
C Leave
C EndIf
**
C Eval JlRtnRcdNbr = JlRtnRcdNbr + 1
**
C CallP GetLstEnt( JlJobInf
C : %Size( JlJobInf )
C : LiHandle
C : JlLstInf
C : 1
C : JlRtnRcdNbr
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Leave
C EndIf
**
C EndDo
**
C CallP CloseLst( LiHandle
C : ApiError
C )
**
C EndIf
**
C Eval *InLr = *On
**
C Return
**
**-- Get CPU data: -----------------------------------------------------**
C GetCpuDta BegSr
**
C Clear JbKeyDta
**
C For Ix = 1 To KiFldNbrRtn
**
C Select
C When KiKeyFld(Ix) = 312
C CallP memcpy( %Addr( JbPrcUniTim )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 314
C CallP memcpy( %Addr( JbPrcUniPct )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix) = 315
C CallP memcpy( %Addr( JbPrcUniTimE )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
C EndSl
C EndFor
**
C EndSr
**-- Check CPU percent: ------------------------------------------------**
C ChkCpuPct BegSr
**
C If JbPrcUniPct > RdPrcTimIntL / 2
**
C Eval CpuLvl = 1
C Eval PgmNam = GetTopStkE( JbJobId )
**
C Eval MsgDta = 'CPU alert - program ' +
C %Trim( PgmNam ) +
C ' in job ' +
C %Trim( JbJobUsd ) +
C ' is currently using ' +
C %Char( JbPrcUniPct ) +
C ' CPU % of ' +
C %Char( RdPrcTimIntL ) +
C ' interactive CPU % available.'
**
C CallP(e) SndMsg( *Blanks
C : *Blanks
C : MsgDta
C : %Len( MsgDta )
C : '*INFO'
C : PsCurUsr + '*LIBL'
C : 1
C : *Blanks
C : MsgKey
C : 0
C )
**
C Else
C Eval CpuLvl = CpuLvl + 2
C EndIf
**
C EndSr
**-- Send completion message: ------------------------------------------**
C SndCmpMsg BegSr
**
C Eval MsgDta = 'CPU monitor completed ' +
C '- max utilization by job ' +
C %Trim( JbJobUsd ) +
C ' using ' +
C %Char( JbPrcUniPct ) +
C ' CPU % of ' +
C %Char( RdPrcTimIntL ) +
C ' interactive CPU % available.'
**
C CallP(e) SndMsg( *Blanks
C : *Blanks
C : MsgDta
C : %Len( MsgDta )
C : '*COMP'
C : PsCurUsr + '*LIBL'
C : 1
C : *Blanks
C : MsgKey
C : 0
C )
**
C EndSr
**-- Get top stack entry: ----------------------------------------------**
P GetTopStkE B Export
D Pi 20a
D GtJobId 26a Const
**-- API parameters:
D CsRcvVar Ds
D CsBytRtn 10i 0
D CsBytAvl 10i 0
D CsNbrStkE 10i 0
D CsOfsStkE 10i 0
D CsNbrEntRtn 10i 0
D CsThrId 8a
D CsInfSts 1a
D CsCalStk 32767a
**
D CsCalStkE Ds Based( pCalStkE )
D CsStkEntLen 10i 0
D CsOfsStmIds 10i 0
D CsNbrStmIds 10i 0
D CsOfsPrcNam 10i 0
D CsLenPrcNam 10i 0
D CsRqsLvl 10i 0
D CsPgmNam 10a
D CsPgmLib 10a
D CsMiInst 10i 0
D CsModNam 10a
D CsModLib 10a
D CsCtlBdy 1a
D CsRsv 3a
D CsActGrpNbr 10u 0
D CsActGrpNam 10a
D CsAddInf 4096a
**
D CsStmIds 10a Dim( 16 )
D CsPrcNam 512a
**
D CsJobId Ds
D JiJobId 26a
D JiJobNam 10a Overlay( JiJobId: 1 )
D JiUsrNam 10a Overlay( JiJobId: *Next )
D JiJobNbr 6a Overlay( JiJobId: *Next )
D JiIntId 16a
D JiRsv 2a Inz( *Allx'00' )
D JiThrInd 10i 0 Inz( 2 )
D JiThrId 8a Inz( *Allx'00' )
**-- Retrieve call stack:
D RtvCalStk Pr ExtPgm( 'QWVRCSTK' )
D RcRcvVar 32767a
D RcRcvVarLen 10i 0 Const
D RcRcvInfFmt 8a Const
D RcJobId 56a Const
D RcJobIdFmt 8a Const
D RcError 32767a Options( *VarSize )
**
D EntNbr s 5u 0
**-- Get stack entries: ------------------------------------------------**
**
C Eval JiJobId = GtJobId
**
C CallP RtvCalStk( CsRcvVar
C : %Size( CsRcvVar )
C : 'CSTK0100'
C : CsJobId
C : 'JIDF0100'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C Eval pCalStkE = %Addr( CsRcvVar ) + CsOfsStkE
**
C For EntNbr = 1 to CsNbrEntRtn
**
C If EntNbr = 1
**
C Eval CsStmIds = *Blanks
C Eval CsPrcNam = *Blanks
**
C If CsOfsStmIds > *Zero
C CallP MemCpy( %Addr( CsStmIds )
C : %Addr( CsCalStkE ) +
C CsOfsStmIds
C : CsNbrStmIds * %Size( CsStmIds )
C )
C EndIf
**
C If CsOfsPrcNam > *Zero
C CallP MemCpy( %Addr( CsPrcNam )
C : %Addr( CsCalStkE ) +
C CsOfsPrcNam
C : CsLenPrcNam
C )
C EndIf
**
C Leave
C EndIf
**
C If EntNbr < CsNbrEntRtn
C Eval pCalStkE = PCalStkE + CsStkEntLen
C EndIf
C EndFor
**
C Return CsPgmNam + CsPgmLib
**
C Else
C Return *Blanks
C EndIf
**
P GetTopStkE E
Thanks to Carsten Flensburg
|
|
Back
QUSLFLD List Fields
QUSCRTUS Create user space
QUSDLTUS Delete user space
QUSPTRUS Retrieve pointer to user space
**
** Description : Find database field containing scan string
**
** Program summary
** ---------------
**
** Object - User space APIs:
** QUSCRTUS Create user space Creates a user space in either
** user domain or system domain.
** Only user domain user spaces are
** accessible by the user space APIs.
**
** QUSDLTUS Delete user space Deletes the user space specified.
**
** QUSPTRUS Retrieve pointer to The address of the first byte
** user space of the storage allocated by the
** user space requested is returned.
**
** Database and file APIs:
** QUSLFLD List fields Lists the fields of the specified
** file record format to user space.
**
** The list includes information
** about each field's attributes and
** record buffer position.
**
** National language support API:
** QlgConvertCase Convert case Converts a character string to
** upper or lower case based on a
** coded character set identifier
** (CCSID) rather than a table.
**
** The CCSID support makes the API
** very flexible to use, but based
** on experience a certain overhead
** is incurred in this process.
**
** C library functions:
** _Ropen Open record file Opens the record file specified
** as defined by the keywords in the
** mode parameter. If the file does
** not exist it will not be created.
**
** The mode parameter specifies the
** type of file access as well as
** optional parameters to control
** f.x. whether the file is read in
** arrival or keyed order.
**
** The *LIBL & *CURLIB special values
** are supported for the library
** name and an optional member name
** is possible to specify in the
** format library/file(member).
**
** _Rclose Close record file This API closes the previously
** opened record file identified by
** the file pointer parameter.
**
** Storage allocated is freed and
** all buffers are flushed.
**
** _Rreadf Read first record Reads the first record in the
** access pass specified by file
** pointer in either arrival or
** keyed order.
**
** _Rreadn Read next record Reads the next record in the
** access pass specified by file
** pointer in either arrival or
** keyed order.
**
**
** Sequence of events:
** 1. A translation table is setup using the convert case API to
** ensure correct code page translation and at the same time - by
** using at table driven translation - avoid the overhead related
** to repeatedly calling the conversion API.
**
** 2. A user space is created and the list of the requested file's
** fields is loaded to the user space.
**
** 3. The requested file is opened for sequential and blocked read
** only.
**
** 4. The file records are read one by one into a buffer string.
**
** 5. The retrieved record buffer is processed one field at a time,
** scanning every alfa field for the scan string - with or without
** case sensitivity as requested.
**
** 6. For each field containing the scan string a line is printed.
**
** 7. At end of file the file is closed, the user space deleted and
** the program is terminated.
**
**
** Programmer's notes:
** The manual specifies that the record block size - if blocking is
** requested - will be optimized by the system. Unfortunately the
** system still seems to regard the optimum block size on the iSeries
** to be 4K - even though it for RISC systems is 128K.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX103 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX103 )
** Module( CBX103 )
**
**-- Header specifications: --------------------------------------------**
H BndDir( 'QC2LE' ) Option( *SrcStmt ) DatEdit( *MDY/ )
**-- Printer file: -----------------------------------------------------**
FQSYSPRT O F 132 Printer InfDs( PrtLinInf ) OflInd( *InOf )
**-- Printer file information: -----------------------------------------**
D PrtLinInf Ds
D PlOvfLin 5i 0 Overlay( PrtLinInf: 188 )
D PlCurLin 5i 0 Overlay( PrtLinInf: 367 )
D PlCurPag 5i 0 Overlay( PrtLinInf: 369 )
**-- System information: -----------------------------------------------**
D SDs
D PsPgmNam *Proc
**-- Global variables: -------------------------------------------------**
D pRFILE s *
D rc s 10i 0
D Idx s 10i 0
D StrBuf s 10240a
D RtnBuf s 10240a
D FldVal s 1024a Varying
D FldVal40 s 40a
D ScnVal s 1024a Varying
D ScnArg s 32a Varying
D ScnPos s 4s 0
**
D Time s 6s 0
D NbrRcds s 10u 0
**-- Xlate table variables: --------------------------------------------**
D Cvt Ds
D CvtNum 3u 0 Dim( 255 )
D CvtAlf 1a Dim( 255 ) Overlay( Cvt )
**
D Hi s 255a Varying
D Lo s 255a Varying
**-- Global constants: -------------------------------------------------**
D UsrSpcQ c 'DBFLST QTEMP'
D No_Lock c x'00000001'
**-- Api error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**-- I/O feedback structure: -------------------------------------------**
D RIOFB Ds Based( pRIOFB )
D pKey *
D pSysParm *
D IoRcdRrn 10u 0
D IoNbrBytRw 10i 0
D IoBlkCnt 5i 0
D IoBlkFllBy 1a
D IoBitFld 1a
D IoRsv 20a
**-- User space pointers: ----------------------------------------------**
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- User space generic header: ---------- -----------------------------**
D UsrSpc Ds Based( pUsrSpc )
D UsOfsHdr 10i 0 Overlay( UsrSpc: 117 )
D UsOfsLst 10i 0 Overlay( UsrSpc: 125 )
D UsNumLstEnt 10i 0 Overlay( UsrSpc: 133 )
D UsSizLstEnt 10i 0 Overlay( UsrSpc: 137 )
**-- API header information: -------------------------------------------**
D HdrInf Ds Based( pHdrInf )
D FlFilNamU 10a
D FlFilLibU 10a
D FlFilTyp 10a
D FlRcdFmtNamU 10a
D FlRcdLen 10i 0
D FlRcdFmtId 13a
D FlRcdTxtDsc 50a
D 1a
D FlRcdTxtCcsId 10i 0
D FlVarLenFldIn 1a
D FlGphFldInd 1a
D FlDatTimFldIn 1a
D FlNulCapFldIn 1a
**-- API format FLDL0100: ----------------------------------------------**
D FldLst0100 Ds Based( pLstEnt )
D F1FldNam 10a
D F1DtaTyp 1a
D F1DtaUse 1a
D F1OutBufPos 10i 0
D F1InpBufPos 10i 0
D F1Len 10i 0
D F1Digits 10i 0
D F1DecPos 10i 0
D F1TxtDsc 50a
D F1EdtCod 2a
D F1EdtWrdLen 10i 0
D F1EdtWrd 64a
D F1ColHdg1 20a
D F1ColHdg2 20a
D F1ColHdg3 20a
D F1IntFldNam 10a
D F1AltFldNam 30a
D F1AltFldNamLn 10i 0
D F1NbrChrDbcs 10i 0
D F1AlwNull 1a
D F1HstVarInd 1a
D F1DatTimFmt 4a
D F1DatTimSep 1a
D F1VarFldLenIn 1a
D F1TxtDscCcsId 10i 0
D F1DtaCcsId 10i 0
D F1ColHdgCcsId 10i 0
D F1EdtWrdCcsId 10i 0
D F1Ucs2DspFldL 10i 0
**-- Convert case parameters & constants: ------------------------------**
D CcRqsCtlBlk Ds
D RcRqsType 10i 0 Inz( CvtByCcsId )
D RcCCSID 10i 0 Inz( JobCcsId )
D RcCaseRqs 10i 0 Inz
D 10a Inz( *Allx'00')
**
D CvtByCcsId c 1
D JobCcsId c 0
D Lower c 1
D Upper c 0
**-- List fields: ------------------------------------------------------**
D LstFld Pr *
D PxUsrSpc 20a Const
D PxFilNam 10a Const
D PxLibNam 10a Const
**-- To upper case: ----------------------------------------------------**
D ToUpper Pr 1024a Varying
D InpStr 1024a Const Varying
**-- To lower case: ----------------------------------------------------**
D ToLower Pr 1024a Varying
D InpStr 1024a Const Varying
**-- Open file: --------------------------------------------------------**
D Ropen Pr * ExtProc( '_Ropen' )
D pRFile * Value Options( *String )
D pMode * Value Options( *String )
D pOptParm * Value Options( *String: *NoPass )
**-- Close file: -------------------------------------------------------**
D Rclose Pr 10i 0 ExtProc( '_Rclose' )
D pRFile * Value
**-- Read first record: ------------------------------------------------**
D Rreadf Pr * ExtProc( '_Rreadf' )
D pRFile * Value
D pBuffer * Value
D BufLength 10u 0 Value
D Options 10i 0 Value
**-- Read next record: -------------------------------------------------**
D Rreadn Pr * ExtProc( '_Rreadn' )
D pRFile * Value
D pBuffer * Value
D BufLength 10u 0 Value
D Options 10i 0 Value
**-- Create user space: -------------------------------------------------**
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D CsSpcNamQ 20a Const
D CsExtAtr 10a Const
D CsInzSiz 10i 0 Const
D CsInzVal 1a Const
D CsPubAut 10a Const
D CsText 50a Const
**-- Optional 1:
D CsReplace 10a Const Options( *NoPass )
D CsError 32767a Options( *NoPass: *VarSize )
**-- Optional 2:
D CsDomain 10a Const Options( *NoPass )
**-- Delete user space: -------------------------------------------------**
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- Convert case: -----------------------------------------------------**
D CvtCase Pr ExtProc( 'QlgConvertCase' )
D CcRqsBlk 22a Const
D CcInpDta 32767a Const Options( *VarSize )
D CcOutDta 32767a Options( *VarSize )
D CcDtaLen 10i 0 Const
D CcError 32767a Options( *VarSize )
**-- Program parameters: -----------------------------------------------**
D PxFilNam s 10a
D PxLibNam s 10a
D PxScnArg s 32a
D PxCasSns s 1a
**
C *Entry Plist
C Parm PxFilNam
C Parm PxLibNam
C Parm PxScnArg
C Parm PxCasSns
**
**-- Mainline: ---------------------------------------------------------**
**
C ExSr InzPgm
**
C If PxScnArg > *Blanks
**
C Eval pUsrSpc = LstFld( UsrSpcQ
C : PxFilNam
C : PxLibNam
C )
**
C If pUsrSpc <> *Null
**
C Eval pRFILE = Ropen( %Trim( PxLibNam ) +
C '/' +
C %Trim( PxFilNam )
C : 'rr, arrseq=Y, ' +
C 'blkrcd=Y'
C )
C
C If pRFILE <> *Null
**
C Eval pRIOFB = Rreadf( pRFILE
C : %Addr( StrBuf )
C : %Size( StrBuf )
C : No_Lock
C )
**
C DoW IoNbrBytRw > 0
**
C ExSr PrcRcd
**
C Eval pRIOFB = Rreadn( pRFILE
C : %Addr( StrBuf )
C : %Size( StrBuf )
C : No_Lock
C )
**
C EndDo
**
C Eval rc = Rclose( pRFILE )
**
C EndIf
C EndIf
C EndIf
**
C ExSr TrmPgm
**
**-- Process record: ---------------------------------------------------**
C PrcRcd BegSr
**
C Eval RtnBuf = %SubSt( StrBuf: 1: IoNbrBytRw )
**
C Eval pHdrInf = pUsrSpc + UsOfsHdr
C Eval pLstEnt = pUsrSpc + UsOfsLst
**
C For Idx = 1 To UsNumLstEnt
**
C If F1DtaTyp = 'A'
**
C Eval FldVal = %SubSt( RtnBuf
C : F1InpBufPos
C : F1Len
C )
**
C If PxCasSns = 'Y'
C Eval ScnVal = %Xlate( Lo: Hi: FldVal )
C Else
C Eval ScnVal = FldVal
C EndIf
**
C Eval ScnPos = %Scan( ScnArg: ScnVal )
C If ScnPos > *Zero
**
C ExSr WrtLstLin
C EndIf
C EndIf
**
C If Idx < UsNumLstEnt
C Eval pLstEnt = pLstEnt + UsSizLstEnt
C EndIf
C EndFor
**
C EndSr
**-- Write list line: --------------------------------------------------**
C WrtLstLin BegSr
**
C Eval FldVal40 = FldVal
**
C If PlCurLin > PlOvfLin - 3
C Except Header
C EndIf
**
C Eval NbrRcds = NbrRcds + 1
C Except Detail
**
C EndSr
**-- Initialize program: -----------------------------------------------**
C InzPgm BegSr
**
C ExSr InzXltTbl
**
C If PxCasSns = 'Y'
C Eval ScnArg = %TrimR( PxScnArg )
C Eval ScnArg = %Xlate( Lo: Hi: ScnArg )
**
C Else
C Eval ScnArg = %TrimR( PxScnArg )
C EndIf
**
C Time Time
C Except Header
**
C CallP CrtUsrSpc( UsrSpcQ
C : *Blanks
C : 65535
C : x'00'
C : '*CHANGE'
C : *Blanks
C : '*YES'
C : ApiError
C )
**
C EndSr
**-- Initialize translation table: -------------------------------------**
C InzXltTbl BegSr
**
**-- Fill conversion table with displayable (hex 40-hex FE) and
**-- non-duplicate codepoints only:
**
C For Idx = 40 to %Elem( CvtNum )
C Eval CvtNum(Idx) = Idx
C EndFor
**
C Eval Cvt = ToUpper( Cvt )
C SortA CvtAlf
**
C For Idx = 40 to %Elem( CvtAlf )
**
C If CvtAlf(Idx) > CvtAlf(Idx-1)
C Eval Hi = Hi + CvtAlf(Idx)
C EndIf
C EndFor
**
C Eval Lo = ToLower( Hi )
**
C EndSr
**-- Terminate program: ------------------------------------------------**
C TrmPgm BegSr
**
C If NbrRcds = *Zero
C Except NoRcds
C EndIf
**
C CallP DltUsrSpc( UsrSpcQ
C : ApiError
C )
**
C Eval *InLr = *On
C Return
**
C EndSr
**-- Print file definition: --------------------------------------------**
OQSYSPRT EF Header 2 3
O UDATE Y 8
O Time 18 ' : : '
O 75 'Scan file fields rep-
O ort'
O 107 'Program:'
O PsPgmNam 118
O 126 'Page:'
O PAGE + 1
OQSYSPRT EF Header 1
O 4 'File'
O 19 'Library'
O 34 'Scan value'
O 71 'RRN'
O 84 'Field name'
O 90 'Pos.'
O 103 'Field value'
**
OQSYSPRT EF Detail 1
O FlFilNamU 10
O FlFilLibU 22
O PxScnArg 56
O IoRcdRrn 3 71
O F1FldNam 84
O ScnPos 3 89
O FldVal40 132
**
OQSYSPRT EF NoRcds 1
O 26 '(No matches found)'
**-- List fields: ------------------------------------------------------**
P LstFld B
D Pi *
D PxUsrSpc 20a Const
D PxFilNam 10a Const
D PxLibNam 10a Const
**-- List fields to user space:
D LstFldSpc Pr ExtPgm( 'QUSLFLD' )
D LfSpcNamQ 20a Const
D LfFmtNam 8a Const
D LfFilNamQual 20a Const
D LfRcdFmtNam 10a Const
D LfOvrPrc 1a Const
D LfError 32767a Options( *NoPass: *VarSize )
**-- Retrieve pointer to user space:
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**
D pUsrSpc s *
**-- List file fields: -------------------------------------------------**
**
C CallP LstFldSpc( PxUsrSpc
C : 'FLDL0100'
C : PxFilNam + PxLibNam
C : '*FIRST'
C : '0'
C : ApiError
C )
**
C If AeBytAvl = *Zero
**
C CallP RtvPtrSpc( PxUsrSpc
C : pUsrSpc
C )
**
C Return pUsrSpc
C Else
**
C Return *Null
C EndIf
**
P LstFld E
**-- To upper case: ----------------------------------------------------**
P ToUpper B
D Pi 1024a Varying
D InpStr 1024a Const Varying
**
D OutStr s 1024a
**-- Convert to upper case: --------------------------------------------**
**
C Eval RcCaseRqs = Upper
**
C CallP CvtCase( CcRqsCtlBlk
C : InpStr
C : OutStr
C : %Len( InpStr )
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Return InpStr
**
C Else
C Return %TrimR( OutStr )
C EndIf
**
P ToUpper E
**-- To lower case: ----------------------------------------------------**
P ToLower B
D Pi 1024a Varying
D InpStr 1024a Const Varying
**
D OutStr s 1024a
**-- Convert to lower case: --------------------------------------------**
**
C Eval RcCaseRqs = Lower
**
C CallP CvtCase( CcRqsCtlBlk
C : InpStr
C : OutStr
C : %Len( InpStr )
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Return InpStr
**
C Else
C Return %TrimR( OutStr )
C EndIf
**
P ToLower E
And the calling program:
**
** Description : Find database field containing scan string
**
** Compile options:
**
** CrtRpgMod Module( CBX103T ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX103T )
** Module( CBX103T )
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Program parameters: -----------------------------------------------**
** File name:
D PxFilNam s 10a Inz( 'filename' )
** Library name, *LIBL or *CURLIB:
D PxLibNam s 10a Inz( 'lib name' )
** Scan argument:
D PxScnArg s 32a Inz( 'scan string' )
** Scan case sensitive, Y=Yes:
D PxCasSns s 1a Inz( 'Y' )
**
C Call 'CBX103'
C Parm PxFilNam
C Parm PxLibNam
C Parm PxScnArg
C Parm PxCasSns
**
C Eval *InLr = *On
C Return
**
Thanks to Carsten Flensburg
|
|
Back
TCP/IP management APIs (1)
**
** Description : Print TCP/IP connection status
**
** Program summary
** ---------------
**
** Object - User space APIs:
** QUSCRTUS Create user space Creates a user space in either
** user domain or system domain.
** Only user domain user spaces are
** accessible by the user space APIs.
**
** QUSDLTUS Delete user space Deletes the user space specified.
**
** QUSPTRUS Retrieve pointer to The address of the first byte
** user space of the storage allocated by the
** user space requested is returned.
**
**
** Communication - TCP/IP management APIs:
** QtocRtvTCPA Retrieve TCP/IP Retrieves TCP/IPv4 and TCP/IPv6
** attributes (V5R2) stack attributes.
**
** QtocLstNetCnn List network Returns a non-detailed list of
** connections network connections based on a
** set of selection criteria defined
** in the list qualifier parameter.
**
** QtocRtvNetCnnDta List network Retrieves detailed information
** connection data and connection totals for the
** specified network connection.
**
**
** Sequence of events:
** 1. The current operational status of the TCP/IP stack is retrieved
** to ensure that TCP/IP connection information is available.
**
** 2. A user space is created and a list of the current TCP/IP network
** connections is loaded to the user space.
**
** 3. For each TCP/IP network connection retrieved from user space a
** report line is printed and subsequently the associated network
** connection data are retrieved.
**
** 4. The based data and list structures are allocated to the storage
** adresses defined by the offsets found in the basic and additional
** information API formats.
**
** 5. A report line is printed for each of the servicing jobs associated
** with the current network connection.
**
** 6. Finally the user space is deleted, explicitly allocated storage
** freed and the program is terminated.
**
**
** Programmer's notes:
** Earliest release program will run: V5R1
**
** The examples here are all retrieving information about TCP/IPv4
** stacks and connections. As of V5R2 new API formats are available
** for retrieval of similar TCP/IPv6 stack and connection information.
**
** Be careful to allocate sufficient storage for the return structure
** of the QtocRtvNetCnnDta API initially. The returned value for bytes
** actually available might not include the additional structures,
** Socket options and Associated jobs/tasks.
**
** The QtocRtvNetCnnDta API has a reported problem involving a memory
** leak. The following PTFs have been released to fix the problem:
** R510 SI09122 1000
** R520 SI09175 1000
**
**
** Compile options:
**
** CrtRpgMod Module( CBX105 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX105 )
** Module( CBX105 )
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Printer file: -----------------------------------------------------**
FQSYSPRT O F 132 Printer InfDs( PrtLinInf ) OflInd( *InOf )
**-- Printer file information: -----------------------------------------**
D PrtLinInf Ds
D PlOvfLin 5i 0 Overlay( PrtLinInf: 188 )
D PlCurLin 5i 0 Overlay( PrtLinInf: 367 )
D PlCurPag 5i 0 Overlay( PrtLinInf: 369 )
**-- System information: -----------------------------------------------**
D SDs
D PsPgmNam *Proc
**-- Global declarations: ----------------------------------------------**
D Lix s 10u 0
D Dix s 10u 0
D BytAlc s 10u 0
D UsrSpc c 'LSTNETCNN QTEMP'
**
D Time s 6s 0
D NbrRcds s 10u 0
D TcpCnnStt s 4a
D ConOpnTyp s 3a
**-- Tcp state table: --------------------------------------------------**
D SttTbl Ds
D TcpStt 5a Dim( 12 )
D 60a Overlay( SttTbl )
D Inz( 'LST SYNR SYNS EST FIN1 FIN2 +
D CLO2 CLO1 LACK WAIT CLO n/s ')
**-- Open type table: --------------------------------------------------**
D OpnTbl Ds
D OpnTyp 4a Dim( 3 )
D 12a Overlay( OpnTbl )
D Inz( 'PSV ACT n/s ' )
**-- Api error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**
**-- API Header information: -------------------------------------------**
D HdrInf Ds Based( pHdrInf )
D HiUsrSpcNamSp 10a
D HiUsrSpcLibSp 10a
**-- User space generic header: ---------- -----------------------------**
D UsrSpcHdr Ds Based( pUsrSpc )
D UsOfsHdr 10i 0 Overlay( UsrSpcHdr: 117 )
D UsOfsLst 10i 0 Overlay( UsrSpcHdr: 125 )
D UsNumLstEnt 10i 0 Overlay( UsrSpcHdr: 133 )
D UsSizLstEnt 10i 0 Overlay( UsrSpcHdr: 137 )
**-- User space pointers: ----------------------------------------------**
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- TCP/IP attributes: ------------------------------------------------**
D TCPA0100 Ds
D T1BytRtn 10u 0
D T1BytAvl 10u 0
D T1StkSts 10u 0
D T1ActTim 10u 0
D T1LstStrD 8a
D T1LstStrT 6a
D T1LstEndD 8a
D T1LstEndT 6a
D T1StrJob 10a
D T1StrUsr 10a
D T1StrNbr 6a
D T1StrJobInt 16a
D T1EndJob 10a
D T1EndUsr 10a
D T1EndNbr 6a
D T1EndJobInt 16a
D T1OfsAddInf 10u 0
D T1LenAddInf 10u 0
**-- Connection list qualifier: ----------------------------------------**
D NCLQ0100 Ds
D N1NetCnnTyp 10a Inz( '*ALL' )
D N1LstRqsTyp 10a Inz( '*ALL' )
D 12a Inz( *Allx'00' )
D N1LocAdrLow 10u 0 Inz( 0 )
D N1LocAdrUpr 10u 0 Inz( 0 )
D N1LocPortLow 10u 0 Inz( 0 )
D N1LocPortUpr 10u 0 Inz( 0 )
D N1RmtAdrLow 10u 0 Inz( 0 )
D N1RmtAdrUpr 10u 0 Inz( 0 )
D N1RmtPortLow 10u 0 Inz( 0 )
D N1RmmPortUpr 10u 0 Inz( 0 )
**-- Connection list entry: --------------------------------------------**
D NCNN0100 Ds Based( pLstEnt )
D C1RmtAdr 15a
D 1a
D C1RmtAdrBin 10u 0
D C1LocAdr 15a
D 1a
D C1LocAdrBin 10u 0
D C1RmtPort 10u 0
D C1LocPort 10u 0
D C1TcpState 10u 0
D C1IdlTimMs 10u 0
D C1BytIn 20u 0
D C1BytOut 20u 0
D C1ConOpnTyp 10u 0
D C1NetCnnTyp 10a
D 1a
**-- Following fields were added in V5R2 - do not reference in V5R1:
D 1a
D C1AscUsrPrf 10a
D 2a
**-- Socket connection request: ----------------------------------------**
D SocCnnRqs Ds
D ScProtocol 10u 0
D ScLocIpAdr 10u 0
D ScLocPortNbr 10u 0
D ScRmtIpAdr 10u 0
D ScRmtPortNbr 10u 0
**-- Connection data: --------------------------------------------------**
D NCND0100 Ds Based( pCnnDta )
D D1BytRtn 10u 0
D D1BytAvl 10u 0
D D1CurCnnEst 10u 0
D D1ActOpn 10u 0
D D1PasOpn 10u 0
D D1AttOpnFail 10u 0
D D1EstNxtRes 10u 0
D D1SegSnt 10u 0
D D1SegRtr 10u 0
D D1SegRsn 10u 0
D D1SegRcv 10u 0
D D1SegRcvErr 10u 0
D D1DtgSnt 10u 0
D D1DtgRcv 10u 0
D D1DtgNdlPort 10u 0
D D1DtgNdlOde 10u 0
D D1AddInfOfs 10u 0
D D1AddInfLen 10u 0
**
D NCND0200 Ds Based( pCnnDtaInf )
D D2Protocol 10u 0
D D2LocIpAdr 10u 0
D D2LocPortNbr 10u 0
D D2RmtIpAdr 10u 0
D D2RmtPortNbr 10u 0
D D2RndTrpTim 10u 0
D D2RndTrpVar 10u 0
D D2OutBytBuf 10u 0
D D2UsrSndNxt 10u 0
D D2SndNxt 10u 0
D D2SndUnack 10u 0
D D2OutPshNbr 10u 0
D D2OutUrgNbr 10u 0
D D2OutWdwNbr 10u 0
D D2IncBytBuf 10u 0
D D2RcvNxt 10u 0
D D2UsrRcvNxt 10u 0
D D2IncPshNbr 10u 0
D D2IncUrgNbr 10u 0
D D2IncWdwNbr 10u 0
D D2TotRtr 10u 0
D D2CurRtr 10u 0
D D2MaxWdwSiz 10u 0
D D2CurWdwSiz 10u 0
D D2LastUpd 10u 0
D D2LastUpdAck 10u 0
D D2CngWdw 10u 0
D D2SlwStrThr 10u 0
D D2MaxSegSiz 10u 0
D D2InzSndSeqNb 10u 0
D D2InzRcvSeqNb 10u 0
D D2CnnTspLayer 10u 0
D D2TcpState 10u 0
D D2CnnOpnTyp 10u 0
D D2IdlTimMs 10u 0
D D2IpOpt 40a
D D2BytIn 10u 0
D D2BytOut 10u 0
D D2SocState 10u 0
D D2SocLstOfs 10u 0
D D2SocEntNbr 10u 0
D D2SocEntLen 10u 0
D D2JobLstOfs 10u 0
D D2JobEntNbr 10u 0
D D2JobEntLen 10u 0
**-- Following fields were added in V5R2 - do not reference in V5R1:
D D2AscUsrPrf 10a
D 2a
**-- Socket options list:
D SocOptLst Ds Based( pSocOptLst )
D SoSocOpt 10u 0
D SoOptVal 10u 0
**-- Associated jobs/tasks list:
D JobCnnLst Ds Based( pJobCnnLst )
D JcFmtEnt 10u 0
D JcTskNam 16a
D JcJobNam 10a
D JcJobUsr 10a
D JcJobNbr 6a
D JcJobId 16a
**-- Create user space: -------------------------------------------------**
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D CsSpcNamQ 20a Const
D CsExtAtr 10a Const
D CsInzSiz 10i 0 Const
D CsInzVal 1a Const
D CsPubAut 10a Const
D CsText 50a Const
**-- Optional 1:
D CsReplace 10a Const Options( *NoPass )
D CsError 32767a Options( *NoPass: *VarSize )
**-- Optional 2:
D CsDomain 10a Const Options( *NoPass )
**-- Delete user space: -------------------------------------------------**
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- Retrieve pointer to user space: ------------------------------------**
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**-- Retrieve TCP/IP attributes: ---------------------------------------**
D RtvTcpA Pr ExtProc( 'QtocRtvTCPA' )
D RtRcvVar 32767a Options( *VarSize )
D RtRcvVarLen 10i 0 Const
D RtFmtNam 8a Const
D RtError 32767a Options( *VarSize )
**-- List network connections: -----------------------------------------**
D LstNetCnn Pr ExtProc( 'QtocLstNetCnn' )
D LcSpcNamQ 20a Const
D LcFmtNam 8a Const
D LcCnnQual 64a Const
D LcCnnQualSiz 10i 0 Const
D LcCnnQualFmt 8a Const
D LcError 32767a Options( *VarSize )
**-- Retrieve network connection data: ---------------------------------**
D RtvCnnDta Pr ExtProc( 'QtocRtvNetCnnDta' )
D RcRcvVar 65535a Options( *VarSize )
D RcRcvVarLen 10i 0 Const
D RcFmtNam 8a Const
D RcSocCnnRqs 20a Const
D RcError 32767a Options( *VarSize )
**
**-- Mainline: ---------------------------------------------------------**
**
C Time Time
C Except Header
**
C CallP RtvTcpA( TCPA0100
C : %Size( TCPA0100 )
C : 'TCPA0100'
C : ApiError
C )
**
C Select
C When AeBytAvl > *Zero
**-- Error occurred...
C Except NoStack
**
C When T1StkSts = 0 Or
C T1StkSts = 2
**-- TCP/IP stack not operational...
C Except NoStack
**
C Other
C Eval BytAlc = 32767
C Eval pCnnDta = %Alloc( BytAlc )
**
C CallP CrtUsrSpc( UsrSpc
C : *Blanks
C : 65535
C : x'00'
C : '*CHANGE'
C : *Blanks
C : '*YES'
C : ApiError
C )
**
C CallP LstNetCnn( UsrSpc
C : 'NCNN0100'
C : NCLQ0100
C : %Size( NCLQ0100 )
C : 'NCLQ0100'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C ExSr PrcLstEnt
C EndIf
**
C CallP DltUsrSpc( UsrSpc
C : ApiError
C )
**
C DeAlloc pCnnDta
**
C If NbrRcds = *Zero
C Except NoRcds
C EndIf
C EndSl
**
C Eval *InLr = *On
C Return
**
**-- Process list entries: ---------------------------------------------**
C PrcLstEnt BegSr
**
C CallP RtvPtrSpc( UsrSpc
C : pUsrSpc
C )
**
C Eval pHdrInf = pUsrSpc + UsOfsHdr
C Eval pLstEnt = pUsrSpc + UsOfsLst
**
C For Lix = 1 to UsNumLstEnt
**
C ExSr PrtCnnDtl
**
C Select
C When C1NetCnnTyp = '*TCP'
C Eval ScProtocol = 1
**
C When C1NetCnnTyp = '*UDP'
C Eval ScProtocol = 2
**
C Other
C Eval ScProtocol = 0
C EndSl
C
C If ScProtocol > 0
**
C Eval ScLocIpAdr = C1LocAdrBin
C Eval ScLocPortNbr= C1LocPort
C Eval ScRmtIpAdr = C1RmtAdrBin
C Eval ScRmtPortNbr= C1RmtPort
**
C DoU D1BytAvl <= BytAlc
**
C If D1BytAvl > BytAlc
C Eval BytAlc = D1BytAvl
C Eval pCnnDta = %ReAlloc( pCnnDta: BytAlc )
C EndIf
**
C CallP RtvCnnDta( NCND0100
C : BytAlc
C : 'NCND0200'
C : SocCnnRqs
C : ApiError
C )
C EndDo
**
C If AeBytAvl = *Zero
C ExSr PrcDtaEnt
C EndIf
C EndIf
**
C If Lix < UsNumLstEnt
C Eval pLstEnt = pLstEnt + UsSizLstEnt
C EndIf
C EndFor
**
C EndSr
**-- Process data list entries: ----------------------------------------**
C PrcDtaEnt BegSr
**
C Eval pCnnDtaInf = pCnnDta + D1AddInfOfs
**
**-- Socket options:
C Eval pSocOptLst = pCnnDta + D2SocLstOfs
C For Dix = 1 to D2SocEntNbr
**
**--
C If Dix < D2SocEntNbr
C Eval pSocOptLst = pSocOptLst + D2SocEntLen
C EndIf
C EndFor
**
**-- Associated jobs:
C Eval pJobCnnLst = pCnnDta + D2JobLstOfs
**
C For Dix = 1 to D2JobEntNbr
**
C If JcFmtEnt = 1
C ExSr PrtJobDtl
C EndIf
**
C If Dix < D2JobEntNbr
C Eval pJobCnnLst = pJobCnnLst + D2JobEntLen
C EndIf
C EndFor
**
C EndSr
**-- Print connection detail line: -------------------------------------**
C PrtCnnDtl BegSr
**
C If PlCurLin > PlOvfLin - 3
C Except Header
C EndIf
**
C Eval TcpCnnStt = TcpStt(C1TcpState + 1)
C Eval ConOpnTyp = OpnTyp(C1ConOpnTyp + 1)
**
C Eval NbrRcds = NbrRcds + 1
C Except CnnDtl
**
C EndSr
**-- Print connection job detail line: ---------------------------------**
C PrtJobDtl BegSr
**
C If PlCurLin > PlOvfLin - 2
C Except Header
C EndIf
**
C Except JobDtl
**
C EndSr
**-- Print file definition: --------------------------------------------**
OQSYSPRT EF Header 2 3
O UDATE Y 8
O Time 18 ' : : '
O 75 'Print TCP/IP connection -
O status'
O 107 'Program:'
O PsPgmNam 118
O 126 'Page:'
O PAGE + 1
OQSYSPRT EF Header 1
O 14 'Remote address'
O 25 '- Port'
O 40 'Local address'
O 52 '- Port'
O 58 'Type'
O 70 'Open'
O 76 'State'
O 90 'Idle time ms'
O 111 'Bytes in'
O 132 'Bytes out'
**
OQSYSPRT EF CnnDtl 1
O C1RmtAdr 15
O C1RmtPort 3 25
O C1LocAdr 42
O C1LocPort 3 52
O C1NetCnnTyp 64
O ConOpnTyp 69
O TcpCnnStt 76
O C1IdlTimMs 3 90
O C1BytIn 3 111
O C1BytOut 3 132
**
OQSYSPRT EF JobDtl 1
O 22 'Connection job name:'
O JcJobNam 33
O 41 '- user:'
O JcJobUsr 52
O 61 '- number:'
O JcJobNbr 68
**
OQSYSPRT EF NoStack 1
O 26 '(TCP/IP stack not active)'
OQSYSPRT EF NoRcds 1
O 26 '(No entries found)'
Thanks to Carsten Flensburg
|
|
Back
TCP/IP management APIs (2)
**
** Description : Print TCP/IP interface status
**
** Program summary
** ---------------
**
** Object - User space APIs:
** QUSCRTUS Create user space Creates a user space in either
** user domain or system domain.
** Only user domain user spaces are
** accessible by the user space APIs.
**
** QUSDLTUS Delete user space Deletes the user space specified.
**
** QUSPTRUS Retrieve pointer to The address of the first byte
** user space of the storage allocated by the
** user space requested is returned.
**
**
** Communication - TCP/IP management APIs:
** QtocRtvTCPA Retrieve TCP/IP Retrieves TCP/IPv4 and TCP/IPv6
** attributes (V5R2) stack attributes.
**
** QtocLstNetIfc List network Returns a detailed list of all
** interfaces logical TCP/IP interfaces.
**
**
**
** Sequence of events:
** 1. The current operational status of the TCP/IP stack is retrieved
** to ensure that TCP/IP connection information is available.
**
** 2. A user space is created and a list of the logical TCP/IP network
** interfaces is loaded to the user space.
**
** 3. For each TCP/IP network interface retrieved from user space a
** report line is printed.
**
** 4. Finally the user space is deleted and the program is terminated.
**
**
** Programmer's notes:
** Earliest release program will run: V5R1
**
** The examples here are all retrieving information about TCP/IPv4
** stacks and connections. As of V5R2 new API formats are available
** for retrieval of similar TCP/IPv6 stack and interface information.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX1061 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX1061 )
** Module( CBX1061 )
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Printer file: -----------------------------------------------------**
FQSYSPRT O F 132 Printer InfDs( PrtLinInf ) OflInd( *InOf )
**-- Printer file information: -----------------------------------------**
D PrtLinInf Ds
D PlOvfLin 5i 0 Overlay( PrtLinInf: 188 )
D PlCurLin 5i 0 Overlay( PrtLinInf: 367 )
D PlCurPag 5i 0 Overlay( PrtLinInf: 369 )
**-- System information: -----------------------------------------------**
D SDs
D PsPgmNam *Proc
**-- Global declarations: ----------------------------------------------**
D Lix s 10u 0
D PxUsrSpc c 'LSTNETIFC QTEMP'
**
D Time s 6s 0
D NbrRcds s 10u 0
D TcpIfcSts s 9a
D IfcLinTyp s 7a
**-- Interface status table: -------------------------------------------**
D StsTbl Ds
D IfcSts 9a Dim( 9 )
D 81a Overlay( StsTbl )
D Inz( 'Inactive Active Starting +
D Ending RCYPND RCYCNL +
D Failed Failed-T DOD ' )
**-- Interface line type table: ----------------------------------------**
D TypTbl Ds
D LinTyp 7a Dim( 15 )
D 105a Overlay( TypTbl )
D Inz( 'NOTFND ERROR NONE OTHER +
D n/a ELAN TRLAN FR +
D ASYNC PPP WLS X.25 +
D DDI TDLC L2TP ' )
**-- Api error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**-- API Header information: -------------------------------------------**
D HdrInf Ds Based( pHdrInf )
D HiUsrSpcNamSp 10a
D HiUsrSpcLibSp 10a
**-- User space generic header: ---------- -----------------------------**
D UsrSpc Ds Based( pUsrSpc )
D UsOfsHdr 10i 0 Overlay( UsrSpc: 117 )
D UsOfsLst 10i 0 Overlay( UsrSpc: 125 )
D UsNumLstEnt 10i 0 Overlay( UsrSpc: 133 )
D UsSizLstEnt 10i 0 Overlay( UsrSpc: 137 )
**-- User space pointers: ----------------------------------------------**
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- TCP/IP attributes: ------------------------------------------------**
D TCPA0100 Ds
D T1BytRtn 10u 0
D T1BytAvl 10u 0
D T1StkSts 10u 0
D T1ActTim 10u 0
D T1LstStrD 8a
D T1LstStrT 6a
D T1LstEndD 8a
D T1LstEndT 6a
D T1StrJob 10a
D T1StrUsr 10a
D T1StrNbr 6a
D T1StrJobInt 16a
D T1EndJob 10a
D T1EndUsr 10a
D T1EndNbr 6a
D T1EndJobInt 16a
D T1OfsAddInf 10u 0
D T1LenAddInf 10u 0
**-- Interface list entry: ---------------------------------------------**
D NIFC0100 Ds Based( pLstEnt )
D I1IntAdr 15a
D 1a
D I1IntAdrB 10u 0
D I1NetAdr 15a
D 1a
D I1NetAdrB 10u 0
D I1NetName 10a
D I1LinD 10a
D I1IfcName 10a
D 2a
D I1IfcSts 10u 0
D I1IfcTypSrv 10i 0
D I1IfcMtu 10i 0
D I1IfcLinTyp 10i 0
D I1HostAdr 15a
D 1a
D I1HostAdrB 10u 0
D I1IfcSubMsk 15a
D 1a
D I1IfcSubMskB 10u 0
D I1DirBdcAdr 15a
D 1a
D I1DirBdcAdrB 10u 0
D I1ChgDat 8a
D I1ChgTim 6a
D I1AstLocIfc 15a
D 3a
D I1AstLocIfcB 10u 0
D I1ChgSts 10u 0
D I1PckRul 10i 0
D I1AutStr 10u 0
D I1TrlBitSeq 10u 0
D I1IfcTyp 10u 0
D I1PrxArpEnb 10u 0
D I1PrxArpAlw 10u 0
D I1CfgMtu 10i 0
**-- Following fields were added in V5R2 - do not reference in V5R1:
D I1NetNameF 24a
D I1IfcNameF 24a
**-- Create user space: -------------------------------------------------**
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D CsSpcNamQ 20a Const
D CsExtAtr 10a Const
D CsInzSiz 10i 0 Const
D CsInzVal 1a Const
D CsPubAut 10a Const
D CsText 50a Const
**-- Optional 1:
D CsReplace 10a Const Options( *NoPass )
D CsError 32767a Options( *NoPass: *VarSize )
**-- Optional 2:
D CsDomain 10a Const Options( *NoPass )
**-- Delete user space: -------------------------------------------------**
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- Retrieve pointer to user space: ------------------------------------**
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**-- Retrieve TCP/IP attributes: ---------------------------------------**
D RtvTcpA Pr ExtProc( 'QtocRtvTCPA' )
D RtRcvVar 32767a Options( *VarSize )
D RtRcvVarLen 10i 0 Const
D RtFmtNam 8a Const
D RtError 32767a Options( *VarSize )
**-- List network interfaces: ------------------------------------------**
D LstNetIfc Pr ExtProc( 'QtocLstNetIfc' )
D LiSpcNamQ 20a Const
D LiFmtNam 8a Const
D LiError 32767a Options( *VarSize )
**
**-- Mainline: ---------------------------------------------------------**
**
C Time Time
C Except Header
**
C CallP RtvTcpA( TCPA0100
C : %Size( TCPA0100 )
C : 'TCPA0100'
C : ApiError
C )
**
C Select
C When AeBytAvl > *Zero
**-- Error occurred...
C Except NoStack
**
C When T1StkSts = 0 Or
C T1StkSts = 2
**-- TCP/IP stack not operational...
C Except NoStack
**
C Other
**
C CallP CrtUsrSpc( PxUsrSpc
C : *Blanks
C : 65535
C : x'00'
C : '*CHANGE'
C : *Blanks
C : '*YES'
C : ApiError
C )
**
C CallP LstNetIfc( PxUsrSpc
C : 'NIFC0100'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C ExSr PrcLstEnt
C EndIf
**
C CallP DltUsrSpc( PxUsrSpc
C : ApiError
C )
**
C If NbrRcds = *Zero
C Except NoRcds
C EndIf
C EndSl
**
C Eval *InLr = *On
C Return
**
**-- Process list entries: ---------------------------------------------**
C PrcLstEnt BegSr
**
C CallP RtvPtrSpc( PxUsrSpc
C : pUsrSpc
C )
**
C Eval pHdrInf = pUsrSpc + UsOfsHdr
C Eval pLstEnt = pUsrSpc + UsOfsLst
**
C For Lix = 1 to UsNumLstEnt
**
C ExSr PrtIfcDtl
**
C If Lix < UsNumLstEnt
C Eval pLstEnt = pLstEnt + UsSizLstEnt
C EndIf
C EndFor
**
C EndSr
**-- Print interface detail line: --------------------------------------**
C PrtIfcDtl BegSr
**
C If PlCurLin > PlOvfLin - 3
C Except Header
C EndIf
**
C Eval TcpIfcSts = IfcSts(I1IfcSts + 1)
C Eval IfcLinTyp = LinTyp(I1IfcLinTyp + 5)
**
C Eval NbrRcds = NbrRcds + 1
C Except IfcDtl
**
C EndSr
**-- Print file definition: --------------------------------------------**
OQSYSPRT EF Header 2 3
O UDATE Y 8
O Time 18 ' : : '
O 75 'Print TCP/IP interface -
O status'
O 107 'Program:'
O PsPgmNam 118
O 126 'Page:'
O PAGE + 1
OQSYSPRT EF Header 1
O 16 'Internet address'
O 29 'Subnet mask'
O 50 'Network address'
O 64 'Host address'
O 72 'Line'
O 84 '-type'
O 96 'Interface'
O 106 '-status'
O 118 'MTU'
**
OQSYSPRT EF IfcDtl 1
O I1IntAdr 15
O I1IfcSubMsk 33
O I1NetAdr 50
O I1HostAdr 67
O I1LinD 78
O IfcLinTyp 86
O I1IfcName 97
O TcpIfcSts 108
O I1IfcMtu 3 118
**
OQSYSPRT EF NoStack 1
O 26 '(TCP/IP stack not active)'
OQSYSPRT EF NoRcds 1
O 26 '(No entries found)'
Thanks to Carsten Flensburg
|
|
Back
TCP/IP management APIs (3)
**
** Description : Print TCP/IP network routes
**
** Program summary
** ---------------
**
** Object - User space APIs:
** QUSCRTUS Create user space Creates a user space in either
** user domain or system domain.
** Only user domain user spaces are
** accessible by the user space APIs.
**
** QUSDLTUS Delete user space Deletes the user space specified.
**
** QUSPTRUS Retrieve pointer to The address of the first byte
** user space of the storage allocated by the
** user space requested is returned.
**
**
** Communication - TCP/IP management APIs:
** QtocRtvTCPA Retrieve TCP/IP Retrieves TCP/IPv4 and TCP/IPv6
** attributes (V5R2) stack attributes.
**
** QtocLstNetRte List network Returns a detailed list of all
** routes network routes.
**
**
**
** Sequence of events:
** 1. The current operational status of the TCP/IP stack is retrieved
** to ensure that TCP/IP connection information is available.
**
** 2. A user space is created and a list of the TCP/IP network routes
** is loaded to the user space.
**
** 3. For each TCP/IP network route retrieved from user space a report
** line is printed.
**
** 4. Finally the user space is deleted and the program is terminated.
**
**
** Programmer's notes:
** Earliest release program will run: V5R1
**
** According to the API documentation there are 5 route types (0-4)
** and route type 2 maps to HOST. It turns out that ICMP added host
** routes are given route type 5 and therefore an extra HOST entry
** in the mapping table is necessary to ensure a correct result.
**
** The examples here are all retrieving information about TCP/IPv4
** stacks and connections. As of V5R2 new API formats are available
** for retrieval of similar TCP/IPv6 stack and route information.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX1062 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX1062 )
** Module( CBX1062 )
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Printer file: -----------------------------------------------------**
FQSYSPRT O F 132 Printer InfDs( PrtLinInf ) OflInd( *InOf )
**-- Printer file information: -----------------------------------------**
D PrtLinInf Ds
D PlOvfLin 5i 0 Overlay( PrtLinInf: 188 )
D PlCurLin 5i 0 Overlay( PrtLinInf: 367 )
D PlCurPag 5i 0 Overlay( PrtLinInf: 369 )
**-- System information: -----------------------------------------------**
D SDs
D PsPgmNam *Proc
**-- Global declarations: ----------------------------------------------**
D Lix s 10u 0
D PxUsrSpc c 'LSTNETRTE QTEMP'
**
D Time s 6s 0
D NbrRcds s 10u 0
D TcpRteTyp s 7a
D TcpRteSrc s 6a
D TcpRteSts s 7a
**-- Route type table: -------------------------------------------------**
D RteTbl Ds
D RteTyp 7a Dim( 6 )
D 42a Overlay( RteTbl )
D Inz( 'DFTRTE DIRECT HOST SUBNET +
D NET HOST ' )
**-- Route source table: -----------------------------------------------**
D SrcTbl Ds
D RteSrc 6a Dim( 5 )
D 30a Overlay( SrcTbl )
D Inz( 'OTHER CFG ICMP SNMP RIP' )
**-- Route status table: -----------------------------------------------**
D StsTbl Ds
D RteSts 7a Dim( 5 )
D 35a Overlay( StsTbl )
D Inz( 'YES NO DOD NO GATE' )
**-- Api error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**-- API Header information: -------------------------------------------**
D HdrInf Ds Based( pHdrInf )
D HiUsrSpcNamSp 10a
D HiUsrSpcLibSp 10a
**-- User space generic header: ---------- -----------------------------**
D UsrSpc Ds Based( pUsrSpc )
D UsOfsHdr 10i 0 Overlay( UsrSpc: 117 )
D UsOfsLst 10i 0 Overlay( UsrSpc: 125 )
D UsNumLstEnt 10i 0 Overlay( UsrSpc: 133 )
D UsSizLstEnt 10i 0 Overlay( UsrSpc: 137 )
**-- User space pointers: ----------------------------------------------**
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- TCP/IP attributes: ------------------------------------------------**
D TCPA0100 Ds
D T1BytRtn 10u 0
D T1BytAvl 10u 0
D T1StkSts 10u 0
D T1ActTim 10u 0
D T1LstStrD 8a
D T1LstStrT 6a
D T1LstEndD 8a
D T1LstEndT 6a
D T1StrJob 10a
D T1StrUsr 10a
D T1StrNbr 6a
D T1StrJobInt 16a
D T1EndJob 10a
D T1EndUsr 10a
D T1EndNbr 6a
D T1EndJobInt 16a
D T1OfsAddInf 10u 0
D T1LenAddInf 10u 0
**-- Route list entry: -------------------------------------------------**
D NRTE0100 Ds Based( pLstEnt )
D R1RteDst 15a
D 1a
D R1RteDstB 10u 0
D R1SubMsk 15a
D 1a
D R1SubMskB 10u 0
D R1NxtHop 15a
D 1a
D R1NxtHopB 10u 0
D R1RteSts 10u 0
D R1TypSrv 10i 0
D R1RteMtu 10i 0
D R1RteTyp 10u 0
D R1RteSrc 10i 0
D R1RtePcd 10u 0
D R1LocBndIfcSt 10u 0
D R1LocBndTyp 10u 0
D R1LocBndLinTp 10i 0
D R1LocBndIfc 15a
D 1a
D R1LocBndIfcB 10u 0
D R1LocSubMsk 15a
D 1a
D R1LocSubMskB 10u 0
D R1LocNetAdr 15a
D 1a
D R1LocNetAdrB 10u 0
D R1LocBndLinD 10a
D R1ChgDat 8a
D R1ChgTim 6a
**-- Create user space: -------------------------------------------------**
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D CsSpcNamQ 20a Const
D CsExtAtr 10a Const
D CsInzSiz 10i 0 Const
D CsInzVal 1a Const
D CsPubAut 10a Const
D CsText 50a Const
**-- Optional 1:
D CsReplace 10a Const Options( *NoPass )
D CsError 32767a Options( *NoPass: *VarSize )
**-- Optional 2:
D CsDomain 10a Const Options( *NoPass )
**-- Delete user space: -------------------------------------------------**
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- Retrieve pointer to user space: ------------------------------------**
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**-- Retrieve TCP/IP attributes: ---------------------------------------**
D RtvTcpA Pr ExtProc( 'QtocRtvTCPA' )
D RtRcvVar 32767a Options( *VarSize )
D RtRcvVarLen 10i 0 Const
D RtFmtNam 8a Const
D RtError 32767a Options( *VarSize )
**-- List network routes: ----------------------------------------------**
D LstNetRte Pr ExtProc( 'QtocLstNetRte' )
D LiSpcNamQ 20a Const
D LiFmtNam 8a Const
D LiError 32767a Options( *VarSize )
**
**-- Mainline: ---------------------------------------------------------**
**
C Time Time
C Except Header
**
C CallP RtvTcpA( TCPA0100
C : %Size( TCPA0100 )
C : 'TCPA0100'
C : ApiError
C )
**
C Select
C When AeBytAvl > *Zero
**-- Error occurred...
C Except NoStack
**
C When T1StkSts = 0 Or
C T1StkSts = 2
**-- TCP/IP stack not operational...
C Except NoStack
**
C Other
C CallP CrtUsrSpc( PxUsrSpc
C : *Blanks
C : 65535
C : x'00'
C : '*CHANGE'
C : *Blanks
C : '*YES'
C : ApiError
C )
**
C CallP LstNetRte( PxUsrSpc
C : 'NRTE0100'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C ExSr PrcLstEnt
C EndIf
**
C CallP DltUsrSpc( PxUsrSpc
C : ApiError
C )
**
C If NbrRcds = *Zero
C Except NoRcds
C EndIf
C EndSl
**
C Eval *InLr = *On
C Return
**
**-- Process list entries: ---------------------------------------------**
C PrcLstEnt BegSr
**
C CallP RtvPtrSpc( PxUsrSpc
C : pUsrSpc
C )
**
C Eval pHdrInf = pUsrSpc + UsOfsHdr
C Eval pLstEnt = pUsrSpc + UsOfsLst
**
C For Lix = 1 to UsNumLstEnt
**
C ExSr PrtRteDtl
**
C If Lix < UsNumLstEnt
C Eval pLstEnt = pLstEnt + UsSizLstEnt
C EndIf
C EndFor
**
C EndSr
**-- Print route detail line: ------------------------------------------**
C PrtRteDtl BegSr
**
C If PlCurLin > PlOvfLin - 3
C Except Header
C EndIf
**
C Eval TcpRteTyp = RteTyp(R1RteTyp + 1)
C Eval TcpRteSrc = RteSrc(R1RteSrc + 2)
C Eval TcpRteSts = RteSts(R1RteSts)
**
C Eval NbrRcds = NbrRcds + 1
C Except RteDtl
**
C EndSr
**-- Print file definition: --------------------------------------------**
OQSYSPRT EF Header 2 3
O UDATE Y 8
O Time 18 ' : : '
O 75 'Print TCP/IP network -
O routes'
O 107 'Program:'
O PsPgmNam 118
O 126 'Page:'
O PAGE + 1
OQSYSPRT EF Header 1
O 17 'Route destination'
O 30 'Subnet mask'
O 46 'Next hop'
O 65 'Route type'
O 74 '-source'
O 83 '-status'
O 96 'MTU'
O 111 'Change date'
O 118 '-time'
**
OQSYSPRT EF RteDtl 1
O R1RteDst 15
O R1SubMsk 34
O R1NxtHop 53
O TcpRteTyp 62
O TcpRteSrc 73
O TcpRteSts 83
O R1RteMtu 3 96
O R1ChgDat 110
O R1ChgTim 119
**
OQSYSPRT EF NoStack 1
O 26 '(TCP/IP stack not active)'
OQSYSPRT EF NoRcds 1
O 26 '(No entries found)'
Thanks to Carsten Flensburg
|
|
Back
List configuration descriptions & Search hardware resource entry
** Program : CBX101
** Description : Returns the name of the line currently holding the ECS modem
**
** Program summary
** ---------------
**
** Configuration API:
** QDCLCFGD List configuration Returns a list of configuration
** descriptions descriptions based on type as
** well as selection criterias such
** as status and category.
**
** User space APIs:
** QUSCRTUS Create user space Creates a user space.
**
** QUSPTRUS Retrieve pointer to Returns a pointer to the contents
** user space of a user space. The data pointed
** to can be directly modified by
** the program obtaining the pointer.
**
** QUSDLTUS Delete user space Deletes a user space.
**
** Message handling API:
** QMHSNDPM Send program message Sends a message to a program stack
** entry (current, previous, etc.) or
** the joblog.
**
** Hardware resource API:
** QRZSCHE Search hardware Searches the hardware resources
** resource entry for entries matching the request
** criteria(s) in the form of key
** values. Upon a succesful search
** the first or next resource name
** found is returned.
**
** Sequence of events:
** 1. Create user space
**
** 2. List configuration description(s) selected
** based on the return value from the GetEscRsc()
** procedure to user space
**
** 3. Retrieve the configuration description(s)
** one by one.
**
** 4. Send completion message to inform caller
** what line - if any - is currently allocating
** the ECS resource.
**
** 5. Delete user space.
**
**
** GetEscRsc() parameters:
** Return- OUTPUT The name of electronic-customer-support
** value communications resource is returned.
**
** If no matching entry was found or an error
** occurred blanks are returned to the caller.
**
** NOTE: The resource name that is returned is
** for the first port on the I/O adapter
** in card position B of the first multi-
** multifunction IOP on the bus.
**
** If both SDLC lines for the original ECS
** modem and a PPP line for the iSeries Uni-
** versal Connection for Electronic Support
** and Service are configured for the adapter
** the first resource name is returned.
**
** Run the command WRKHDWRSC TYPE(*CMN) and
** specify option 5 to find out which lines
** are configured for the specified resource.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX101 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX101 )
** Module( CBX101 )
**-- Control spec: -----------------------------------------------------**
H Option( *SrcStmt )
**-- API Error Data Structure: -----------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
**-- Global variables: -------------------------------------------------**
D MsgKey s 4a
**-- Create User Space Parameter: --------------------------------------**
D CuUsrSpcQ Ds
D CuUsrSpcNam 10 Inz( 'CFGLST ' )
D CuUsrSpcLib 10 Inz( 'QTEMP ' )
**-- API format CFGD0200: List information: ----------------------------**
D CfgLst200 Ds Based( pLstEnt )
D C2CurStsNam 10i 0
D C2CfgDscNam 10a
D C2CfgDscCat 10a
D C2CurStsTxt 20a
D C2TxtDsc 50a
D C2JobNam 10a
D C2JobUsr 10a
D C2JobNbr 6a
D C2PasTdev 10a
D C2RtvApiNam 8a
D C2CfgCmdSfx 4a
**-- API format CFGD0200: Header information: --------------------------**
D HdrInf Ds Based( pHdrInf )
D ClCfgTypU 10a
D ClObjQualU 40a
D ClStsQualU 20a
D 2a
D ClUspNamU 10a
D ClUspLibU 10a
**-- User Space Generic Header: ---------- -----------------------------**
D UsrSpc Ds Based( pUsrSpc )
D UsOfsHdr 10i 0 Overlay( UsrSpc: 117 )
D UsOfsLst 10i 0 Overlay( UsrSpc: 125 )
D UsNumLstEnt 10i 0 Overlay( UsrSpc: 133 )
D UsSizLstEnt 10i 0 Overlay( UsrSpc: 137 )
**-- Pointers: ---------------------------------------------------------**
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- Get ECS resource: -------------------------------------------------**
D GetEcsRsc Pr 32a
**-- Search hardware resource entry: ------------------------------------**
D SchHdwRscE Pr ExtPgm( 'QRZSCHE' )
D ShRscNam 32a
D ShRscCri 60a Const
D ShError 32767a Options( *VarSize )
**-- List configuration descriptions: ----------------------------------**
D LstCfgDsc Pr ExtPgm( 'QDCLCFGD' )
D LcSpcNamQ 20a Const
D LcFmtNam 8a Const
D LcCfgDscTyp 10a Const
D LcObjQual 40a Const
D LcStsQual 20a Const
D LcError 32767a Options( *NoPass: *VarSize )
**-- Create user space: -------------------------------------------------**
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D CsSpcNamQ 20a Const
D CsExtAtr 10a Const
D CsInzSiz 10i 0 Const
D CsInzVal 1a Const
D CsPubAut 10a Const
D CsText 50a Const
**-- Optional 1:
D CsReplace 10a Const Options( *NoPass )
D CsError 32767a Options( *NoPass: *VarSize )
**-- Optional 2:
D CsDomain 10a Const Options( *NoPass )
**-- Retrieve pointer to user space: ------------------------------------**
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**-- Delete user space: -------------------------------------------------**
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- Send program message: ---------------------------------------------**
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D SpMsgId 7a Const
D SpMsgFq 20a Const
D SpMsgDta 512a Const Options( *VarSize )
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 512a Options( *VarSize )
**
D SpCalStkElen 10i 0 Const Options( *NoPass )
D SpCalStkEq 20a Const Options( *NoPass )
D SpDspWait 10i 0 Const Options( *NoPass )
**
D SpCalStkEtyp 20a Const Options( *NoPass )
D SpCcsId 10i 0 Const Options( *NoPass )
**-- Send completion message: ------------------------------------------**
D SndCmpMsg Pr 10i 0
D PxMsgId 10a Const
D PxMsgF 10a Const
D PxMsgFlib 10a Const
D PxMsgDta 512a Const Varying
**-----------------------------------------------------------------------**
**
C CallP CrtUsrSpc( CuUsrSpcQ
C : *Blanks
C : 65535
C : x'00'
C : '*CHANGE'
C : *Blanks
C : '*YES'
C : ApiError
C )
**
C CallP LstCfgDsc( CuUsrSpcQ
C : 'CFGD0200'
C : '*LIND'
C : '*RSRC ' + GetEcsRsc()
C : '*GE *VARYON'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C CallP RtvPtrSpc( CuUsrSpcQ
C : pUsrSpc
C )
**
C ExSr GetCfgDsc
C EndIf
**
C CallP DltUsrSpc( CuUsrSpcQ
C : ApiError
C )
**
C Return
**
**-- Get Configuration Description: ------------------------------------**
C GetCfgDsc BegSr
**
C Eval pHdrInf = pUsrSpc + UsOfsHdr
**
C If UsNumLstEnt = *Zero
C ExSr RscVacMsg
**
C Else
C Eval pLstEnt = pUsrSpc + UsOfsLst
C Do UsNumLstEnt
**
C ExSr PrcLstEnt
C Eval pLstEnt = pLstEnt + UsSizLstEnt
C EndDo
C EndIf
**
C EndSr
**-- Ressource vacant message: -----------------------------------------**
C RscVacMsg BegSr
**
C CallP SndCmpMsg( 'CPF9897'
C : 'QCPFMSG'
C : '*LIBL'
C : 'No lines currently allocating +
C ECS resource.'
C )
**
C EndSr
**-- Process List Entry: -----------------------------------------------**
C PrcLstEnt BegSr
**
C CallP SndCmpMsg( 'CPF9897'
C : 'QCPFMSG'
C : '*LIBL'
C : 'Line ' +
C %TrimR( C2CfgDscNam ) + ' (' +
C %TrimR( C2TxtDsc ) + ')' +
C ' is currently ' +
C %TrimR( C2CurStsTxt ) +
C '.'
C )
**
C EndSr
**-- Get ECS resource: -------------------------------------------------**
P GetEcsRsc B Export
D Pi 32a
**-- API parameters:
D ShRscCri Ds
D ScStcLen 10i 0 Inz( %Len( ShRscCri ))
D ScOfsRcd 10i 0 Inz( 37 )
D ScNbrRcd 10i 0 Inz( 1 )
D ScHandle 16a Inz( *Allx'00' )
D ScSchRsc 10i 0 Inz( 1 )
D ScSchRqs 10i 0 Inz( 1 )
D ScRcdStc
D ScRcdLen 10i 0 Inz( -1 )
D Overlay( ScRcdStc: 1 )
D ScKey 10i 0 Inz( 25 )
D Overlay( ScRcdStc: *Next )
D ScDtaLen 10i 0 Inz( 1 )
D Overlay( ScRcdStc: *Next )
D ScDta 10a Overlay( ScRcdStc: *Next )
**
D ShRscNam s 32a
**
C CallP SchHdwRscE( ShRscNam: ShRscCri: ApiError )
**
C If AeBytAvl > *Zero
C Eval ShRscNam = *Blanks
C EndIf
**
C Return ShRscNam
**
P GetEcsRsc E
**-- Send completion message: ------------------------------------------**
P SndCmpMsg B
D Pi 10i 0
D PxMsgId 10a Const
D PxMsgF 10a Const
D PxMsgFlib 10a Const
D PxMsgDta 512a Const Varying
**
C CallP SndPgmMsg( PxMsgId
C : PxMsgF + PxMsgFlib
C : PxMsgDta
C : %Len( PxMsgDta )
C : '*COMP'
C : '*PGMBDY'
C : 1
C : MsgKey
C : ApiError
C )
**
C If AeBytAvl = *Zero
C Return 0
**
C Else
C Return -1
C EndIf
**
P SndCmpMsg E
Thanks to Carsten Flensburg
|
|
Back
Output Distribution : Retreive Last Spoolfile# for job.
* -- Fields...
d #of@entry s inz like(binary@9)
d #of@keys s inz like(binary@9)
d binary@9 s 9b 0 inz
d blank@10 s 10a inz
d blank@20 s 20a inz
d ccyymmdd s d datfmt(*iso)
d curr@job s 26a inz
d dtl@data s 1000a inz
d format s 8a inz
d lib@pgm s 21a inz
d no c *off
d selected s inz like(*in01)
d start@pos s inz like(binary@9)
d us@extatr s 10a inz('quslspl')
d us@initsiz s inz(2000) like(binary@9)
d us@initval s 1a inz
d us@pubauth s 10a inz('*ALL')
d us@desc s 50a inz('OD@RTVSP# Temporary User Space')
d us@replace s 10a inz('*YES')
d usrspc@len s inz like(binary@9)
d x s 9b 0 inz
d y s 9b 0 inz
d z s 9b 0 inz
d yes c *on
* -- Data Structures....
d holdInfo ds
d hold@job 10a inz
d hold@user 10a inz
d hold@job# 6a inz
d hold@prtf 10a inz
d hold@splf# 4s 0 inz
d hold@sts 10a inz
* ---- Character/Numeric conversion...
d character ds
d numeric 1 4b 0 inz
* ---- User Space Name...
d user@space ds
d usrspc@nam 10a inz('OD@RTVSPF#')
d usrspc@lib 10a inz('QTEMP')
* ---- Requested Spooled File keys...
d splf@keys ds
d splf@key1 1 4b 0 inz(201)
d splf@key2 5 8b 0 inz(202)
d splf@key3 9 12b 0 inz(203)
d splf@key4 13 16b 0 inz(204)
d splf@key5 17 20b 0 inz(205)
d splf@key6 21 24b 0 inz(210)
* ---- Edit API Error Data Structure...
d api@err@ds ds inz
d bytes@rsvd 1 4b 0 inz(%size(api@err@ds))
d bytes@aval 5 8b 0 inz
d api@msgid# 9 15a inz
d api@rsvrd 16 16a inz
d api@errmsg 17 116a inz
* -- Indicators...
d ind@ptr s * inz(%addr(*in))
d ds based(ind@ptr)
d indicators 99
* ---- 01 - 29 : Functions Key indicators...
* ---- 30 - 39 : Random indicators...
* ---- 40 - 49 : Subfile indicators...
* ---- 50 - 89 : Error indicators...
* ---- 90 - 99 : File/Array/Scan indicators..
d recnotfnd 1 overlay(indicators:90)
d endoffile 1 overlay(indicators:99)
* -- Program parameters...
d pgm@parms ds
d out@job 10a
d out@user 10a
d out@job# 6a
d out@prtf 10a
d out@splf# 4s 0
* -- API QUSLSPL data strucure...
/copy qsysinc/qrpglesrc,quslspl
* -- Common User Space data strucure...
/copy qsysinc/qrpglesrc,qusgen
* -- Create User Space API...
c call 'QUSCRTUS'
c parm user@space
c parm us@extatr
c parm us@initsiz
c parm us@initval
c parm us@pubauth
c parm us@desc
c parm us@replace
c parm api@err@ds
* -- List out Job Spooled Files...
c call 'QUSLSPL'
c parm user@space
c parm 'SPLF0200' format
c parm blank@10
c parm blank@20
c parm blank@10
c parm blank@10
c parm api@err@ds
c parm '*' curr@job
c parm splf@keys
c parm 6 #of@keys
* ---- Retrieve User Space Header contents...
c call 'QUSRTVUS'
c parm user@space
c parm 1 start@pos
c parm 192 usrspc@len
c parm qush0100
c parm api@err@ds
* -- Check User Space status for good data...
* ---- Header Format...
c if (qussrl = '0100')
* ---- 'C'omplete or 'P'artial...
c and ((qusis = 'C') or (qusis = 'P'))
* ---- Number of List Entries in User Space is greater than 0..
c and (qusnbrle > 0)
c exsr @retrieve
* ---- If value of HOLD@STS is not *FINISHED, then return SPLF#.
c if hold@sts <> '*FINISHED'
c eval out@job = hold@job
c eval out@user = hold@user
c eval out@job# = hold@job#
c eval out@prtf = hold@prtf
c eval out@splf# = hold@splf#
c endif
c endif
c eval *inlr = *on
*****************************************************************
* Sub-routine : @retrieve *
*****************************************************************
c @retrieve begsr
* -- Maintain the number of List Entrees...
c eval #of@entry = 0
c eval x = qusnbrle
c do qusnbrle
c eval x = x - 1
* -- Adjust the Offset value to *Last Spoolfile value...
c eval start@pos = qusold + 1 +
c (x * qussee)
c clear holdInfo
* -- Retrieve the lesser of allocated storage or available data..
c eval usrspc@len = 1000
c if qussee < 1000
c eval usrspc@len = qussee
c endif
* ---- Retrieve User Space Detail contents...
c call 'QUSRTVUS'
c parm user@space
c parm start@pos
c parm usrspc@len
c parm dtl@data
c parm api@err@ds
* ---- Loop Through returned data...
c eval qusf0200 = %subst(dtl@data:1:4)
c eval z = 5
c do qusnbrfr00
* ------ Retrieve header information...
c eval qussplki = %subst(dtl@data:z:16)
* ------ Set Y to location of actual data associated with key...
c eval y = z + 16
c select
c when quskfffr00 = 201
c eval hold@prtf = %subst(dtl@data:y:qusdl02)
c when quskfffr00 = 202
c eval hold@job = %subst(dtl@data:y:qusdl02)
c when quskfffr00 = 203
c eval hold@user = %subst(dtl@data:y:qusdl02)
c when quskfffr00 = 204
c eval hold@job# = %subst(dtl@data:y:qusdl02)
c when quskfffr00 = 205
c eval character = %subst(dtl@data:y:qusdl02)
c eval hold@splf# = numeric
c when quskfffr00 = 210
c eval hold@sts = %subst(dtl@data:y:qusdl02)
c endsl
* ------ Adjust Z to address next keyed record returned...
c eval z = z + quslfir02
c enddo
* -------- If the status of the report comes back not *FINISHED
* (written or deleted) then exit do-loop..
c if hold@sts <> '*FINISHED'
c leave
c endif
c enddo
c endsr
*****************************************************************
* Sub-routine : *inzsr *
*****************************************************************
c *inzsr begsr
c *entry plist
c parm pgm@parms
c eval out@splf# = 0
c endsr
Thanks to David L Mosley, Jr.
|
|
Back
Set profile exit program & Retrieve profile exit program
CBX107:
/* Description : Set profile exit program command */
/* Program function: SETPRFEXIT command processing program */
/* */
/* Program summary */
/* --------------- */
/* Work management APIs: */
/* QWTSETPX Set profile exit Sets for a user profile */
/* program the exit program to call */
/* defined by the specified */
/* format and the values of */
/* the exit flags. */
/* */
/* QWTRTVPX Retrieve profile Retrieves the values of */
/* exit program the exit flags currently */
/* set for the user profile */
/* and the exit point format */
/* specified. */
/* */
/* Programmer's notes: */
/* Currently supported by the profile exit APIs are the */
/* preattention and presystem request exit points */
/* QIBM_QWT_PREATTNPGMS respectively QIBM_QWT_SYSREQPGMS. */
/* Both are managed through either the WRKREGINF facility */
/* or the ADDEXITPGM and RMVEXITPGM commands. */
/* */
/* */
/* Compile options: */
/* CrtClPgm Pgm( CBX107 ) */
/* SrcFile( QCLSRC ) */
/* SrcMbr( *PGM ) */
/* */
/*-------------------------------------------------------------------*/
Pgm ( &UsrPrf +
&XitFmt +
&XitOpt +
)
/*-- Parameters: ---------------------------------------------------*/
Dcl &UsrPrf *Char 10
Dcl &XitFmt *Char 8
Dcl &XitOpt *Char 34
Dcl &PgmNbr *Char 4 x'00000008'
Dcl &Flags *Char 32
/*-- Global error monitoring: --------------------------------------*/
MonMsg CPF0000 *N GoTo Error
RtvUsrPrf &UsrPrf RtnUsrPrf( &UsrPrf )
ChgVar &Flags %Sst( &XitOpt 3 32 )
Call QWTSETPX ( &PgmNbr +
&Flags +
&XitFmt +
&UsrPrf +
x'00000000' +
)
SndPgmMsg Msg( 'Profile exit programs have been set.' ) +
MsgType( *COMP )
Return:
Return
/*-- Error handling: -----------------------------------------------*/
Error:
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
EndPgm:
EndPgm
CBX1070:
/*-------------------------------------------------------------------*/
/* */
/* Program function: SETPRFEXIT prompt override program */
/* */
/* */
/* Parameters: */
/* CmdNamQ INPUT Qualified command name */
/* */
/* KeyPrm1 INPUT Key parameter indentifying the */
/* user profile to retrieve exit */
/* point information about. */
/* */
/* KeyPrm2 INPUT Key parameter identifying the */
/* format name of the exit point */
/* to retrieve information about. */
/* */
/* CmdStr OUTPUT The formatted command prompt */
/* string returning the current */
/* activation status of the exit */
/* point's registered programs. */
/* */
/* */
/* Compile options: */
/* CrtClPgm Pgm( CBX107O ) */
/* SrcFile( QCLSRC ) */
/* SrcMbr( *PGM ) */
/* */
/* */
/*-------------------------------------------------------------------*/
Pgm ( &CmdNamQ +
&KeyPrm1 +
&KeyPrm2 +
&CmdStr +
)
/*-- Parameters: ---------------------------------------------------*/
Dcl &CmdNamQ *Char 20
Dcl &KeyPrm1 *Char 10
Dcl &KeyPrm2 *Char 8
Dcl &CmdStr *Char 1024
Dcl &RcvVar *Char 40
Dcl &RcvLen *Char 4 x'00000028'
Dcl &Flags *Char 32
Dcl &Value *Char 4
Dcl &PgmFlg *Dec 9
Dcl &NbrEnt *Dec 5
Dcl &OffSet *Dec 5 1
/*-- Global error monitoring: --------------------------------------*/
MonMsg CPF0000 *N GoTo Error
Call QWTRTVPX ( &RcvVar +
&RcvLen +
&KeyPrm2 +
&KeyPrm1 +
x'00000000' )
ChgVar &NbrEnt %Bin( &RcvVar 1 4 )
ChgVar &Flags %Sst( &RcvVar 9 32 )
ChgVar %Sst( &CmdStr 1 2 ) x'0040'
ChgVar %Sst( &CmdStr 3 10 ) '?#EXITPGM('
Next:
ChgVar &PgmFlg %Bin( &Flags &OffSet 4 )
If ( &PgmFlg = 1 ) ChgVar &Value '*ON '
Else ChgVar &Value '*OFF'
ChgVar &CmdStr ( &CmdStr *Bcat &Value )
ChgVar &OffSet ( &OffSet + 4 )
If ( &OffSet < &NbrEnt * 4 ) Do
GoTo Next
EndDo
ChgVar &CmdStr ( &CmdStr *Bcat ')' )
Return:
Return
/*-- Error handling: -----------------------------------------------*/
Error:
SndPgmMsg MsgId( CPF0011 ) MsgF( QCPFMSG ) MsgType( *ESCAPE )
EndPgm:
EndPgm
Pls note: '?#EXITPGM(' .... '#' neeeds to be changed to '<'
CBX107P:
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtPnlGrp PnlGrp( CBX107P )
.* SrcFile( QPNLSRC )
.* SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='SETPRFEXIT'.
Set Profile Exit Program - Help
:P.
The Set Profile Exit command (SETPRFEXIT) activates or deactivates for
the specified user profile, the exit program(s) registered for the exit
point defined by the format parameter.
:P.
The current setting is retrieved for the specified user profile if the
command is prompted prior to execution.
:EHELP.
:HELP NAME='SETPRFEXIT/USRPRF'.
User profile (USRPRF) - Help
:XH3.User profile (USRPRF)
:P.
Specifies the name of the user profile whose exit program setting you
want to change.
:P.
The possible values are:
:PARML.
:PT.:PV.user-name:EPV.
:PD.
The name of the user profile that you want to change the profile exit
program setting for.
:PT.:PK.*CURRENT:EPK.
:PD.
The user profile that is currently running is used.
:EPARML.
:EHELP.
:HELP NAME='SETPRFEXIT/FORMAT'.
Exit program format (FORMAT) - Help
:XH3.Exit program format (FORMAT)
:P.
The format name defines the specific exit program setting to change.
:P.
The possible values are:
:PARML.
:PT.:PK DEF.*SYSRQS:EPK.
:PD.
The presystem request program exit point setting is changed for the
specified user profile.
:PT.:PK.*ATTN:EPK.
:PD.
The preattention program exit point setting is changed for the
specified user profile.
:EPARML.
:EHELP.
:HELP NAME='SETPRFEXIT/EXITPGM'.
Exit program option (EXITPGM) - Help
:XH3.Exit program option (EXITPGM)
:P.
Specifies for the registered exit point programs in the order 1 to 8
if the corresponding exit program should be activated, deactivated or
have it's current setting remain unchanged.
:P.
The possible values are:
:PARML.
:PT.:PK.*SAME:EPK.
:PD.
The current setting remains unchanged for corresponding exit program.
:PT.:PK.*ON:EPK.
:PD.
The corresponding exit program is activated for the specified user
profile.
:PT.:PK.*OFF:EPK.
:PD.
The corresponding exit program is deactivated for the specified user
profile.
:EPARML.
:EHELP.
:EPNLGRP.
CBX107X:
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( SETPRFEXIT ) */
/* Pgm( CBX107 ) */
/* SrcMbr( CBX107X ) */
/* HlpPnlGrp( CBX107P ) */
/* HlpId( *CMD ) */
/* PmtOvrPgm( CBX107O ) */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Set Profile Exit Program' )
Parm USRPRF *Name +
Min( 1 ) +
SpcVal(( *CURRENT )) +
Expr( *YES ) +
Keyparm( *YES ) +
Prompt( 'User profile' )
Parm FORMAT *Char 8 +
Rstd( *YES ) +
Dft( *SYSRQS ) +
SpcVal(( *SYSRQS SREQ0100 ) +
( *ATTN ATTN0100 )) +
Expr( *YES ) +
Keyparm( *YES ) +
Prompt( 'Exit program format' )
Parm EXITPGM E0001 +
Prompt( 'Exit program option' )
E0001: Elem *INT4 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *ON 1 ) ( *OFF 0 ) ( *SAME -1 )) +
Expr( *YES ) +
Prompt( 'Program 1' )
Elem *INT4 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *ON 1 ) ( *OFF 0 ) ( *SAME -1 )) +
Expr(*YES) +
Prompt( 'Program 2' )
Elem *INT4 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *ON 1 ) ( *OFF 0 ) ( *SAME -1 )) +
Expr( *YES ) +
Prompt( 'Program 3' )
Elem *INT4 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *ON 1 ) ( *OFF 0 ) ( *SAME -1 )) +
Expr( *YES ) +
Prompt( 'Program 4' )
Elem *INT4 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *ON 1 ) ( *OFF 0 ) ( *SAME -1 )) +
Expr( *YES ) +
Prompt( 'Program 5' )
Elem *INT4 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *ON 1 ) ( *OFF 0 ) ( *SAME -1 )) +
Expr( *YES ) +
Prompt( 'Program 6' )
Elem *INT4 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *ON 1 ) ( *OFF 0 ) ( *SAME -1 )) +
Expr( *YES ) +
Prompt( 'Program 7' )
Elem *INT4 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *ON 1 ) ( *OFF 0 ) ( *SAME -1 )) +
Expr( *YES ) +
Prompt( 'Program 8' )
Thanks to Carsten Flensburg
|
|
Back
List signed on users
**-- Program description: ----------------------------------------------**
**
** This program will return the number of physical devices that a given
** privileged user profile - user class greater than *USER - is signed
** on to. The user profile name is provided in the first parameter and
** two special values are accepted:
**
** *JOBUSR - the user profile that started the current job.
** *CURUSR - the user profile currently registered as job user.
**
** The number of currently signed on devices for the specified user
** profile is returned in the second parameter. If the specified user
** profile has user class *USER, zero is returned. The user class
** condition can simply be removed in the event that all users are to
** be checked.
**
** Note that certain clients - like Citrix - actually runs on a central
** server, only the screen is sent to the work station. In this case
** the server's IP address will be detected by this program and only
** counted as one and the same work station, regardless of the actual
** number of PC's connected to the server by the specified user profile.
**
**-- Compilation specification: ----------------------------------------**
**
** CrtBndRpg Pgm( 'library'/CBX904 )
** SrcFile( 'library'/QRPGLESRC )
**
**
**-- Header: -----------------------------------------------------------**
H Option( *SrcStmt ) DftActGrp( *No )
**-- System information: -----------------------------------------------**
D PgmSts SDs
D PsPgmNam *Proc
D PsSts 5a Overlay( PgmSts: 11 )
D PsCurJob 10a Overlay( PgmSts: 244 )
D PsUsrPrf 10a Overlay( PgmSts: 254 )
D PsJobNbr 6a Overlay( PgmSts: 264 )
D PsCurUsr 10a Overlay( PgmSts: 358 )
**-- 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
**-- User space generic header: ----------------------------------------**
D UsrSpcHdr Ds Based( pUsrSpc )
D UsOfsHdr 10i 0 Overlay( UsrSpcHdr: 117 )
D UsOfsLst 10i 0 Overlay( UsrSpcHdr: 125 )
D UsNumLstEnt 10i 0 Overlay( UsrSpcHdr: 133 )
D UsSizLstEnt 10i 0 Overlay( UsrSpcHdr: 137 )
**-- User space pointers: ----------------------------------------------**
D pUsrSpc s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- Signed-on user information: ---------------------------------------**
D SGNU0100 Ds Based( pLstEnt )
D SuDspNam 10a
D SuUsrPrf 10a
D SuJobNbr 6a
D SuAct 10a
D SuActNam 10a
D SuDscJobAlw 1a
D 17a
**-- Global variables: -------------------------------------------------**
D UsrCls s 10a
D UsrSpc c 'QEZLSGNU QTEMP'
**
D DevIpAdr s 15a
D DevIpLst s 15a Dim( 128 )
D CurIdx s 5u 0
D SchIdx s 5u 0
D Idx s 5u 0
**-- Create user space: -------------------------------------------------**
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D CsSpcNamQ 20a Const
D CsExtAtr 10a Const
D CsInzSiz 10i 0 Const
D CsInzVal 1a Const
D CsPubAut 10a Const
D CsText 50a Const
**-- Optional 1:
D CsReplace 10a Const Options( *NoPass )
D CsError 32767a Options( *NoPass: *VarSize )
**-- Optional 2:
D CsDomain 10a Const Options( *NoPass )
**-- Delete user space: -------------------------------------------------**
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- Retrieve pointer to user space: ------------------------------------**
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**-- Retrieve user information: ----------------------------------------**
D RtvUsrInf Pr ExtPgm( 'QSYRUSRI' )
D RuRcvVar 32767a Options( *VarSize )
D RuRcvVarLen 10i 0 Const
D RuFmtNam 10a Const
D RuUsrPrf 10a Const
D RuError 32767a Options( *VarSize )
**-- Retrieve device description: --------------------------------------**
D RtvDevDsc Pr ExtPgm( 'QDCRDEVD' )
D RdRcvVar 32767a Options( *VarSize )
D RdRcvVarLen 10i 0 Const
D RdFmtNam 10a Const
D RdDevNam 10a Const
D RdError 32767a Options( *VarSize )
**-- List signed on users: ---------------------------------------------**
D LstSgnUsr Pr ExtPgm( 'QEZLSGNU' )
D LuUsrSpc 20a Const
D LuFmtNam 8a Const
D LuUsrNam 10a Const
D LuDspNam 10a Const
D LuIncDsc 10a Const
D LuIncSgo 10a Const
D LuError 32767a Options( *VarSize )
**-- Get user class: ---------------------------------------------------**
D GetUsrCls Pr 10a
D PxUsrPrf 10a Value
**-- Get device ip address: --------------------------------------------**
D GetDevIp Pr 15a
D PxDevNam 10a Value
**-- Parameters: -------------------------------------------------------**
D PxUsrPrf s 10a
D PxNbrDev s 5p 0
**
C *Entry Plist
C Parm PxUsrPrf
C Parm PxNbrDev
**
**-- Check user device assignment: -------------------------------------**
**
C Eval PxNbrDev = *Zero
**
C If PxUsrPrf = '*JOBUSR'
C Eval PxUsrPrf = PsUsrPrf
**
C ElseIf PxUsrPrf = '*CURUSR'
C Eval PxUsrPrf = PsCurUsr
C EndIf
**
C If GetUsrCls( PxUsrPrf ) <> '*USER'
**
C CallP CrtUsrSpc( UsrSpc
C : *Blanks
C : 65535
C : x'00'
C : '*CHANGE'
C : *Blanks
C : '*YES'
C : ApiError
C )
**
C If AeBytAvl = *Zero
**
C CallP LstSgnUsr( UsrSpc
C : 'SGNU0100'
C : PxUsrPrf
C : '*ALL'
C : '*YES'
C : '*NO'
C : ApiError
C )
**
C If AeBytAvl = *Zero
**
C CallP RtvPtrSpc( UsrSpc
C : pUsrSpc
C )
**
C Eval pLstEnt = pUsrSpc + UsOfsLst
**
C For Idx = 1 to UsNumLstEnt
**
C ExSr PrcLstEnt
**
C If Idx < UsNumLstEnt
C Eval pLstEnt = pLstEnt + UsSizLstEnt
C EndIf
C EndFor
**
C Eval PxNbrDev = CurIdx
**
C EndIf
**
C CallP DltUsrSpc( UsrSpc
C : ApiError
C )
**
C EndIf
C EndIf
**
C Eval *InLr = *On
C Return
**
**-- Process list entries: ---------------------------------------------**
C PrcLstEnt BegSr
**
C Eval DevIpAdr = GetDevIp( SuDspNam )
**
C If DevIpAdr = *Blanks
C Eval DevIpAdr = SuDspNam
C EndIf
**
C If CurIdx = *Zero
C Eval CurIdx = 1
C Eval DevIpLst( CurIdx ) = DevIpAdr
C Else
**
C Eval SchIdx = %Lookup( DevIpAdr
C : DevIpLst
C : 1
C : CurIdx
C )
C
C If SchIdx = *Zero
**
C If CurIdx < %Elem( DevIpLst )
C Eval CurIdx += 1
C Eval DevIpLst( CurIdx ) = DevIpAdr
C EndIf
C EndIf
C EndIf
**
C EndSr
**-- Get user class: ---------------------------------------------------**
P GetUsrCls B Export
D Pi 10a
D PxUsrPrf 10a Value
**
D RuInfo Ds
D RuBytRtn 10i 0
D RuBytAvl 10i 0
D RuUsrPrf 10a
D RuUsrCls 10a Overlay( RuInfo: 19 )
**
C CallP RtvUsrInf( RuInfo
C : %Size( RuInfo )
C : 'USRI0200'
C : PxUsrPrf
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Eval RuUsrCls = *Blanks
C EndIf
**
C Return RuUsrCls
**
P GetUsrCls E
**-- Get device ip address: --------------------------------------------**
P GetDevIp B Export
D Pi 15a
D PxDevNam 10a Value
**
D RdInfo Ds
D RdBytRtn 10i 0
D RdBytAvl 10i 0
D RdInfDat 7a
D RdInfTim 6a
D RdDevNam 10a
D RdDevCtg 10a
D RdIpAdr 15a Overlay( RdInfo: 878 )
**
C CallP RtvDevDsc( RdInfo
C : %Size( RdInfo )
C : 'DEVD0600'
C : PxDevNam
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Eval RdIpAdr = *Blanks
C EndIf
**
C Return RdIpAdr
**
P GetDevIp E
Thanks to Carsten Flensburg
|
|
Back
Page #3
Page #5
