iSeries & System i

#3 API - Table of Contents #5

API Name # Description
QOKSCHD 2 Search System Directory
QGYOLJOB, QGYCTLE & QGYCLST 8 Open list of jobs a.o.
QUSLFLD   List fields
Qtoc........   TCP/IP management APIs (1)
Qtoc........   TCP/IP management APIs (2)
Qtoc........   TCP/IP management APIs (3)
QDCLCFGD   List configuration descriptions
QRZSCHE   Search hardware resource entry
QUSLSPL   List out Job Spooled Files
QWTSETPX   Set profile exit program
QWTRTVPX   Retrieve profile exit program
QEZLSGNU   List signed on users



QOKSCHD
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

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

Qtoc......

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

Qtoc......

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

Qtoc......

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

QDCLCFGD & QRZSCHE

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

QUSLSPL

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

QWTSETPX & QWTRTVPX

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

QEZLSGNU

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

Back