iSeries & System i

#4 API - Table of Contents #6

API Name # Description
QECCVTEC 1 Convert edit code mask
QGYRHRL & QGYRHRI   Retrieve the Interactive Feature Code
QSYRUSRA   Retrieve user authority to object
QSYLUSRA   List users authorized to object
QSPRJOBQ   Retrieve job queue information
CEE4RAGE   Register AG Exit Procedure
GetServByPort   Get Service Name for Port
StatvFs   Get File System Information
QUSCRTUQ   Create user queue
QLICVTTP   Convert object type
QUILNGTX   Display long text
QP0LROR   Retrieve object references
QlgLstat   Get file or link information
QSPRILSP   Retrieve identity of last spooled file created



QECCVTEC
Convert edit code mask

     **  Program . . : CBX109S
     **  Description : Get file field value by key
     **
     **  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.
     **
     **  Work management API:
     **    QUSRJOBI       Retrieve job         Retrieves specific information
     **                   information          about a specific job, covering
     **                                        all attributes and other state
     **                                        and runtime related information.
     **
     **  Edit function API:
     **    QECCVTEC       Convert edit code    Converts an edit code into an
     **                   mask                 edit mask, which is a set of
     **                                        instructions used by the edit
     **                                        function to format a numeric
     **                                        value into a character string.
     **
     **  MI builtins:
     **    _LBEDIT       Late bound edit       Transforms a numeric value from
     **                                        its internal format to character
     **                                        form, using the provided edit
     **                                        mask. Late bound here refers to
     **                                        the source value location not
     **                                        having to be provided until
     **                                        runtime.
     **
     **
     **    _MEMMOVE      Copy memory           Copies a string from one pointer
     **                                        specified location to another.
     **
     **  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.
     **
     **    _Rreadk        Read by key          Reads a record in a keyed file
     **                                        matching the key value parameter.
     **                                        This key value can be partial.
     **                                        The record is locked unless the
     **                                        No_Lock option is set.
     **
     **
     **  Service program procedures:
     **    GetFldVal      Get field value      Based on a file name, field name
     **                                        and key value, the corresponding
     **                                        field value is returned in left
     **                                        adjusted character format.
     **
     **                                        The library list is searched to
     **                                        locate the file specified.
     **
     **                                        This function can be called as
     **                                        a single request performing all
     **                                        involved steps at once.  Or - if
     **                                        repeated retrievals from the same
     **                                        file are required - as a session
     **                                        performing the initialization and
     **                                        termination process only once.
     **
     **                                        If an error occurs in the process
     **                                        the resulting error message id is
     **                                        returned as the field value.
     **
     **    LstFld         List fields          Lists to the specified user space
     **                                        a list of the specified file's
     **                                        fields, including name, data type
     **                                        and length.
     **
     **    Chain          Read record by key   Performs the actual keyed access
     **                                        to the file identified by the
     **                                        file pointer passed and returns,
     **                                        if a match is found, the record
     **                                        buffer retrieved.
     **
     **    RtvFld         Retrieve field       The buffer offset, data type and
     **                                        field length of the field name
     **                                        specified is retrieved from the
     **                                        user space field list.
     **
     **                                        Based on these field attributes
     **                                        the field's value is extracted
     **                                        and, if necessary, converted to
     **                                        character format and eventually
     **                                        returned to the caller.
     **
     **                                        The record buffer is available
     **                                        to this procedure by means of a
     **                                        global variable.
     **
     **    EditC          Edit by edit code    Converts the specified buffer
     **                                        location containing a numeric
     **                                        value in internal format to a
     **                                        readable character format as
     **                                        defined by the specified edit
     **                                        code.
     **
     **    ApyDecFmt      Apply decimal        Applies the current job's decimal
     **                   format               format to binary fields having
     **                                        decimal positions.
     **
     **
     **  Programmer's notes:
     **    This API example's intention is to demonstrate the ability to parse
     **    an externally defined record buffer using various APIs, MI builtins
     **    and C library functions.
     **
     **    The flexibility achieved by the parameterized field value level
     **    access to an externally defined file could be further extended to
     **    enable the reverse functionality.  The _CVTEFN and _LBCPYNV(R) MI
     **    builtins offer functionality that enables you to update a numeric
     **    field in a record buffer, based on a character representation of a
     **    numeric value, respectively another buffer location containing a
     **    numeric value.
     **
     **    This way many types of file and data exchanges could be soft coded
     **    throughout the whole exchange process.  Note however, that updating
     **    production data at the buffer level requires careful design and a
     **    high level of precaution - the above lines only intents to point
     **    out the possibility - in case that need should arise at some point.
     **
     **
     **  Compile options required:
     **    CrtRpgMod  CBX109S                        +
     **               DbgView( *LIST )
     **
     **    CrtSrvPgm  CBX109S                        +
     **               Module( CBX109S )              +
     **               Export( *ALL )                 +
     **               ActGrp( QSRVPGM )
     **
     **
     **-- Header specifications:  --------------------------------------------**
     H NoMain  BndDir( 'QC2LE' )  Option( *SrcStmt )
     **-- System information:  -----------------------------------------------**
     D PgmSts         SDs
     D  PsPgmNam         *Proc
     D  PsMsgId                       7a   Overlay( PgmSts: 40 )
     **-- 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 & constants:  -------------------------------**
     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
     **
     D Key_Lt          c                   x'09000100'
     D Key_Le          c                   x'0A000100'
     D Key_Eq          c                   x'0B000100'
     D Key_Eq_N        c                   x'0B000101'
     D Key_Ge          c                   x'0C000100'
     D Key_Gt          c                   x'0D000100'
     **
     D No_Lock         c                   x'00000001'
     **-- Edit template & constants:  ----------------------------------------**
     D DPA_Template_T  Ds
     D  SclTyp                        1a
     D  SclLen                        5i 0
     D   DecPos                       3i 0 Overlay( SclLen: 1 )
     D   DecLen                       3i 0 Overlay( SclLen: 2 )
     D  Rsv                          10i 0 Inz
     **
     D T_SIGNED        c                   x'00'
     D T_FLOAT         c                   x'01'
     D T_ZONED         c                   x'02'
     D T_PACKED        c                   x'03'
     D T_UNSIGNED      c                   x'0A'
     **-- Global variables:  -------------------------------------------------**
     D RcdBuf          s           4096a
     D pRFILE          s               *
     D rc              s             10i 0
     **-- Global constants:  -------------------------------------------------**
     D Null            c                   ''
     D UsrSpc          c                   'DBFLST    QTEMP'
     **-- 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 )
     **-- 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 )
     **-- Convert edit code to mask:  ----------------------------------------**
     D CvtCdeMsk       Pr                  ExtPgm( 'QECCVTEC' )
     D  CcEdtMsk                    256a
     D  CcEdtMskLen                  10i 0
     D  CcRcvVarLen                  10i 0
     D  CcZroFilChr                   1a
     D  CcEdtCde                      1a   Const
     D  CcCcyInd                      1a   Const
     D  CcSrcVarPrc                  10i 0 Const
     D  CcSrcVarDec                  10i 0 Const
     D  CcError                   32767a          Options( *VarSize )
     **-- Retrieve job information:  -----------------------------------------**
     D RtvJobInf       Pr                  ExtPgm( 'QUSRJOBI' )
     D  RiRcvVar                  32767a          Options( *VarSize )
     D  RiRcvVarLen                  10i 0 Const
     D  RiFmtNam                      8a   Const
     D  RiJobNamQ                    26a   Const
     D  RiJobIntId                   16a   Const
     **-- Optional 1:
     D  RiError                   32767a          Options( *NoPass: *VarSize )
     **-- Optional 2:
     D  RiRstStc                      1a          Options( *NoPass )
     **-- Open file:  --------------------------------------------------------**
     D Ropen           Pr              *   ExtProc( '_Ropen' )
     D  pRFile                         *   Value  Options( *String )
     D  pMode                          *   Value  Options( *String )
     **-- Close file:  -------------------------------------------------------**
     D Rclose          Pr            10i 0 ExtProc( '_Rclose' )
     D  pRFile                         *   Value
     **-- Read by key:  ------------------------------------------------------**
     D Rreadk          Pr              *   ExtProc( '_Rreadk' )
     D  pRFile                         *   Value
     D  pBuffer                        *   Value
     D  BufLength                    10u 0 Value
     D  Options                      10i 0 Value
     D  pKey                           *   Value
     D  KeyLength                    10u 0 Value
     **-- Copy memory:  ------------------------------------------------------**
     D MemCpy          Pr              *   ExtProc( '_MEMMOVE' )
     D pOutMem                         *   Value
     D pInpMem                         *   Value
     D iMemSiz                       10u 0 Value
     **-- Edit function:  ----------------------------------------------------**
     D Edit            Pr                  ExtProc( '_LBEDIT' )
     D  RcvVar                         *   Value
     D  RcvVarLen                    10u 0 Const
     D  SrcVar                         *   Value
     D  SrcVarAtr                          Const  Like( DPA_Template_T )
     D  EdtMsk                      256a   Const
     D  EdtMskLen                    10u 0 Const
     **-- Get field value:  --------------------------------------------------**
     D GetFldVal       Pr          1024a   Varying
     D  PxRqsTyp                     10i 0 Const
     D  PxFilNam                     10a   Const           Options( *NoPass )
     D  PxFldNam                     10a   Const           Options( *NoPass )
     D  PxKey                       256a   Const  Varying  Options( *NoPass )
     **-- List fields:  ------------------------------------------------------**
     D LstFld          Pr             7a   Varying
     D  PxUsrSpc                     20a   Const
     D  PxFilNam                     10a   Const
     **-- Read file by key:  -------------------------------------------------**
     D Chain           Pr         10240a   Varying
     D  PxFilPtr                       *   Const
     D  PxKeyVal                    256a   Const
     **-- Retrieve field:  ---------------------------------------------------**
     D RtvFld          Pr          1024a   Varying
     D  PxUsrSpc                     20a   Const
     D  PxFldNam                     10a   Const
     **-- Edit code:  --------------------------------------------------------**
     D EditC           Pr           256a   Varying
     D  PxDecVar                       *   Value
     D  PxDecTyp                      1a   Const
     D  PxDecDig                      5u 0 Const
     D  PxDecPos                      5u 0 Const
     D  PxEdtCde                      1a   Const
     **-- Apply decimal format:  ---------------------------------------------**
     D ApyDecFmt       Pr            32a   Varying
     D  PxInpStr                     32a   Value  Varying
     D  PxDecPos                      5u 0 Const
     **-- Get field value:  --------------------------------------------------**
     P GetFldVal       B                   Export
     D                 Pi          1024a   Varying
     D  PxRqsTyp                     10i 0 Const
     D  PxFilNam                     10a   Const           Options( *NoPass )
     D  PxFldNam                     10a   Const           Options( *NoPass )
     D  PxKey                       256a   Const  Varying  Options( *NoPass )
     **-- Local variables:
     D FldVal          s           1024a   Varying
     **-- Get field value:  --------------------------------------------------**
     **
     C                   Eval      FldVal      = Null
     **
     C                   If        %Parms     >= 2
     C
     C                   If        PxRqsTyp    = 0             Or
     C                             PxRqsTyp    = 1
     **
     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                   Eval      FldVal     =  AeMsgId
     **
     C                   Else
     C                   Eval      FldVal     =  LstFld( UsrSpc
     C                                                 : PxFilNam
     C                                                 )
     **
     C                   Monitor
     C                   Eval      pRFILE     =  Ropen( PxFilNam
     C                                                : 'rr, nullcap=Y'
     C                                                )
     **
     C                   On-Error
     C                   Eval      FldVal     =  PsMsgId
     C                   EndMon
     C                   EndIf
     **
     C                   EndIf
     C                   EndIf
     **
     C                   If        %Parms     =  4             And
     C                             FldVal     =  Null          And
     C                             pRFILE     >  *Null
     C
     C                   If        PxRqsTyp    = 0             Or
     C                             PxRqsTyp    = 2
     **
     C                   Eval      RcdBuf      = Chain( pRFILE: PxKey )
     **
     C                   If        RcdBuf     <> Null
     **
     C                   Eval      FldVal      = RtvFld( UsrSpc
     C                                                 : PxFldNam
     C                                                 )
     C                   EndIf
     **
     C                   EndIf
     C                   EndIf
     **
     C                   If        %Parms     >= 1
     C
     C                   If        PxRqsTyp    = 0             Or
     C                             PxRqsTyp    = 3
     **
     C                   Eval      rc          = Rclose( pRFILE )
     **
     C                   CallP     DltUsrSpc( UsrSpc
     C                                      : ApiError
     C                                      )
     **
     C                   EndIf
     C                   EndIf
     **
     C                   Return    FldVal
     **
     P GetFldVal       E
     **-- List fields:  ------------------------------------------------------**
     P LstFld          B                   Export
     D                 Pi             7a   Varying
     D  PxUsrSpc                     20a   Const
     D  PxFilNam                     10a   Const
     **-- List fields:  ------------------------------------------------------**
     **
     C                   CallP     LstFldSpc( PxUsrSpc
     C                                      : 'FLDL0100'
     C                                      : PxFilNam  + '*LIBL'
     C                                      : '*FIRST'
     C                                      : '0'
     C                                      : ApiError
     C                                      )
     **
     C                   If        AeBytAvl    = *Zero
     C                   Return    Null
     **
     C                   Else
     C                   Return    AeMsgId
     C                   EndIf
     **
     P LstFld          E
     **-- Read file by key:  -------------------------------------------------**
     P Chain           B                   Export
     D                 Pi         10240a   Varying
     D  PxFilPtr                       *   Const
     D  PxKeyVal                    256a   Const
     **
     D StrBuf          s          10240a
     D RtnBuf          s          10240a   Varying
     D KeyFld          s            256a
     **-- Chain:  ------------------------------------------------------------**
     **
     C                   Eval      KeyFld      = PxKeyVal
     **
     C                   Eval      pRIOFB      = Rreadk( PxFilPtr
     C                                                 : %Addr( StrBuf )
     C                                                 : %Size( StrBuf )
     C                                                 : Key_Eq_N
     C                                                 : %Addr( KeyFld )
     C                                                 : %Len( %TrimR( KeyFld ))
     C                                                 )
     **
     C                   If        IoNbrBytRw  > 0
     C                   Eval      RtnBuf      = %SubSt( StrBuf: 1: IoNbrBytRw )
     C                   EndIf
     **
     C                   Return    RtnBuf
     **
     P Chain           E
     **-- Retrieve field:  ---------------------------------------------------**
     P RtvFld          B                   Export
     D                 Pi          1024a   Varying
     D  PxUsrSpc                     20a   Const
     D  PxFldNam                     10a   Const
     **-- Local variables:
     D FldVal          s           1024a
     D Idx             s             10u 0
     **-- API format FLDL0100:
     D FldLst100       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
     **-- 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
     **-- 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 )
     **-- Retrieve field:  ---------------------------------------------------**
     **
     C                   CallP     RtvPtrSpc( PxUsrSpc: pUsrSpc )
     **
     C                   Eval      pHdrInf     = pUsrSpc + UsOfsHdr
     C                   Eval      pLstEnt     = pUsrSpc + UsOfsLst
     **
     C                   For       Idx = 1  To UsNumLstEnt
     **
     C                   If        F1FldNam    = PxFldNam
     **
     C                   Select
     C                   When      F1DtaTyp    = 'A'      Or
     C                             F1DtaTyp    = 'L'      Or
     C                             F1DtaTyp    = 'T'      Or
     C                             F1DtaTyp    = 'Z'
     **
     C                   CallP     MemCpy( %Addr( FldVal )
     C                                   : %Addr( RcdBuf ) +
     C                                     F1InpBufPos - 1
     C                                   : F1Len
     C                                   )
     **
     C                   When      F1DtaTyp    = 'P'      Or
     C                             F1DtaTyp    = 'Z'      Or
     C                             F1DtaTyp    = 'B'
     **
     C                   Eval      FldVal      = EditC( %Addr( RcdBuf ) +
     C                                                  F1InpBufPos - 1
     C                                                : F1DtaTyp
     C                                                : F1Digits
     C                                                : F1DecPos
     C                                                : 'P'
     C                                                )
     **
     C                   EndSl
     **
     C                   Leave
     C                   EndIf
     **
     C                   If        Idx         < UsNumLstEnt
     C                   Eval      pLstEnt     = pLstEnt + UsSizLstEnt
     C                   EndIf
     C                   EndFor
     **
     C                   Return    %TrimR( FldVal )
     **
     P RtvFld          E
     **-- Edit code:  --------------------------------------------------------**
     P EditC           B                   Export
     D                 Pi           256a   Varying
     D  PxDecVar                       *   Value
     D  PxDecTyp                      1a   Const
     D  PxDecDig                      5u 0 Const
     D  PxDecPos                      5u 0 Const
     D  PxEdtCde                      1a   Const
     **-- Local variables & constants:
     D EdtMsk          s            256a
     D EdtMskLen       s             10i 0
     D RcvVar          s            256a
     D RcvVarLen       s             10i 0
     D ZroFilChr       s              1a
     D DecDig          s             10u 0
     **
     **-- Edit:  -------------------------------------------------------------**
     **
     C                   Select
     C                   When      PxDecTyp   = 'P'            Or
     C                             PxDecTyp   = 'Z'
     **
     C                   If        PxDecTyp   = 'P'
     C                   Eval      SclTyp     = T_PACKED
     C                   Else
     C                   Eval      SclTyp     = T_ZONED
     C                   EndIf
     **
     C                   Eval      DecDig     = PxDecDig
     C                   Eval      DecPos     = PxDecPos
     C                   Eval      DecLen     = PxDecDig
     **
     C                   When      PxDecTyp   = 'B'
     **
     C                   Eval      SclTyp     = T_SIGNED
     **
     C                   Eval      DecDig     = PxDecDig
     C                   Eval      DecPos     = *Zero
     **
     C                   If        DecDig     > 5
     C                   Eval      DecDig     = 10
     C                   Eval      DecLen     = 4
     C                   Else
     C                   Eval      DecDig     = 5
     C                   Eval      DecLen     = 2
     C                   EndIf
     C                   EndSl
     **
     C                   CallP     CvtCdeMsk( EdtMsk
     C                                      : EdtMskLen
     C                                      : RcvVarLen
     C                                      : ZroFilChr
     C                                      : PxEdtCde
     C                                      : ' '
     C                                      : DecDig
     C                                      : DecPos
     C                                      : ApiError
     C                                      )
     **
     C                   CallP(e)  Edit( %Addr( RcvVar )
     C                                 : RcvVarLen
     C                                 : PxDecVar
     C                                 : DPA_Template_T
     C                                 : EdtMsk
     C                                 : EdtMskLen
     C                                 )
     **
     C                   If        %Error
     C                   Return    Null
     **
     C                   ElseIf    PxDecTyp   = 'B'            And
     C                             PxDecPos   > *Zero
     **
     C                   Return    ApyDecFmt( %SubSt( RcvVar: 1: RcvVarLen )
     C                                      : PxDecPos
     C                                      )
     **
     C                   Else
     C                   Return    %TrimL( %SubSt( RcvVar: 1: RcvVarLen ))
     C                   EndIf
     **
     P EditC           E
     **-- Apply decimal format:  ---------------------------------------------**
     P ApyDecFmt       B
     D                 Pi            32a   Varying
     D  PxInpStr                     32a   Value  Varying
     D  PxDecPos                      5u 0 Const
     **-- Local variables:
     D ZroOfs          s              5u 0
     D DecOfs          s              5u 0
     **-- Job info format JOBI0400:
     D J4RcvDta        Ds
     D  J4BytRtn                     10i 0
     D  J4BytAvl                     10i 0
     D  J4JobNam                     10a
     D  J4UsrNam                     10a
     D  J4JobNbr                      6a
     D  J4DecFmt                      1a   Overlay( J4RcvDta: 457 )
     **
     C                   CallP     RtvJobInf( J4RcvDta
     C                                      : %Size( J4RcvDta )
     C                                      : 'JOBI0400'
     C                                      : '*'
     C                                      : *Blank
     C                                      : ApiError
     C                                      )
     **
     C                   If        AeBytAvl    > *Zero
     C                   Return    PxInpStr
     C                   Else
     **
     C                   If        J4DecFmt    = 'J'
     C                   Eval      ZroOfs      = %Len( PxInpStr ) - PxDecPos
     C                   Eval      DecOfs      = ZroOfs + 1
     C                   Else
     C                   Eval      ZroOfs      = %Len( PxInpStr ) - PxDecPos + 1
     C                   Eval      DecOfs      = ZroOfs
     C                   EndIf
     **
     C                   Eval      PxInpStr    = %Xlate( ' '
     C                                                 : '0'
     C                                                 : PxInpStr
     C                                                 : ZroOfs
     C                                                 )
     C
     **
     C                   If        J4DecFmt    = ' '
     C                   Return    %Replace( '.'
     C                                     : PxInpStr
     C                                     : DecOfs
     C                                     : 0
     C                                     )
     **
     C                   Else
     C                   Return    %Replace( ','
     C                                     : PxInpStr
     C                                     : DecOfs
     C                                     : 0
     C                                     )
     C                   EndIf
     C                   EndIf
     **
     P ApyDecFmt       E

The calling program ** Program . . : CBX109T ** Description : Get file field value by key - Test ** ** Program directions ** ------------------ ** ** This test program retrieves field values from the TCP/IP host table ** which is stored in a physical file named QATOCHOST in QUSRSYS. ** ** Go CFGTCP option 10 allow you to examine the current entries in this ** table. If you want, or if required, please change the key value from ** '127.0.0.1' to another existing entry in the table. Please also ** check that you have sufficient authority to the table prior to ** running this test program. ** ** Another option would be to replace the file name, field name and key ** value specified in the example below to values of your own choice. ** ** This test program presents the retrieved field values using the DSPLY ** facility. You could also simply start a debug session against this ** program and step through the code lines, to watch the process as it ** unfolds. ** ** When the debug session is positioned on a GetFldVal() procedure ** statement you can use F22 to step into the subprocedure and examine ** the statements executed there. The F10 step instruction also applies ** while in the subprocedure. ** ** ** Compile options required: ** CrtRpgMod CBX109T + ** DbgView( *LIST ) ** ** CrtPgm CBX109T + ** Module( CBX109T ) + ** BndSrvPgm( CBX109S ) + ** ActGrp( QILE ) ** ** **-- Header specifications: --------------------------------------------** H Option( *SrcStmt ) **-- Global definitions: -----------------------------------------------** D FldVal s 1024a Varying D DspVal s 42a ** D SngRqs c 0 D InzRqs c 1 D RunRqs c 2 D TrmRqs c 3 **-- Get field value: --------------------------------------------------** D GetFldVal Pr 1024a Varying D PxRqsTyp 10i 0 Const D PxFilNam 10a Const Options( *NoPass ) D PxFldNam 10a Const Options( *NoPass ) D PxKey 256a Const Varying Options( *NoPass ) ** **-- Mainline: ---------------------------------------------------------** ** C Eval FldVal = GetFldVal( SngRqs C : 'QATOCHOST' C : 'HOSTNME1' C : '127.0.0.1' C ) ** C Eval DspVal = FldVal C 'HOSTNME1 =' Dsply DspVal ** C Eval FldVal = GetFldVal( InzRqs C : 'QATOCHOST' C ) ** C Eval FldVal = GetFldVal( RunRqs C : 'QATOCHOST' C : 'HOSTNME1' C : '127.0.0.1' C ) ** C Eval DspVal = FldVal C 'HOSTNME1 =' Dsply DspVal ** C Eval FldVal = GetFldVal( RunRqs C : 'QATOCHOST' C : 'IPINTGER' C : '127.0.0.1' C ) ** C Eval DspVal = FldVal C 'IPINTGER =' Dsply DspVal ** C Eval FldVal = GetFldVal( RunRqs C : 'QATOCHOST' C : 'TXTDESC' C : '127.0.0.1' C ) ** C Eval DspVal = FldVal C 'TXTDESC =' Dsply DspVal ** C Eval FldVal = GetFldVal( TrmRqs ) ** C Return ** Thanks to Carsten Flensburg

Back

QGYRHRL & QGYRHRI
Retrieve the Interactive Feature Code

      *===============================================================
      * GetProcFeat                                                  +
      *===============================================================
     PGetProcFeat      B
     DGetProcFeat      PI             1n
      *---------------------------------------------------------------
     D SysProc                        4A
     D Proc                           4A
     D Int                            4A
     D wxdebug                        1N   const
      *---------------------------------------------------------------

      *---------------------------------------------------------------------
      * Local work areas *
      *---------------------------------------------------------------------

     D*****************************************************************
     D*Field definitions for RHRL0100 format.
     D*****************************************************************
     DQGYL0100         DS
     D*                                             Qgy RHRL0100
     D QGYBR                   1      4U 0
     D*                                    number of bytes returned
     D QGYBA                   5      8U 0
     D*                                    number of bytes available
     D QGYNBRRR                9     12U 0
     D*                                    num of resources returned
     D QGYREL                 13     16U 0
     D*                                    length of resource entry
     D Qvadsomhelst           17   2016a

     DRESDTL           DS
     D QGYCAT                  1      4U 0
     D*                                    category
     D QGYFL                   5      8U 0
     D*                                    family level
     D QGYLT                   9     12B 0
     D*                                    LAN line type
     D QGYNAME                13     22
     D*                                    name
     D QGYTYPE                23     26
     D*                                    type
     D QGYMODL                27     29
     D*                                    model
     D QGYSTAT                30     30
     D*                                    status
     D QGYSYS                 31     38
     D*                                    system connected to
     D QGYADDR                39     50
     D*                                    LAN adapter address
     D QGYDES                 51    100
     D*                                    description
     D QGYKIND               101    124
     D*                                    resource kind

     D*****************************************************************
     D*Field definitions for RHRI0410 format.
     D*****************************************************************
     DRcvVar           DS
     D QRHBRTN                 1      4B 0
     D*                                             Bytes Returned
     D QRHBAVL                 5      8B 0
     D*                                             Bytes Available
     D QRHSBUS                 9     12B 0
     D*                                             System Bus number
     D QRHSBOA                13     16B 0
     D*                                             System Board number
     D QRHSCAR                17     20B 0
     D*                                             System Card number
     D QRHSSRL                21     30a
     D*                                             System serial number
     D QRHPART                31     42
     D*                                             Part number
     D QRHFRAM                43     46a
     D*                                             Frame id
     D QRHCARP                47     51a
     D*                                             Card position
     D QRHSPRC                52     55a
     D*                                             Sys. processor feature code
     D QRHPRC                 56     59a
     D*                                             Processor feature code
     D QRHPRCI                60     63a
     D*                                             Interactive feature code

     D ListFormat      S              8    INZ('RHRI0410')
     D ListFormat2     S              8    INZ('RHRL0100')
     D Resource        S             10    INZ('          ')
     D RcvSiz          S             10i 0 INZ(%size(RCVVAR))
     D RcvSiz2         S             10i 0 INZ(%size(QGYL0100))
     D ResourceCat     S             10i 0 INZ(4)
     D strpos          S             10i 0 INZ(1)
     D DtlSiz          S             10i 0 INZ(%size(RESDTL))
     D wxlog           S            256a

      *===============================================================
      * Error Information Data Structure                             +
      *===============================================================
      *Error Code
     DQUSBN            DS
      *                                             Qus EC
     DQUSBNB                   1      4B 0          inz(%size(QUSBN))
      *                                             Bytes Provided
     DQUSBNC                   5      8B 0
      *                                             Bytes Available
     DQUSBND                   9     15
      *                                             Exception Id
     DQUSBNF                  16    256

     C                   eval      wxlog      = *blanks

     C                   CALL      'QGYRHRL'
     C                   PARM                    QGYL0100
     C                   PARM                    RcvSiz2
     C                   PARM                    ListFormat2
     C                   PARM                    ResourceCat
     C                   PARM                    QUSBN

     C                   if        QUSBNC > 0      error occured
     C                   callp     SndDbgMsg( GetTime +
     C                                       ' Error on QGYRHRI program ' +
     C                                       'call: ' +
     C                                        QUSBND)
     C                   return    *on
     C                   endif

     C                   if        QGYNBRRR > 0
     C                   do        QGYNBRRR
     C                   eval       %subst(RESDTL:1:DTLSIZ) =
     C                              %subst(Qvadsomhelst:strpos:DTLSIZ)

     C                   if        %subst(QGYKIND:17:8) =
     C                             x'0000000000080000'
     C                   eval      Resource = QGYNAME
     C                   leave
     C                   endif

     C                   eval      StrPos = StrPos + QGYREL
     C                   enddo
     C                   endif

     C                   CALL      'QGYRHRI'
     C                   PARM                    RcvVar
     C                   PARM                    RcvSiz
     C                   PARM                    ListFormat
     C                   PARM                    Resource
     C                   PARM                    QUSBN

     C                   if        QUSBNC > 0      error occured
     C                   callp     SndDbgMsg( GetTime +
     C                                       ' Error on QGYRHRI program ' +
     C                                       'call: ' +
     C                                        QUSBND)
     C                   return    *on
     C                   endif

     C                   if        wxdebug      debug
     C                   callp     SndDbgMsg( GetTime +
     C                                      ' System Proc#: ' +
     C                                      %trim(QRHSPRC) + ' ' +
     C                                      ' Processor#: ' +
     C                                      %trim(QRHPRC) + ' ' +
     C                                      ' Interactive#: ' +
     C                                      %trim(QRHPRCI) + ' ' +
     C                                      ' Serial#: ' + QRHSSRL +
     C                                      ' system board: ' +
     C                                      %trim(%editc(QRHSBOA:'Z')) )
     C                   endif

     C                   eval      SysProc = QRHSPRC
     C                   eval      Proc    = QRHPRC
     C                   eval      Int     = QRHPRCI

     C                   return    *off
     PGetProcFeat      E

Thanks to Stefan Tageson
Back

QSYRUSRA
Retrieve user authority to object

     **
     **  Program . . : CBX5032
     **  Description : Check object authority
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : April 15, 2004
     **
     **
     **  Program summary
     **  ---------------
     **
     **  Parameters:
     **    INPUT      PxObjNam      Object name, the object for which to
     **                             check the specified authorization level.
     **
     **    INPUT      PxObjLib      Object library.
     **
     **    INPUT      PxObjTyp      Object type.
     **
     **    INPUT      PxAut         Authorization level to check for.
     **
     **                             Valid values:
     **                               *ALL
     **                               *CHANGE
     **                               *USE
     **                               *EXCLUDE
     **                               *AUTLMGT
     **
     **    INPUT      PxUsrPrf       Name of user profile having it's
     **                              authority checked.
     **
     **                              Special values:
     **                                *CURRENT   The user currently running
     **                                           the job.
     **
     **                                *PUBLIC    The public authority for
     **                                           the specified object is
     **                                           checked.
     **
     **     OUTPUT     PxRtnCod      A boolean value indicating the result
     **                              of the requested action.
     **
     **                              Valid return codes:
     **                                0 = Authority level not found
     **                                1 = Authority level found
     **
     **  Security API:
     **    QSYRUSRA     Retrieve user          Returns a specific user's
     **                 authority to object    authority for the specified
     **                                        object.
     **
     **
     **  Programmer's notes:
     **    This program checks if a user has the specified authority to an
     **    object. All authorization sources are taken into account during
     **    the authorization check (group profile(s), adopted authority as
     **    well as authorization lists, public and *ALLOBJ authority).
     **
     **    The actual source of authority is specified in the returned data
     **    structure subfield 'U1AutSrc' as a 2-letter code.  Please check
     **    the Security API manual for the details. It can be found online
     **    here:
     **
     **    http://publib.boulder.ibm.com/iseries/v5r2/ic2924/info/apis/ ...
     **       ... qsyrusra.htm
     **
     **  Compile options:
     **
     **    CrtRpgMod Module( CBX5032 )  DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX5032 )
     **              Module( CBX5032 )
     **
     **
     **-----------------------------------------------------------------------**
     ** Revised . : 00.00.0000
     ** by  . . . :
     ** Reference :
     ** Changes . :
     **
     **-- Header specifications:  --------------------------------------------**
     H Option( *SrcStmt )
     **-- Api Error:  --------------------------------------------------------**
     D ApiError        Ds
     D  AeBytPrv                     10i 0 Inz( %Size( ApiError ))
     D  AeBytAvl                     10i 0
     D  AeMsgId                       7a
     D                                1a
     D  AeMsgDta                    128a
     **-- Receiver format USRA0100:  -----------------------------------------**
     D USRA0100        Ds
     D  U1BytRtn                     10i 0
     D  U1BytAvl                     10i 0
     D  U1ObjAut                     10a
     D  U1AutLstMgt                   1a
     D  U1ObjOpr                      1a
     D  U1ObjMgm                      1a
     D  U1ObjExs                      1a
     D  U1DtaRead                     1a
     D  U1DtaAdd                      1a
     D  U1DtaUpd                      1a
     D  U1DtaDlt                      1a
     D  U1AutLst                     10a
     D  U1AutSrc                      2a
     D  U1AdpAut                      1a
     D  U1AdpObjAut                  10a
     D  U1AdpAutLstMg                 1a
     D  U1AdpObjOpr                   1a
     D  U1AdpObjMgm                   1a
     D  U1AdpObjExs                   1a
     D  U1AdpDtaRead                  1a
     D  U1AdpDtaAdd                   1a
     D  U1AdpDtaUpd                   1a
     D  U1AdpDtaDlt                   1a
     D  U1AdpDtaExe                   1a
     D                               10a
     D  U1AdpObjAlt                   1a
     D  U1AdpObjRef                   1a
     D                               10a
     D  U1DtaExe                      1a
     D                               10a
     D  U1ObjAlt                      1a
     D  U1ObjRef                      1a
     D  U1AspDevLib                  10a
     D  U1AspDevObj                  10a
     **-- Retrieve user authority to object:  --------------------------------**
     D RtvUsrAut       Pr                  ExtPgm( 'QSYRUSRA' )
     D  RuRcvVar                                  Like( USRA0100 )
     D  RuRcvVarLen                  10i 0 Const
     D  RuFmtNam                      8a   Const
     D  RuUsrPrf                     10a   Const
     D  RuObjNamQ                    20a   Const
     D  RuObjTyp                     10a   Const
     D  RuError                   32767a          Options( *VarSize )
     D  RuAspDev                     10a          Options( *NoPass )
     **-- Parameters:  -------------------------------------------------------**
     D PxObjNam        s             10a
     D PxObjLib        s             10a
     D PxObjTyp        s             10a
     D PxUsrPrf        s             10a
     D PxAut           s             10a
     D PxRtnCod        s               n
     **
     C     *Entry        Plist
     C                   Parm                    PxObjNam
     C                   Parm                    PxObjLib
     C                   Parm                    PxObjTyp
     C                   Parm                    PxUsrPrf
     C                   Parm                    PxAut
     C                   Parm                    PxRtnCod
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      PxRtnCod    = *Off
     **
     C                   CallP     RtvUsrAut( USRA0100
     C                                      : %Size( USRA0100 )
     C                                      : 'USRA0100'
     C                                      : PxUsrPrf
     C                                      : PxObjNam + PxObjLib
     C                                      : PxObjTyp
     C                                      : ApiError
     C                                      )
     **
     C                   If        AeBytAvl    = *Zero
     **
     C                   Select
     C                   When      PxAut       = '*ALL '       And
     C                             U1ObjAut    = '*ALL '
     **
     C                   Eval      PxRtnCod    = *On
     **
     C                   When      PxAut       = '*CHANGE '    And
     C                             U1ObjOpr    = 'Y'           And
     C                             U1DtaRead   = 'Y'           And
     C                             U1DtaAdd    = 'Y'           And
     C                             U1DtaUpd    = 'Y'           And
     C                             U1DtaDlt    = 'Y'           And
     C                             U1DtaExe    = 'Y'
     **
     C                   Eval      PxRtnCod    = *On
     **
     C                   When      PxAut       = '*USE '       And
     C                             U1ObjOpr    = 'Y'           And
     C                             U1DtaRead   = 'Y'           And
     C                             U1DtaExe    = 'Y'
     **
     C                   Eval      PxRtnCod    = *On
     **
     C                   When      PxAut       = '*AUTLMGT '   And
     C                             U1AutLstMgt = 'Y'
     **
     C                   Eval      PxRtnCod    = *On
     **
     C                   When      PxAut       = '*EXCLUDE '   And
     C                             U1ObjAut    = '*EXCLUDE '
     **
     C                   Eval      PxRtnCod    = *On
     C                   EndSl
     C                   EndIf
     C
     C                   Return
     **

The calling program **-- Program parameters: -----------------------------------------------** D PxObjNam s 10a D PxObjLib s 10a D PxObjTyp s 10a D PxUsrPrf s 10a D PxAut s 10a D PxRtnCod s n ** **-- Check object authority: ** C Call 'CBX5032' C Parm 'QCMD' PxObjNam C Parm '*LIBL' PxObjLib C Parm '*PGM' PxObjTyp C Parm '*PUBLIC' PxUsrPrf C Parm '*USE' PxAut C Parm PxRtnCod ** C If PxRtnCod = '1' C Else C EndIf ** Thanks to Carsten Flensburg

Back

QSYLUSRA
List users authorized to object

     **
     **  Program . . : CBX5031
     **  Description : Check private authority
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : April 15, 2004
     **
     **
     **  Program summary
     **  ---------------
     **
     **  Parameters:
     **    INPUT      PxObjNam      Object name, the object for which to
     **                             check the specified authorization level.
     **
     **    INPUT      PxObjLib      Object library.
     **
     **    INPUT      PxObjTyp      Object type.
     **
     **    INPUT      PxAut         Authorization level to check for.
     **
     **                             Valid values:
     **                               *ALL
     **                               *CHANGE
     **                               *USE
     **                               *EXCLUDE
     **                               *AUTLMGT
     **
     **    INPUT      PxUsrPrf       Name of user profile having it's
     **                              authority checked.
     **
     **                              Special values:
     **                                *CURRENT   The user currently running
     **                                           the job.
     **
     **                                *PUBLIC    The public authority for
     **                                           the specified object is
     **                                           checked.
     **
     **     OUTPUT     PxRtnCod      A boolean value indicating the result
     **                              of the requested action.
     **
     **                              Valid return codes:
     **                                0 = Authority level not found
     **                                1 = Authority level found
     **
     **  Security API:
     **    QSYLUSRA     List users authorized  Creates a list of users having a
     **                 to object              private authority to the object
     **                                        specified.  The list is put into
     **                                        a user space.
     **
     **  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.
     **
     **
     **  Programmer's notes:
     **    This program checks if a user holds a private authorization of
     **    the specified level to an object. No other authorization sources
     **    are taken into account during the authorization check.
     **
     **
     **  Compile options:
     **
     **    CrtRpgMod Module( CBX5031 )  DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX5031 )
     **              Module( CBX5031 )
     **
     **                                                                       **
     **-- Header specifications:  --------------------------------------------**
     H Option( *SrcStmt )
     **-- System information:  -----------------------------------------------**
     D PgmSts         SDs
     D  PsJobUsr                     10a   Overlay( PgmSts: 254 )
     D  PsCurUsr                     10a   Overlay( PgmSts: 358 )
     **-- Global variables:  -------------------------------------------------**
     D Idx             s             10i 0
     **-- API error data structure:  -----------------------------------------**
     D ApiError        Ds
     D  AeBytPro                     10i 0 Inz( %Size( ApiError ))
     D  AeBytAvl                     10i 0 Inz
     **-- Create User Space Parameter:  --------------------------------------**
     D CuUsrSpcQ       Ds
     D  CuUsrSpcNam                  10    Inz( 'AUTLST   ' )
     D  CuUsrSpcLib                  10    Inz( 'QTEMP ' )
     **-- Entry format USRA0100:  --------------------------------------------**
     D USRA0100        Ds                  Based( pLstEnt )
     D  U1UsrPrf                     10a
     D  U1AutVal                     10a
     D  U1AutLstMgt                   1a
     D  U1ObjOpr                      1a
     D  U1ObjMgt                      1a
     D  U1ObjExs                      1a
     D  U1DtaRead                     1a
     D  U1DtaAdd                      1a
     D  U1DtaUpd                      1a
     D  U1DtaDlt                      1a
     D  U1DtaExe                      1a
     D                               10a
     D  U1ObjAlt                      1a
     D  U1ObjRef                      1a
     **-- API format USRA0100: Header information:  --------------------------**
     D HdrInf          Ds                  Based( pHdrInf )
     D  HiObjNam                     10a
     D  HiLibNam                     10a
     D  HiObjTyp                     10a
     D  HiOwnNam                     10a
     D  HiAutL                       10a
     D  HiPriGrp                     10a
     D  HiFldAut                      1a
     D  HiAspDevLib                  10a
     D  HiAspDevObj                  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 )
     **-- List authorized users:  --------------------------------------------**
     D LstAutUsr       Pr                  ExtPgm( 'QSYLUSRA' )
     D  LaSpcNamQ                    20a   Const
     D  LaFmtNam                      8a   Const
     D  LaObjNamQ                    20a   Const
     D  LaObjTyp                     10a   Const
     D  LaError                   32767a          Options( *VarSize )
     D  LaAspDev                     10a          Options( *NoPass )
     **-- 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
     **
     D  CsReplace                    10a   Const  Options( *NoPass )
     D  CsError                   32767a          Options( *NoPass: *VarSize )
     **
     D  CsDomain                     10a   Const  Options( *NoPass )
     **
     D  CsTfrSizRqs                  10i 0 Const  Options( *NoPass )
     D  CsOptSpcAlg                   1a   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 )
     **-- Parameters:  -------------------------------------------------------**
     D PxObjNam        s             10a
     D PxObjLib        s             10a
     D PxObjTyp        s             10a
     D PxUsrPrf        s             10a
     D PxAut           s             10a
     D PxRtnCod        s               n
     **
     C     *Entry        Plist
     C                   Parm                    PxObjNam
     C                   Parm                    PxObjLib
     C                   Parm                    PxObjTyp
     C                   Parm                    PxUsrPrf
     C                   Parm                    PxAut
     C                   Parm                    PxRtnCod
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      PxRtnCod    = *Off
     **
     C                   If        PxUsrPrf    = '*CURRENT'
     C                   Eval      PxUsrPrf    = PsCurUsr
     C                   EndIf
     **
     C                   CallP     CrtUsrSpc( CuUsrSpcQ
     C                                      : *Blanks
     C                                      : 65535
     C                                      : x'00'
     C                                      : '*CHANGE'
     C                                      : *Blanks
     C                                      : '*YES'
     C                                      : ApiError
     C                                      )
     **
     C                   CallP     LstAutUsr( CuUsrSpcQ
     C                                      : 'USRA0100'
     C                                      : PxObjNam + PxObjLib
     C                                      : PxObjTyp
     C                                      : ApiError
     C                                      )
     **
     C                   If        AeBytAvl    = *Zero
     **
     C                   CallP     RtvPtrSpc( CuUsrSpcQ
     C                                      : pUsrSpc
     C                                      )
     **
     C                   ExSr      ChkUsrAut
     C                   EndIf
     **
     C                   CallP     DltUsrSpc( CuUsrSpcQ
     C                                      : ApiError
     C                                      )
     **
     C                   Return
     **
     **-- Check user authority:  ---------------------------------------------**
     C     ChkUsrAut     BegSr
     **
     C                   Eval      pHdrInf     = pUsrSpc + UsOfsHdr
     C                   Eval      pLstEnt     = pUsrSpc + UsOfsLst
     **
     C                   For       Idx = 1  to  UsNumLstEnt
     **
     C                   If        U1UsrPrf    = PxUsrPrf
     C                   ExSr      ChkAutVal
     **
     C                   Leave
     C                   EndIf
     **
     C                   If        Idx         < UsNumLstEnt
     C                   Eval      pLstEnt     = pLstEnt + UsSizLstEnt
     C                   EndIf
     C                   EndFor
     **
     C                   EndSr
     **-- Check authority value:  --------------------------------------------**
     C     ChkAutVal     BegSr
     **
     C                   Select
     C                   When      PxAut       = '*ALL '       And
     C                             U1AutVal    = '*ALL '
     **
     C                   Eval      PxRtnCod    = *On
     **
     C                   When      PxAut       = '*CHANGE '    And
     C                             U1ObjOpr    = 'Y'           And
     C                             U1DtaRead   = 'Y'           And
     C                             U1DtaAdd    = 'Y'           And
     C                             U1DtaUpd    = 'Y'           And
     C                             U1DtaDlt    = 'Y'           And
     C                             U1DtaExe    = 'Y'
     **
     C                   Eval      PxRtnCod    = *On
     **
     C                   When      PxAut       = '*USE '       And
     C                             U1ObjOpr    = 'Y'           And
     C                             U1DtaRead   = 'Y'           And
     C                             U1DtaExe    = 'Y'
     **
     C                   Eval      PxRtnCod    = *On
     **
     C                   When      PxAut       = '*AUTLMGT '   And
     C                             U1AutLstMgt = 'Y'
     **
     C                   Eval      PxRtnCod    = *On
     **
     C                   When      PxAut       = '*EXCLUDE '   And
     C                             U1AutVal    = '*EXCLUDE '
     **
     C                   Eval      PxRtnCod    = *On
     C                   EndSl
     **
     C                   EndSr

The calling program **-- Program parameters: -----------------------------------------------** D PxObjNam s 10a D PxObjLib s 10a D PxObjTyp s 10a D PxUsrPrf s 10a D PxAut s 10a D PxRtnCod s n ** **-- Check private authority: ** C Call 'CBX5031' C Parm 'QPWFSERVER' PxObjNam C Parm 'QSYS' PxObjLib C Parm '*AUTL' PxObjTyp C Parm 'QSYS' PxUsrPrf C Parm '*ALL' PxAut C Parm PxRtnCod ** C If PxRtnCod = '1' C Else C EndIf Thanks to Carsten Flensburg

Back

QSPRJOBQ
Retrieve job queue information

      // ****************************************************************** //
      // *  Compile Options                                               * //
      // ****************************************************************** //
     H Option(*SRCSTMT:*NODEBUGIO) Indent('|') ExprOpts(*ResDecPos)
      /IF  DEFINED(*CRTBNDRPG)
     H   DFTACTGRP(*NO)
     H   ActGrp(*NEW)
      /ENDIF
     H BndDir('QC2LE')

      // ****************************************************************** //
      // *  Definition Specifations                                       * //
      // ****************************************************************** //
      // ------------------------------------------------------------------ //
      // - External Prototypes                                            - //
      // ------------------------------------------------------------------ //
     D GETJOBQ         PR                  EXTPGM('QSPRJOBQ')
     D  RECIEVER                    144A
     D  RCVRLEN                      10I 0 const
     D  FORMAT                        8A   const
     D  JOBQ                         20A   conST
     D  ERROR                       116A

      // ------------------------------------------------------------------ //
      // - Data Structures/Arrays                                         - //
      // ------------------------------------------------------------------ //
      /INCLUDE QSYSINC/QRPGLESRC,QSPRJOBQ
      /INCLUDE QSYSINC/QRPGLESRC,QUSEC
     D QUSED01                      100A

      // ****************************************************************** //
      // *  Main Calculations                                             * //
      // ****************************************************************** //
      /Free
       GETJOBQ(QSPQ010000:%SIZE(QSPQ010000):'JOBQ0100':
                   'QBATCH    QGPL':QUSEC);
       DSPLY QSPSN;
       *INLR = *On;
      /End-Free

Thanks to Chris Beck
Back

CEE4RAGE
Register Activation Group Exit Procedure

Here's a message that I posted to the iSeries Network RPG forum back in
May. It was in reply to someone who wanted to run procedures when a service
program was activated or deactivated (much like a constructor/destructor
in OO languages.)

As far as I know, there's no way to run a procedure during the activation
phase.

Here's how I approach the problem:  I have a subprocedure that gets called
first by every exported subprocedure.  I use a global field to determine
if it's been called before, and if so, it does not run again.

I also tend to register a cleanup procedure with CEE4RAGE. Though,
ending the activation group should theoretically clean everything
up for me, I like to do it explicitly.  I like to be in control! :)

The following code should help illustrate what I'm talking about:

     H NOMAIN

     D Initialized     s              1N   inz(*off)

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      * Initialization routine
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P InzSrvPgm       B
     D InzSrvPgm       PI

     D CEE4RAGE        PR
     D   procedure                     *   procptr const
     D   feedback                    12A   options(*omit)

      /free
         if (Initialized);
             return;
         endif;

         // .. open files here ...
         // .. other initializations ...

         CEE4RAGE(%paddr(EndSrvPgm): *OMIT);

         Initialized = *ON;
         return;
      /end-free
     P                 e

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      * EndSrvPgm():  This is called automatically when the activation
      *               group ends.  (which is when the srvpgm is removed
      *               from memory.)
      *
      *  Note that this must be exported so that CEE4RAGE can call it.
      *
      * InzSrvPgm() registers this procedure with the CEE4RAGE() API
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P EndSrvPgm       B                   export
     D EndSrvPgm       PI
     D   AgMark                      10U 0 options(*nopass)
     D   Reason                      10U 0 options(*nopass)
     D   Result                      10U 0 options(*nopass)
     D   UserRC                      10U 0 options(*nopass)
      /free

           // ... terminate any helper processes
           // ... shut down any persistent APIs
           // ... close files.
           // ... deallocate memory.

           Initialized = *OFF;
           return;
      /end-free
     P                 E

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      *  Every exported procedure (besides EndSrvPgm) starts by calling
      *  the InzSrvPgm() subprocedure
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P SomeProc        B                   export
     D SomeProc        PI            10I 0
     D   SomeParm                   123A   const

      /free

            InzSrvPgm();

            // ... perform function of subproc here ...
            return data;

      /end-free
     P                 E

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      *  Every exported procedure (besides EndSrvPgm) starts by calling
      *  the InzSrvPgm() subprocedure
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P AnotherProc     B                   export
     D AnotherProc     PI            10I 0
     D   AnotherParm                321A   const

      /free

            InzSrvPgm();

            // ... perform function of subproc here ...

            return data;

      /end-free
     P                 E

Thanks to Scott Klement
Back

GetServByPort
Get Service Name for Port

Q:
Is there any way to retrieve the TCP/IP service (local port name)
associated to a local port number ?
Just like int the command WRKSRVTBLE. Is there an API for this ?
A:
- Here's an RPG/IV example of the getservbyport() function:

     H bnddir( 'QC2LE' )
     **
     D getservbyport   pr              *   extproc( 'getservbyport' )
     D  port                         10i 0 value
     D  protocol                       *   value  options( *string )
     **
     D servent         ds                  based( p_servent )
     D  s_name                         *
     D  s_aliases                      *
     D  port                         10i 0
     D  s_proto                        *
     **
     D idx             s             10i 0
     D name            s            128a
     D protocol        s            128a
     D p_aliases       s               *   dim( 12 )  based( s_aliases )
     D aliases         s            128a   dim( %elem( p_aliases ))
     **
      /free

       p_servent = getservbyport( 443: *null );

       if p_servent <> *null;
         name      = %str( s_name );
         protocol  = %str( s_proto );

         for idx = 1 to %elem( p_aliases );
           if  p_aliases(idx) = *null;
             leave;
           endif;

           aliases(idx) = %str( p_aliases(idx));
         endfor;
       endif;

       p_servent = getservbyport( 443: 'udp' );

       if p_servent <> *null;
         name      = %str( s_name );
         protocol  = %str( s_proto );

         for idx = 1 to %elem( p_aliases );
           if  p_aliases(idx) = *null;
             leave;
           endif;

           aliases(idx) = %str( p_aliases(idx));
         endfor;
       endif;

       *inlr = *on;
       return;

      /end-free

The first call returns the first server registered to the specified port.
The second call returns the service name for the specified port's 'udp'
protocol entry.

If you need to call the getservbyport() function repeatedly, the
setservent() and endservent() functions allow you to control when the
service database file is opened and closed, leaving it open for the
getservbyport() calls. The getservent() function enables you to retrieve a
sequential list of the servers in the service database.

Thanks to Carsten Flensburg
Back

StatvFs
Get File System Information

     H DFTACTGRP(*NO)

      /copy statvfs_h

     D chkflag         PR             1N
     D   field                       10U 0 value
     D   bit                         10U 0 value
     D getsize         PR            15A   varying
     D   size                        10U 0 value

     D fstype          s             80A   varying
     D vfs             ds                  likeds(ds_statvfs)
     D msg             s             52A
     D peObj           s             32A

     c     *entry        plist
     c                   parm                    peObj

     c                   if        statvfs(%trimr(peObj): vfs) = -1
     c                   eval      msg = 'statvfs() failed.'
     c                   dsply                   msg
     c                   eval      *inlr = *on
     c                   return
     c                   endif

     c                   eval      msg = 'Object = ' + peObj
     c     msg           dsply

     c                   eval      fstype = %str(%addr(vfs.f_basetype))
     c                   eval      msg = 'FS Type: ' + fstype
     c     msg           dsply

     c                   eval      msg = 'Block size: ' +
     c                                 getsize(vfs.f_bsize)
     c     msg           dsply

     c                   if        vfs.f_bsize <> 0

     c                   eval      msg = 'Total blocks: ' +
     c                                  %char(vfs.f_blocks)
     c     msg           dsply

     c                   eval      msg = 'Blocks free: ' +
     c                                  %char(vfs.f_bfree)
     c     msg           dsply

     c                   endif

     c                   eval      msg = 'Object link maximum: ' +
     c                                  %char(vfs.f_objlinkmax)
     c     msg           dsply

     c                   eval      msg = 'Directory link maximum: ' +
     c                                  %char(vfs.f_dirlinkmax)
     c     msg           dsply

     c                   eval      msg = 'Pathname component max: ' +
     c                                  getsize(vfs.f_namemax)
     c     msg           dsply

     c                   eval      msg = 'Path name maximum: ' +
     c                                  getsize(vfs.f_pathmax)
     c     msg           dsply

     c                   if        chkflag(vfs.f_flag: ST_RDONLY)
     c                   eval      msg = 'Read Only = Yes'
     c                   else
     c                   eval      msg = 'Read Only = No'
     c                   endif
     c     msg           dsply

     c                   if        chkflag(vfs.f_flag: ST_NOSUID)
     c                   eval      msg = 'Set Userid Allowed = No'
     c                   else
     c                   eval      msg = 'Set Userid Allowed = Yes'
     c                   endif
     c     msg           dsply

     c                   if        chkflag(vfs.f_flag: ST_CASE_SENSITITIVE)
     c                   eval      msg = 'Case Sensitivity = Yes'
     c                   else
     c                   eval      msg = 'Case Sensitivity = No'
     c                   endif
     c     msg           dsply

     c                   if        chkflag(vfs.f_flag: ST_CHOWN_RESTRICTED)
     c                   eval      msg = 'Chg Owner restricted = Yes'
     c                   else
     c                   eval      msg = 'Chg Owner restricted = No'
     c                   endif
     c     msg           dsply

     c                   if        chkflag(vfs.f_flag: ST_THREAD_SAFE)
     c                   eval      msg = 'Threadsafe = Yes'
     c                   else
     c                   eval      msg = 'Threadsafe = No'
     c                   endif
     c     msg           dsply

     c                   if        chkflag(vfs.f_flag: ST_DYNAMIC_MOUNT)
     c                   eval      msg = 'Dynamic mount = Yes'
     c                   else
     c                   eval      msg = 'Dynamic mount = No'
     c                   endif
     c     msg           dsply

     c                   if        chkflag(vfs.f_flag: ST_NO_EXPORTS)
     c                   eval      msg = 'Can be exported = No'
     c                   else
     c                   eval      msg = 'Can be exported = Yes'
     c                   endif
     c     msg           dsply

     c                   if        chkflag(vfs.f_flag: ST_SYNCHRONOUS)
     c                   eval      msg = 'Sync write support = Yes'
     c                   else
     c                   eval      msg = 'Sync write support = No'
     c                   endif
     c                   dsply                   msg

     c                   eval      *inlr = *on
     c                   return

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      *  chkflag():  Check whether a flag bit is set
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P chkflag         B
     D chkflag         PI             1N
     D   field                       10U 0 value
     D   bit                         10U 0 value
     c                   return    (%bitand(field:bit) <> 0)
     P                 E

      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      *  getsize():  Get human-readable size info
      *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     P getsize         B
     D getsize         PI            15A   varying
     D   size                        10U 0 value
     c                   select
     c                   when      size = 0
     c                   return    'Not defined'
     c                   when      size = *HIVAL
     c                   return    'No maximum'
     c                   other
     c                   return    %char(size)
     c                   endsl
     P                 E

Here's the source for member "STATVFS_H":
      /if defined(STATVFS_H_DEFINED)
      /eof
      /endif

      /define STATVFS_H_DEFINED

      *---------------------------------------------------------------
      * ds_statvfs - data structure to receive file system info
      *
      *   f_bsize   = file system block size (in bytes)
      *   f_frsize  = fundamental block size in bytes.
      *                if this is zero, f_blocks, f_bfree and f_bavail
      *                are undefined.
      *   f_blocks  = total number of blocks (in f_frsize)
      *   f_bfree   = total free blocks in filesystem (in f_frsize)
      *   f_bavail  = total blocks available to users (in f_frsize)
      *   f_files   = total number of file serial numbers
      *   f_ffree   = total number of unused file serial numbers
      *   f_favail  = number of available file serial numbers to users
      *   f_fsid    = filesystem ID.  This will be 4294967295 if it's
      *                too large for a 10U 0 field. (see f_fsid64)
      *   f_flag    = file system flags (see below)
      *   f_namemax = max filename length.  May be 4294967295 to
      *                indicate that there is no maximum.
      *   f_pathmax = max pathname legnth.  May be 4294967295 to
      *                indicate that there is no maximum.
      *   f_objlinkmax = maximum number of hard-links for objects
      *                other than directories
      *   f_dirlinkmax = maximum number of hard-links for directories
      *   f_fsid64  = filesystem id (in a 64-bit integer)
      *   f_basetype = null-terminated string containing the file
      *                  system type name.  For example, this might
      *                  be "root" or "Network File System (NFS)"
      *
      *  Since f_basetype is null-terminated, you should read it
      *  in ILE RPG with:
      *       myString = %str(%addr(ds_statvfs.f_basetype))
      *---------------------------------------------------------------
     D ds_statvfs      DS                  qualified
     D  f_bsize                      10U 0
     D  f_frsize                     10U 0
     D  f_blocks                     20U 0
     D  f_bfree                      20U 0
     D  f_bavail                     20U 0
     D  f_files                      10U 0
     D  f_ffree                      10U 0
     D  f_favail                     10U 0
     D  f_fsid                       10U 0
     D  f_flag                       10U 0
     D  f_namemax                    10U 0
     D  f_pathmax                    10U 0
     D  f_objlinkmax                 10I 0
     D  f_dirlinkmax                 10I 0
     D  f_reserved1                   4A
     D  f_fsid64                     20U 0
     D  f_basetype                   80A

      *---------------------------------------------------------------
      * flags specified in the f_flags element of the ds_statvfs
      *   data structure.
      *---------------------------------------------------------------
     D ST_RDONLY...
     D                 C                   CONST(1)
     D ST_NOSUID...
     D                 C                   CONST(2)
     D ST_CASE_SENSITITIVE...
     D                 C                   CONST(4)
     D ST_CHOWN_RESTRICTED...
     D                 C                   CONST(8)
     D ST_THREAD_SAFE...
     D                 C                   CONST(16)
     D ST_DYNAMIC_MOUNT...
     D                 C                   CONST(32)
     D ST_NO_MOUNT_OVER...
     D                 C                   CONST(64)
     D ST_NO_EXPORTS...
     D                 C                   CONST(128)
     D ST_SYNCHRONOUS...
     D                 C                   CONST(256)

      *---------------------------------------------------------------
      * statvfs() -- Get file system status
      *
      *    path = (input) pathname of a link ("file") in the IFS.
      *     buf = (output) data structure containing file system info
      *
      * Returns 0 if successful, -1 upon error.
      * (error information is returned via the "errno" variable)
      *---------------------------------------------------------------
     D statvfs         PR            10I 0 ExtProc('statvfs64')
     D   path                          *   value options(*string)
     D   buf                               like(ds_statvfs)

Thanks to Carsten Flensburg
Back

QUSCRTUQ & QLICVTTP & QUILNGTX
QUSCRTUQ: Create user queue
QLICVTTP : Convert object type
QUILNGTX : Display long text

     **  Program . . : CBX1150
     **  Description : Test user queues - client function
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : February 19, 2004
     **
     **
     **  Program summary
     **  ---------------
     **
     **    This program offers some simple templates for a number of the
     **    MI builtins and C library function used to address user queues
     **    - here's a list of all available functions:
     **
     **    C library functions:
     **      'enq'       Enqueue
     **      'deq'       Dequeue
     **      'deqi'      Dequeue with indicator
     **      'matqmsg'   Materialize queue messages
     **      'matqat'    Materialize queue attributes
     **
     **    MI builtins:
     **      '_ENQ'      Enqueue
     **      '_DEQ'      Dequeue
     **      '_DEQWAIT'  Dequeue with wait
     **      '_MATQMSG'  Materialize queue messages
     **      '_MATQAT'   Materialize queue attributes
     **
     **
     **  Programmer's notes:
     **    Functionally user queues are very much the same as data queues: They
     **    provide asynchronous communication between programs, and the stored
     **    messages can be retrieved by arrival sequence or key.
     **
     **    The major advantage of user queues over data queues is speed; they are
     **    faster than data queues. On the other hand user queues are a bit more
     **    complicated to put into action; you need to resolve a system pointer
     **    to the user queue to be able to call the various user queue functions
     **    and for example get acqainted with such constructs as bit-fields that
     **    enables you to reference single bits at field level.
     **
     **    This program offers a number of examples of some - but not all - of
     **    the user queue functions, for you to use as a starting point in the
     **    event that you should want to include user queues in your tool box.
     **    You can find more information in the MI Functional Reference and the
     **    ILE C/C++ for iSeries Run-Time Library Functions manuals.
     **
     **    To run this sample program compile it as described below, start a
     **    debug session, call it, and then step throug the program in the
     **    debugger:
     **
     **    StrDbg    Pgm( CBX1150 ) - Press F10
     **
     **    Call      Pgm( CBX1150 ) - Press F10 repeatedly
     **
     **
     **  Compile options:
     **    First, create the CBX115S service program.  (Instructions can be
     **      found in the CBX115S source member.)
     **
     **    CrtRpgMod Module( CBX1150 )  DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX1150 )
     **              Module( CBX1150 )
     **              ActGrp( QILE )
     **              BndSrvPgm( CBX115S )
     **
     **
     **-- Header specifications:  --------------------------------------------**
     H Option( *SrcStmt )  BndDir( 'QC2LE' )
     **-- API Error Data Structure:  -----------------------------------------**
     D ApiError        Ds
     D  AeBytPro                     10i 0 Inz( %Size( ApiError ))
     D  AeBytAvl                     10i 0 Inz
     D                                1a
     D  AeExcpId                      7a
     D  AeExcpDta                   256a
     **-- Global variables:  -------------------------------------------------**
     D UsrQuePtrF      s               *   ProcPtr
     D UsrQuePtrK      s               *   ProcPtr
     D MsgDeq          s             10i 0
     **
     D EnqMsg          s           1024a
     D DeqMsg          s           1024a
     **-- Global constants:  -------------------------------------------------**
     D DeqGt           c                   x'02'
     D DeqLt           c                   x'04'
     D DeqNe           c                   x'06'
     D DeqEq           c                   x'08'
     D DeqGe           c                   x'0A'
     D DeqLe           c                   x'0C'
     **
     D TimeDeqGt       c                   x'02'
     D TimeDeqLt       c                   x'04'
     D TimeDeqNe       c                   x'06'
     D TimeDeqEq       c                   x'08'
     D TimeDeqGe       c                   x'0A'
     D TimeDeqLe       c                   x'0C'
     **
     D WaitDeq         c                   x'10'
     D WaitDeqGt       c                   x'12'
     D WaitDeqLt       c                   x'14'
     D WaitDeqNe       c                   x'16'
     D WaitDeqEq       c                   x'18'
     D WaitDeqGe       c                   x'1A'
     D WaitDeqLe       c                   x'1C'
     **-- Enqueue message prefix:  -------------------------------------------**
     D EnqMsgPfx       Ds
     D  EpMsgLen                     10i 0
     D  EpEnqKey                      3a
     **-- Dequeue message prefix:  -------------------------------------------**
     D DeqMsgPfx       Ds
     D  DpTimStp                      8a
     D  DqWaitTim                     8a
     D  DqMsgLen                     10i 0 Inz
     D  DqOption                      1a
     **  DqAccSt1: 1; Bit weight 8
     **  DqAccSt2: 1; -   -      4
     **  DqMPL   : 1; -   -      2
     **  DqWait4e: 1; -   -      1
     **  DqKeyRel: 4; -   -      8-1
     D  DqKey                         3a
     D  DqKeyRtn                           Like( DqKey )
     **-- Queue attributes:  -------------------------------------------------**
     D QueAtr          Ds
1    D  QaBytPrv                     10i 0 Inz( %Size( QueAtr ))
     D  QaBytAvl                     10i 0
9    D  QaObjId                      32a
     D   QaObjTyp                     1a   Overlay( QaObjId: 1 )
     D   QaObjSub                     1a   Overlay( QaObjId: *Next )
     D   QaObjNam                    30a   Overlay( QaObjId: *Next )
41   D  QaCrtOptBf                    4a
45   D                                4a
49   D  QaSpcSiz                     10i 0
53   D  QaSpcInzVal                   1a
54   D  QaPfrClsBf                    4a
58   D                                7a
65   D  QaCtx                          *   ProcPtr
81   D  QaAccGrp                       *   ProcPtr
97   D  QaQueAtrBf                    1a
98   D  QaCurMaxMsg                  10i 0
102  D  QaCurMsgEnq                  10i 0
106  D  QaExtVal                     10i 0
110  D  QaKeyLen                      5i 0
112  D  QaMaxSizMsg                  10i 0
116  D                                1a
117  D  QaMaxNbrExt                  10i 0
121  D  QaCurNbrExt                  10i 0
125  D  QaInzNbrMsg                  10i 0
     **-- Enqueue message:  --------------------------------------------------**
     D enqMI           Pr                  ExtProc( '_ENQ' )
     D  QuePtr                         *   ProcPtr
     D  MsgPfx                      256a   Options( *VarSize )
     D  MsgTxt                    32767a   Options( *VarSize )
     **-- Dequeue message with wait:  ----------------------------------------**
     D deqwait         Pr                  ExtProc( '_DEQWAIT' )
     D  MsgPfx                      256a   Options( *VarSize )
     D  MsgTxt                    32767a   Options( *VarSize )
     D  QuePtr                         *   ProcPtr
129  **-- Enqueue message:  --------------------------------------------------**
     D enq             Pr                  ExtProc( 'enq' )
     D  QuePtr                         *   ProcPtr  Value
     D  MsgPfx                      256a   Const  Options( *VarSize )
     D  MsgTxt                    32767a   Const  Options( *VarSize )
     **-- Dequeue message:  --------------------------------------------------**
     D deq             Pr                  ExtProc( 'deq' )
     D  MsgPfx                      256a   Options( *VarSize )
     D  MsgTxt                    32767a   Options( *VarSize )
     D  QuePtr                         *   ProcPtr  Value
     **-- Dequeue message with indicator:  -----------------------------------**
     D deqi            Pr            10i 0 ExtProc( 'deqi' )
     D  MsgPfx                      296a   Options( *VarSize )
     D  MsgTxt                    32767a   Options( *VarSize )
     D  QuePtr                         *   ProcPtr  Value
     **-- Materialize queue attributes:  -------------------------------------**
     D matqat          Pr                  ExtProc( 'matqat' )
     D  RcvAtr                      128a
     D  QuePtr                         *   ProcPtr  Value
     **-- Wait seconds:  -----------------------------------------------------**
     D sleep           Pr            10i 0 ExtProc( 'sleep' )
     D  seconds                      10u 0 Value
     **-- Wait microseconds:  ------------------------------------------------**
     D usleep          Pr            10i 0 ExtProc( 'usleep' )
     D  useconds                     10u 0 Value
     **-- Create user queue:  ------------------------------------------------**
     D CrtUsrQ         Pr                  ExtPgm( 'QUSCRTUQ' )
     D  CuUsrQqual                   20a   Const
     D  CuExtAtr                     10a   Const
     D  CuQueTyp                      1a   Const
     D  CuKeyLen                     10i 0 Const
     D  CuMaxMsgSiz                  10i 0 Const
     D  CuInzNbrMsg                  10i 0 Const
     D  CuAddNbrMsg                  10i 0 Const
     D  CuPubAut                     10a   Const
     D  CuTxtDsc                     50a   Const
     **
     D  CuRplQue                     10a   Const  Options( *NoPass )
     D  CuError                   32767a          Options( *NoPass: *VarSize )
     **
     D  CuQueDmn                     10a   Const  Options( *NoPass )
     D  CuAlwPtr                     10a   Const  Options( *NoPass )
     **
     D  CuNbqExt                     10i 0 Const  Options( *NoPass )
     D  CuRclStg                      1a   Const  Options( *NoPass )
     **-- Get current number of queue entries:  ------------------------------**
     D GetCurNbrE      Pr            10i 0
     D  PxQuePtr                       *   ProcPtr
     **-- Get system pointer:  -----------------------------------------------**
     D GetSysPtr       Pr              *   ProcPtr
     D  PxObjNam                     10a   Const
     D  PxObjLib                     10a   Const
     D  PxObjTyp                     10a   Const
     **-- Get MI time value:  ------------------------------------------------**
     D GetTimVal       Pr             8a
     D  PxSeconds                    10u 0 Const
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   CallP     CrtUsrQ( 'USRQ      QTEMP'
     C                                    : 'TESTUSRQ'
     C                                    : 'F'
     C                                    : *Zero
     C                                    : 1024
     C                                    : 256
     C                                    : 128
     C                                    : '*ALL'
     C                                    : 'Test user queue'
     C                                    : '*YES'
     C                                    : ApiError
     C                                    : '*USER'
     C                                    : '*NO'
     C                                    )
     **
     C                   CallP     CrtUsrQ( 'USRQKEY   QTEMP'
     C                                    : 'TESTUSRQ'
     C                                    : 'K'
     C                                    : 3
     C                                    : 1024
     C                                    : 256
     C                                    : 128
     C                                    : '*ALL'
     C                                    : 'Test user queue - key'
     C                                    : '*YES'
     C                                    : ApiError
     C                                    : '*USER'
     C                                    : '*NO'
     C                                    )
     **
     C                   Eval      UsrQuePtrF =  GetSysPtr( 'USRQ'
     C                                                    : 'QTEMP'
     C                                                    : '*USRQ'
     C                                                    )
     **
     C                   If        UsrQuePtrF <> *Null
     **
     C                   Eval      UsrQuePtrK =  GetSysPtr( 'USRQKEY'
     C                                                    : 'QTEMP'
     C                                                    : '*USRQ'
     C                                                    )
     **
     C                   If        UsrQuePtrK <> *Null
     **
     C                   ExSr      TstEnqNoKey
     C                   ExSr      TstDeqNoKey
     **
     C                   ExSr      TstEnqKey
     C                   ExSr      TstDeqKey
     **
     C                   ExSr      TstEnqMiKey
     C                   ExSr      TstDeqKey
     **
     C                   ExSr      TstEnqMiKey
     C                   ExSr      TstDeqiKey
     **
     C                   ExSr      TstEnqKey
     C                   ExSr      TstDeqwKey
     **
     C                   EndIf
     C                   EndIf
     **
     C                   Eval      *InLr      =  *On
     C                   Return
     **
     **-- Test enq no key:  --------------------------------------------------**
     C     TstEnqNoKey   BegSr
     **
     C                   Eval      EnqMsg     =  'Test FIFO message 1'
     C                   Eval      EpMsgLen   =  %Len( %TrimR( EnqMsg ))
     **
     C                   CallP     enq( UsrQuePtrF: EnqMsgPfx: EnqMsg )
     **
     C                   EndSr
     **-- Test enq key:  -----------------------------------------------------**
     C     TstEnqKey     BegSr
     **
     C                   Eval      EnqMsg     =  'Test key message 1'
     C                   Eval      EpEnqKey   =  'KEY'
     C                   Eval      EpMsgLen   =  %Len( %TrimR( EnqMsg ))
     **
     C                   CallP     enq( UsrQuePtrK: EnqMsgPfx: EnqMsg )
     **
     C                   EndSr
     **-- Test enqMI key:  ---------------------------------------------------**
     C     TstEnqMiKey   BegSr
     **
     C                   Eval      EnqMsg     =  'Test key message 2'
     C                   Eval      EpEnqKey   =  'KEY'
     C                   Eval      EpMsgLen   =  %Len( %TrimR( EnqMsg ))
     **
     C                   CallP     enqMI( UsrQuePtrK: EnqMsgPfx: EnqMsg )
     **
     C                   EndSr
     **-- Test deq no key:  --------------------------------------------------**
     C     TstDeqNoKey   BegSr
     **
     C                   Eval      DqKey      =  *Blanks
     C                   Eval      DqOption   =  WaitDeq
     **
     C                   DoW       GetCurNbrE( UsrQuePtrF ) > *Zero
     **
     C                   CallP(e)  deq( DeqMsgPfx: DeqMsg: UsrQuePtrF )
     **
     C                   If        Not %Error
     C                   ExSr      PrcUsrQe
     C                   EndIf
     **
     C                   EndDo
     **
     C                   EndSr
     **-- Test deq key:  -----------------------------------------------------**
     C     TstDeqKey     BegSr
     **
     C                   Eval      DqKey      =  'KEY'
     C                   Eval      DqOption   =  TimeDeqEq
     C                   Eval      DqWaitTim  =  GetTimVal( 5 )
     **
     C                   Do        3
     **
     C                   CallP(e)  deq( DeqMsgPfx: DeqMsg: UsrQuePtrK )
     **
     C                   If        Not %Error
     C                   ExSr      PrcUsrQe
     **
     C                   Else
     C                   CallP     usleep( 500000 )
     C                   EndIf
     **
     C                   EndDo
     **
     C                   EndSr
     **-- Test deqi key:  ----------------------------------------------------**
     C     TstDeqiKey    BegSr
     **
     C                   Eval      DqOption   =  TimeDeqEq
     C                   Eval      DqKey      =  'KEY'
     **
     C                   DoW       GetCurNbrE( UsrQuePtrK ) > *Zero
     **
     C                   Eval      MsgDeq     =  deqi( DeqMsgPfx
     C                                               : DeqMsg
     C                                               : UsrQuePtrK
     C                                               )
     **
     C                   If        MsgDeq     =  1
     C                   ExSr      PrcUsrQe
     C                   EndIf
     **
     C                   CallP     sleep( 1 )
     C                   EndDo
     **
     C                   EndSr
     **-- Test deqwait key:  -------------------------------------------------**
     C     TstDeqwKey    BegSr
     **
     C                   Eval      DqKey      =  'KEY'
     C                   Eval      DqOption   =  TimeDeqEq
     C                   Eval      DqWaitTim  =  GetTimVal( 7 )
     **
     C                   DoW       GetCurNbrE( UsrQuePtrK ) > *Zero
     **
     C                   CallP(e)  deqwait( DeqMsgPfx: DeqMsg: UsrQuePtrK )
     **
     C                   If        Not %Error
     C                   ExSr      PrcUsrQe
     C                   EndIf
     **
     C                   EndDo
     **
     C                   EndSr
     **-- Process user queue entry:  -----------------------------------------**
     C     PrcUsrQe      BegSr
     **
     C                   Eval      DeqMsg     =  %Subst( DeqMsg: 1: DqMsgLen )
     **
     C                   EndSr
     **-- Get current number of queue entries:  ------------------------------**
     P GetCurNbrE      B
     D                 Pi            10i 0
     D  PxQuePtr                       *   ProcPtr
     **
     C                   If        PxQuePtr    = *Null
     C                   Return    -1
     C                   Else
     **
     C                   CallP(e)  matqat( QueAtr: PxQuePtr )
     **
     C                   If        %Error
     C                   Return    -1
     **
     C                   Else
     C                   Return    QaCurMsgEnq
     C                   EndIf
     C                   EndIf
     **
     P GetCurNbrE      E

     **  Program . . : CBX1151
     **  Description : Test user queues - server function
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : February 19, 2004
     **
     **
     **  Program summary
     **  ---------------
     **
     **  MI builtins:
     **    _ENQ          Enqueue message       Puts a message to the user queue
     **                                        specified.  An optional key used
     **                                        at message retrieval time can be
     **                                        specified.
     **
     **                                        The actual user queue is defined
     **                                        by a system pointer.
     **
     **    _DEQWAIT      Dequeue message       Gets a message from the specified
     **                  with wait             user queue.  The retrieval order
     **                                        is defined at queue creation time
     **                                        and includes first-in-first-out,
     **                                        last-in-first-out and by-key.
     **
     **                                        The wait time is specified in the
     **                                        dequeue message prefix parameter.
     **                                        If a time-out occurs the builtin
     **                                        returns an exception to the
     **                                        calling program.
     **
     **                                        The actual user queue is defined
     **                                        by a system pointer.
     **
     **  C library function:
     **    cvthc         Convert hex to        Converts a character string to
     **                  character             its hexadecimal representation
     **                                        in the form of 4-bit sequences
     **                                        also known as nibbles.
     **
     **
     **  Sequence of events:
     **    1. The put and get user queue names as well as the library they are
     **       located in are received as input paramters and a system pointer
     **       to each is resolved.
     **
     **    2. Being a server function the program then waits indefinetely for
     **       client requests to be received from the get user queue. To ensure
     **       that the right client receives the reply, a unique key is included
     **       in the request message structure. Also included is a request type
     **       defining the type of action to be performed by the server.
     **
     **    3. Once a request is received it is processed based on the request
     **       type. Two request types are supported.
     **
     **         *CVTHEX will convert the received message string to its
     **         hexadecimal representation and put the converted string
     **         to the reply user queue and the retreived key from the
     **         request message structure is supplied as retrieval key.
     **
     **         *STOP will end the server job immediately.
     **
     **    4. When a reply has been returned, the server will continue waiting
     **       indefinetely for the next request to arrive.
     **
     **    5. If the server job has been requested to stop processing, the
     **       wait loop is exited and the job is ended normally.
     **
     **
     **  Compile options:
     **    First, create the CBX115S service program.  (Instructions can be
     **      found in the CBX115S source member.)
     **
     **    CrtRpgMod Module( CBX1151 )  DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX1151 )
     **              Module( CBX1151 )
     **              ActGrp( QILE )
     **              BndSrvPgm( CBX115S )
     **
     **
     **-- Header specifications:  --------------------------------------------**
     H Option( *SrcStmt )  BndDir( 'QC2LE' )
     **-- Global variables:  -------------------------------------------------**
     D RqsQuePtr       s               *   ProcPtr
     D RpyQuePtr       s               *   ProcPtr
     D RqsHdrSiz       s             10i 0
     **
     D EnqMsg          s           1024a
     **
     D DeqMsg          Ds
     D  DmRpyKey                     16a
     D  DmRqsTyp                      8a
     D  DmRqsMsg                   1000a
     **-- Global constants:  -------------------------------------------------**
     D WaitDeq         c                   x'10'
     **-- Enqueue message prefix:  -------------------------------------------**
     D EnqMsgPfx       Ds
     D  EqMsgLen                     10i 0
     D  EqEnqKey                     16a
     **-- Dequeue message prefix:  -------------------------------------------**
     D DeqMsgPfx       Ds
     D  DqTimStp                      8a
     D  DqWaitTim                     8a
     D  DqMsgLen                     10i 0 Inz
     D  DqOption                      1a
     **  DqAccSt1: 1; Bit weight 8
     **  DqAccSt2: 1; -   -      4
     **  DqMPL   : 1; -   -      2
     **  DqWait4e: 1; -   -      1
     **  DqKeyRel: 4; -   -      8-1
     D  DqKey                        16a
     **-- Enqueue message:  --------------------------------------------------**
     D enq             Pr                  ExtProc( '_ENQ' )
     D  QuePtr                         *   ProcPtr
     D  MsgPfx                      256a   Options( *VarSize )
     D  MsgTxt                    32767a   Options( *VarSize )
     **-- Dequeue message with wait:  ----------------------------------------**
     D deqwait         Pr                  ExtProc( '_DEQWAIT' )
     D  MsgPfx                      256a   Options( *VarSize )
     D  MsgTxt                    32767a   Options( *VarSize )
     D  QuePtr                         *   ProcPtr
     **-- Convert hex to character:  -----------------------------------------**
     D cvthc           Pr              *   ExtProc( 'cvthc' )
     D                                 *   Value
     D                                 *   Value
     D                               10I 0 Value
     **-- Get system pointer:  -----------------------------------------------**
     D GetSysPtr       Pr              *   ProcPtr
     D  PxObjNam                     10a   Const
     D  PxObjLib                     10a   Const
     D  PxObjTyp                     10a   Const
     **-- Parameters:  -------------------------------------------------------**
     D PxRqsQueNam     s             10a
     D PxRpyQueNam     s             10a
     D PxQueLib        s             10a
     **
     C     *Entry        Plist
     C                   Parm                    PxRqsQueNam
     C                   Parm                    PxRpyQueNam
     C                   Parm                    PxQueLib
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      RqsQuePtr  =  GetSysPtr( PxRqsQueNam
     C                                                    : PxQueLib
     C                                                    : '*USRQ'
     C                                                    )
     **
     C                   If        RqsQuePtr  <> *Null
     **
     C                   Eval      RpyQuePtr  =  GetSysPtr( PxRpyQueNam
     C                                                    : PxQueLib
     C                                                    : '*USRQ'
     C                                                    )
     **
     C                   If        RpyQuePtr  <> *Null
     **
     C                   DoU       *InLr      =  *On
     **
     C                   ExSr      DeqRqsMsg
     **
     C                   If        *InLr      =  *Off
     C                   ExSr      PrcRqsMsg
     C                   ExSr      EnqRpyMsg
     C                   EndIf
     **
     C                   EndDo
     **
     C                   EndIf
     C                   EndIf
     **
     C                   Return
     **
     **-- Dequeue request message:  ------------------------------------------**
     C     DeqRqsMsg     BegSr
     **
     C                   Eval      DqKey      =  *Blanks
     C                   Eval      DqOption   =  WaitDeq
     **
     C                   CallP(e)  deqwait( DeqMsgPfx: DeqMsg: RqsQuePtr )
     **
     C                   If        Not %Error
     C                   Eval      DeqMsg     =  %Subst( DeqMsg: 1: DqMsgLen )
     C                   Eval      EnqMsg     =  *Blanks
     **
     C                   If        DmRqsTyp   =  '*STOP '
     C                   Eval      *InLr      =  *On
     C                   EndIf
     C                   EndIf
     **
     C                   EndSr
     **-- Enqueue reply message:  --------------------------------------------**
     C     EnqRpyMsg     BegSr
     **
     C                   Eval      EqEnqKey   =  DmRpyKey
     C                   Eval      EqMsgLen   =  %Len( %TrimR( EnqMsg ))
     **
     C                   CallP     enq( RpyQuePtr: EnqMsgPfx: EnqMsg )
     **
     C                   EndSr
     **-- Process request message:  ------------------------------------------**
     C     PrcRqsMsg     BegSr
     **
     C                   If        DmRqsTyp   =  '*CVTHEX'
     **
     C                   CallP     cvthc( %Addr( EnqMsg )
     C                                  : %Addr( DmRqsMsg )
     C                                  : 2 * ( DqMsgLen - RqsHdrSiz )
     C                                  )
     **
     C                   EndIf
     **
     C                   EndSr
     **-- Initial processing:  -----------------------------------------------**
     C     *InzSr        BegSr
     **
     C                   Eval      RqsHdrSiz  =  %Size( DmRpyKey ) +
     C                                           %Size( DmRqsTyp )
     **
     C                   EndSr

     **  Program . . : CBX1152
     **  Description : Test user queues - client function
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : February 19, 2004
     **
     **
     **  Program summary
     **  ---------------
     **
     **  MI builtins:
     **    _ENQ          Enqueue message       Puts a message to the user queue
     **                                        specified.  An optional key used
     **                                        at message retrieval time can be
     **                                        specified.
     **
     **                                        The actual user queue is defined
     **                                        by a system pointer.
     **
     **    _DEQWAIT      Dequeue message       Gets a message from the specified
     **                  with wait             user queue.  The retrieval order
     **                                        is defined at queue creation time
     **                                        and includes first-in-first-out,
     **                                        last-in-first-out and by-key.
     **
     **                                        The wait time is specified in the
     **                                        dequeue message prefix parameter.
     **                                        If a time-out occurs the builtin
     **                                        returns an exception to the
     **                                        calling program.
     **
     **                                        The actual user queue is defined
     **                                        by a system pointer.
     **
     **    _GENUUID      Generate universal    Returns a 16 byte token that is
     **                  unique identifier     guaranteed to be unique across
     **                                        all time and space - or as its
     **                                        name says, universally unique.
     **
     **  User interface manager APIs:
     **    QUILNGTX      Display long text     Displays the text string passed
     **                                        to the API in a pop-up window.
     **                                        Optionally a panel title can be
     **                                        retrieved from a message file.
     **
     **                                        Maximum string length is 15360k.
     **
     **  Message handling API:
     **    QMHSNDPM      Send program message  Sends a message to a program stack
     **                                        entry (current, previous, etc.) or
     **                                        an external message queue.
     **
     **                                        Both messages defined in a message
     **                                        file and immediate messages can be
     **                                        used. For specific message types
     **                                        only one or the other is allowed.
     **
     **    QMHRCVPM      Receive program       Returns information describing
     **                  message               the selected message in a call
     **                                        message queue or, as in this
     **                                        case, an external message queue.
     **
     **
     **  Sequence of events:
     **    1. The put and get user queue names as well as the library they are
     **       located in are received as input paramters and a system pointer
     **       to each is resolved.
     **
     **    2. An inquiry message is sent to the external message queue, waiting
     **       for an input string to process. Upon receiving an actual reply,
     **       a unique key is generated to be included with the request message
     **       to ensure correct retrieval of the corresponding reply, and the
     **       request message is put to the request user queue.
     **
     **    3. Next the dequeue parameters are set, a time-out value of 5 seconds
     **       and the retrieval key that the reply was associated with in step 2.
     **       If a time-out occurs an informational message is displayed in a
     **       window, otherwise the result of the hexadecimal conversion of the
     **       input string is displayed.
     **
     **    4. If an empty reply is received in step 2 a 'terminate processing'
     **       message is sent to the server job and this program returns control
     **       to its caller, to delete the user queues involved and end the test
     **       application.
     **
     **
     **  Programmer's notes:
     **    User reports have surfaced, indicating that the GENUUID function
     **    - under certain circumstances - might have a problem generating a
     **    truly unique identifier on multi-processor iSeries machines.
     **
     **    But apparently this has not yet lead to the opening of an APAR so
     **    there is currently no conclusive information available on this
     **    matter.
     **
     **    The message dialogue developed for the purpose of this user queue
     **    test application is by no means adequate for a genuine production
     **    environment.
     **
     **    In real life it is crucial to invest the time necessary to develop
     **    a robust and flexible data protocol up front, covering some of the
     **    following aspects:
     **
     **      -  Request and reply message indentification
     **      -  Message version identification
     **      -  Error code and message reporting
     **      -  Message definition design (proprietary or standard)
     **      -  Expanding list support (to avoid message length constraints)
     **      -  National language support
     **      -  Normalization level of message record formats
     **
     **    And when dealing with some of the above questions it is in many
     **    cases worth considering to what extent XML would offer a useful
     **    solution.
     **
     **
     **  Compile options:
     **    First, create the CBX115S service program.  (Instructions can be
     **      found in the CBX115S source member.)
     **
     **    CrtRpgMod Module( CBX1152 )  DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX1152 )
     **              Module( CBX1152 )
     **              ActGrp( QILE )
     **              BndSrvPgm( CBX115S )
     **
     **
     **-- Header specifications:  --------------------------------------------**
     H Option( *SrcStmt )  BndDir( 'QC2LE' )
     **-- 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
     **-- Global variables:  -------------------------------------------------**
     D RqsQuePtr       s               *   ProcPtr
     D RpyQuePtr       s               *   ProcPtr
     D MsgKey          s              4a
     D MsgDta          s           1024a   Varying
     **
     D DeqMsg          s           1024a
     **
     D EnqMsg          Ds
     D  EmRpyKey                     16a
     D  EmRqsTyp                      8a
     D  EmRqsMsg                   1000a
     **-- Global constants:  -------------------------------------------------**
     D TimeDeqEq       c                   x'08'
     **-- Enqueue message prefix:  -------------------------------------------**
     D EnqMsgPfx       Ds
     D  EqMsgLen                     10i 0
     D  EqEnqKey                     16a
     **-- Dequeue message prefix:  -------------------------------------------**
     D DeqMsgPfx       Ds
     D  DqTimStp                      8a
     D  DqWaitTim                     8a
     D  DqMsgLen                     10i 0 Inz
     D  DqOption                      1a
     **  DqAccSt1: 1; Bit weight 8
     **  DqAccSt2: 1; -   -      4
     **  DqMPL   : 1; -   -      2
     **  DqWait4e: 1; -   -      1
     **  DqKeyRel: 4; -   -      8-1
     D  DqKey                        16a
     **-- UUID template:  ----------------------------------------------------**
     D UUID_template   Ds
     D  UtBytPrv                     10u 0 Inz( %Size( UUID_template ))
     D  UtBytAvl                     10u 0
     D                                8a   Inz( *Allx'00' )
     D  UUID                         16a
     **-- Message information structure:  ------------------------------------**
     D RCVM0100        Ds
     D  R1BytPrv                     10i 0
     D  R1BytAvl                     10i 0
     D  R1MsgSev                     10i 0
     D  R1MsgId                       7a
     D  R1MsgTyp                      2a
     D  R1MsgKey                      4a
     D                                7a
     D  R1CcsIdCnvSts                10i 0
     D  R1CcsIdDta                   10i 0
     D  R1MsgLen                     10i 0
     D  R1MsgLenAvl                  10i 0
     D  R1MsgRpy                   1024a
     **-- Enqueue:  ----------------------------------------------------------**
     D enq             Pr                  ExtProc( '_ENQ' )
     D  QuePtr                         *   ProcPtr
     D  MsgPfx                      256a   Options( *VarSize )
     D  MsgTxt                    32767a   Options( *VarSize )
     **-- Dequeue with wait:  ------------------------------------------------**
     D deqwait         Pr                  ExtProc( '_DEQWAIT' )
     D  MsgPfx                      256a   Options( *VarSize )
     D  MsgTxt                    32767a   Options( *VarSize )
     D  QuePtr                         *   ProcPtr
     **-- Generate universal unique identifier:  -------------------------- --**
     D GenUuid         Pr                  ExtProc( '_GENUUID' )
     D  UUID_template                  *   Value
     **-- 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 )
     **-- Receive program message:  ------------------------------------------**
     D RcvPgmMsg       Pr                  ExtPgm( 'QMHRCVPM' )
     D  RpRcvVar                  32767a          Options( *VarSize )
     D  RpRcvVarLen                  10i 0 Const
     D  RpFmtNam                     10a   Const
     D  RpCalStkE                   256a   Const  Options( *VarSize )
     D  RpCalStkCtr                  10i 0 Const
     D  RpMsgTyp                     10a   Const
     D  RpMsgKey                      4a   Const
     D  RpWait                       10i 0 Const
     D  RpMsgAct                     10a   Const
     D  RpError                   32767a          Options( *VarSize )
     **
     D  RpCalStkElen                 10i 0 Const  Options( *NoPass )
     D  RpCalStkEq                   20a   Const  Options( *NoPass )
     **
     D  RpCalStkEtyp                 20a   Const  Options( *NoPass )
     D  RpCcsId                      10i 0 Const  Options( *NoPass )
     **-- Display long text:  ------------------------------------------------**
     D DspLngTxt       Pr                  ExtPgm( 'QUILNGTX' )
     D  DtLngTxt                   1024a   Const  Options( *VarSize )
     D  DtLngTxtLen                  10i 0 Const
     D  DtMsgId                       7a   Const
     D  DtMsgF                       20a   Const
     D  DtError                      10i 0 Const
     **-- Get system pointer:  -----------------------------------------------**
     D GetSysPtr       Pr              *   ProcPtr
     D  PxObjNam                     10a   Const
     D  PxObjLib                     10a   Const
     D  PxObjTyp                     10a   Const
     **-- Get MI time value:  ------------------------------------------------**
     D GetTimVal       Pr             8a
     D  PxSec                        10u 0 Const
     **-- Parameters:  -------------------------------------------------------**
     D PxRqsQueNam     s             10a
     D PxRpyQueNam     s             10a
     D PxQueLib        s             10a
     **
     C     *Entry        Plist
     C                   Parm                    PxRqsQueNam
     C                   Parm                    PxRpyQueNam
     C                   Parm                    PxQueLib
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      RqsQuePtr  =  GetSysPtr( PxRqsQueNam
     C                                                    : PxQueLib
     C                                                    : '*USRQ'
     C                                                    )
     **
     C                   If        RqsQuePtr  <> *Null
     **
     C                   Eval      RpyQuePtr  =  GetSysPtr( PxRpyQueNam
     C                                                    : PxQueLib
     C                                                    : '*USRQ'
     C                                                    )
     **
     C                   If        RpyQuePtr  <> *Null
     **
     C                   DoU       *InLr      =  *On
     **
     C                   ExSr      GetRqsMsg
     C                   ExSr      EnqRqsMsg
     **
     C                   If        *InLr      =  *Off
     C                   ExSr      DeqRpyMsg
     C                   EndIf
     **
     C                   EndDo
     **
     C                   EndIf
     C                   EndIf
     **
     C                   Return
     **
     **-- Enqueue request message:  ------------------------------------------**
     C     EnqRqsMsg     BegSr
     **
     C                   Callp     GenUuid( %Addr( UUID_template ))
     **
     C                   Eval      EqEnqKey   =  *Blanks
     C                   Eval      EmRpyKey   =  UUID
     C                   Eval      EqMsgLen   =  %Len( %TrimR( EnqMsg ))
     **
     C                   CallP     enq( RqsQuePtr: EnqMsgPfx: EnqMsg )
     **
     C                   EndSr
     **-- Dequeue reply message:  --------------------------------------------**
     C     DeqRpyMsg     BegSr
     **
     C                   Eval      DqKey      =  UUID
     C                   Eval      DqOption   =  TimeDeqEq
     C                   Eval      DqWaitTim  =  GetTimVal( 5 )
     **
     C                   CallP(e)  deqwait( DeqMsgPfx: DeqMsg: RpyQuePtr )
     **
     C                   If        %Error
     C                   Exsr      HdlRpyTmo
     **
     C                   Else
     C                   Exsr      DspRpyMsg
     C                   EndIf
     **
     C                   EndSr
     **-- Handle reply timeout:  ---------------------------------------------**
     C     HdlRpyTmo     BegSr
     **
     C                   Eval      MsgKey     =  *Blanks
     **
     C                   CallP     RcvPgmMsg( RCVM0100
     C                                      : %Size( RCVM0100 )
     C                                      : 'RCVM0100'
     C                                      : '*'
     C                                      : *Zero
     C                                      : '*LAST'
     C                                      : MsgKey
     C                                      : -1
     C                                      : '*REMOVE'
     C                                      : ApiError
     C                                      )
     **
     C                   Eval      MsgDta      = 'The get user queue '     +
     C                                           'message timed out. '     +
     C                                           'Please check that the '  +
     C                                           'server job is active.'
     **
     C                   CallP(e)  DspLngTxt( MsgDta
     C                                      : %Len( MsgDta )
     C                                      : *Blanks
     C                                      : *Blanks
     C                                      : *Zero
     C                                      )
     **
     C                   EndSr
     **-- Display reply message:  --------------------------------------------**
     C     DspRpyMsg     BegSr
     **
     C                   Eval      MsgDta      = %TrimR( EmRqsMsg ) + ' -> ' +
     C                                           %SubSt( DeqMsg: 1: DqMsgLen )
     **
     C                   CallP(e)  DspLngTxt( MsgDta
     C                                      : %Len( MsgDta )
     C                                      : *Blanks
     C                                      : *Blanks
     C                                      : *Zero
     C                                      )
     **
     C                   EndSr
     **-- Get request message:  ----------------------------------------------**
     C     GetRqsMsg     BegSr
     **
     C                   Eval      MsgDta      = 'Please enter string '    +
     C                                           'to be converted to '     +
     C                                           'hex. To stop test just ' +
     C                                           'press enter.'
     **
     C                   CallP     SndPgmMsg( *Blanks
     C                                      : *Blanks
     C                                      : MsgDta
     C                                      : %Len( MsgDta )
     C                                      : '*INQ'
     C                                      : '*EXT'
     C                                      : *Zero
     C                                      : MsgKey
     C                                      : ApiError
     C                                      )
     **
     C                   CallP     RcvPgmMsg( RCVM0100
     C                                      : %Size( RCVM0100 )
     C                                      : 'RCVM0100'
     C                                      : '*'
     C                                      : *Zero
     C                                      : '*RPY'
     C                                      : MsgKey
     C                                      : -1
     C                                      : '*OLD'
     C                                      : ApiError
     C                                      )
     **
     C                   Eval      R1MsgRpy   =  %Subst( R1MsgRpy: 1: R1MsgLen )
     **
     C                   If        R1MsgRpy   =  '*N'
     C                   Eval      EmRqsTyp   =  '*STOP'
     C                   Eval      *InLr      =  *On
     **
     C                   Else
     C                   Eval      EmRqsTyp   =  '*CVTHEX'
     C                   Eval      EmRqsMsg   =  R1MsgRpy
     C                   EndIf
     **
     C                   EndSr

     **  Program . . : CBX115S
     **  Description : Test user queues - service functions
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : February 19, 2004
     **
     **
     **  Program summary
     **  ---------------
     **
     **  Object-related  API:
     **    QLICVTTP      Convert object type   Convert an iSeries object type to
     **                                        or from hexadecimal format.
     **
     **  C library function:
     **    rslvsp        Resolve system        Creates a system pointer to the
     **                  pointer               object specified by the input
     **                                        parameters. Only a system state
     **                                        program is allowed to generate
     **                                        an authorized system pointer.
     **
     **    mitime        Create an _MI_Time    Creates an _MI_Time value from
     **                  value                 the individual time durations
     **                                        specified.
     **
     **  Service program procedures:
     **    GetSysPtr     Get system pointer    Based on object name, library and
     **                                        object type a system pointer to
     **                                        the object is generated and
     **                                        returned to the caller.
     **
     **    GetTimVal     Get MI time value     Generates an MI time value from
     **                                        the specified number of seconds.
     **
     **  Programmer's notes:
     **    RPG/IV has no explicit support of system pointers - but defining an
     **    uninitialized procedure pointer will make the RPG compiler create
     **    an open pointer, capable of storing any type of iSeries pointer.
     **
     **    Though not very likely - due to the many production programs already
     **    exploiting this feature - it is possible that a future introduction
     **    of true system pointer support to RPG/IV might disable this "hidden"
     **    system pointer support.
     **
     **    If used in production programs, you should therefore document the
     **    use of this feature very carefully to ensure that you can take the
     **    appropriate evasive actions if necessary.
     **
     **
     **  Compile options required:
     **    CrtRpgMod  CBX115S
     **
     **    CrtSrvPgm  CBX115S                        +
     **               Module( CBX115S )              +
     **               Export( *ALL )                 +
     **               ActGrp( *CALLER )
     **
     **
     **-- Header specifications:  --------------------------------------------**
     H NoMain  BndDir( 'QC2LE' )
     **-- API Error Data Structure:  -----------------------------------------**
     D ApiError        Ds
     D  AeBytPro                     10i 0 Inz( %Size( ApiError ))
     D  AeBytAvl                     10i 0 Inz
     D                                1a
     D  AeExcpId                      7a
     D  AeExcpDta                   256a
     **-- Convert object type to hex:  ---------------------------------------**
     D CvtObjTyp       Pr                  ExtPgm( 'QLICVTTP' )
     D  CtCnvOpt                     10a   Const
     D  CtObjSym                     10a   Const
     D  CtObjHex                      2a
     D  CtError                   32767a          Options( *VarSize )
     **-- Get system pointer:  -----------------------------------------------**
     D GetSysPtr       Pr              *   ProcPtr
     D  PxObjNam                     10a   Const
     D  PxObjLib                     10a   Const
     D  PxObjTyp                     10a   Const
     **-- Get MI time value:  ------------------------------------------------**
     D GetTimVal       Pr             8a
     D  PxSec                        10u 0 Const
     **-- Check object existence:  -------------------------------------------**
     D ObjExist        Pr              n
     D  PxObjNam                     10a   Const
     D  PxObjLib                     10a   Const
     D  PxObjTyp                     10a   Const
     **-- Resolve system pointer:  -------------------------------------------**
     D rslvsp          Pr              *   ProcPtr  ExtProc( 'rslvsp' )
     D  PxObjTyp                      2a   Value
     D  PxObjNam                       *   Value  Options( *String )
     D  PxObjLib                       *   Value  Options( *String )
     D  PxAutReq                      2a   Value
     **-- mitime - create an _MI_Time value from components:  ----------------**
     D mitime          Pr                  ExtProc( 'mitime' )
     D  PxDelay                       8a
     D  PxHours                      10u 0 Value
     D  PxMin                        10u 0 Value
     D  PxSec                        10u 0 Value
     D  PxMs                         10u 0 Value
     **-- Get system pointer:  -----------------------------------------------**
     P GetSysPtr       B                   Export
     D                 Pi              *   ProcPtr
     D  PxObjNam                     10a   Const
     D  PxObjLib                     10a   Const
     D  PxObjTyp                     10a   Const
     **-- Local variables:
     D SysPtr          s               *   ProcPtr
     D ObjTypHex       s              2a
     **
     C                   If        ObjExist( PxObjNam: PxObjLib: PxObjTyp )
     **
     C                   Callp     CvtObjTyp( '*SYMTOHEX'
     C                                      : PxObjTyp
     C                                      : ObjTypHex
     C                                      : ApiError
     C                                      )
     **
     C                   If        AeBytAvl   =  *Zero
     **
     C                   Eval      SysPtr =  rslvsp( ObjTypHex
     C                                             : PxObjNam
     C                                             : PxObjLib
     C                                             : x'0000'
     C                                             )
     **
     C                   EndIf
     C                   EndIf
     **
     C                   Return                  SysPtr
     **
     P GetSysPtr       E
     **-- Get MI time value:  ------------------------------------------------**
     P GetTimVal       B                   Export
     D                 Pi             8a
     D  PxSec                        10u 0 Const
     **-- time parameter:
     D PxDelay         s              8a
     **
     C                   CallP     mitime( PxDelay
     C                                   : 0
     C                                   : 0
     C                                   : PxSec
     C                                   : 0
     C                                   )
     **
     C                   Return                  PxDelay
     **
     P GetTimVal       E
     **-- Check object existence:  -------------------------------------------**
     P ObjExist        B                   Export
     D                 Pi              n
     D  PxObjNam                     10a   Const
     D  PxObjLib                     10a   Const
     D  PxObjTyp                     10a   Const
     **-- Retrieve object description:
     D RoData          Ds
     D  RoBytRtn                     10i 0
     D  RoBytAvl                     10i 0
     D RoDtaLgt        s             10i 0 Inz( %Size( RoData ))
     D RoFmtNam        s              8a   Inz( 'OBJD0100' )
     D RoObjQ          s             20a
     D RoObjTyp        s             10a
     **
     C                   Eval      RoObjQ     =  PxObjNam + PxObjLib
     **
     C                   Call      'QUSROBJD'
     C                   Parm                    RoData
     C                   Parm                    RoDtaLgt
     C                   Parm                    RoFmtNam
     C                   Parm                    RoObjQ
     C                   Parm      PxObjTyp      RoObjTyp
     C                   Parm                    ApiError
     **
     C                   Return    ( AeBytAvl =  *Zero )
     **
     P ObjExist        E

/*  Program . . : CBX115                                             */
/*  Description : User queue example                                 */
/*  Author  . . : Carsten Flensburg                                  */
/*  Published . : Club Tech iSeries Programming Tips Newsletter      */
/*  Date  . . . : February 19, 2004                                  */
/*                                                                   */
/*  Program function:  Initialize, run and clean up user queue       */
/*                     example.                                      */
/*                                                                   */
/*  Programmer's notes:                                              */
/*    Submit of the server job should occur through a job queue      */
/*    ensuring immediate activation of the server job, otherwise     */
/*    the user queue driven dialogue between the server and client   */
/*    jobs will not be possible.                                     */
/*                                                                   */
/*    To run the user queue test application simply compile the      */
/*    involved objects as described in each source header and        */
/*    eventually call this program.                                  */
/*                                                                   */
/*  Compile options:                                                 */
/*    First, create the CRTUSRQ command from the January 29, 2004    */
/*       issue of Club Tech iSeries Programming Tips Newsletter.     */
/*    CrtClPgm   Pgm( CBX115 )                                       */
/*               SrcFile( QCLSRC )                                   */
/*               SrcMbr( *PGM )                                      */
/*                                                                   */
     Pgm

/*-- Global variables:  ---------------------------------------------*/
     Dcl        &JobNbr           *Char    10
     Dcl        &UsrQueNamF       *Char    10     'USQF'
     Dcl        &UsrQueNamK       *Char    10     'USQK'
     Dcl        &UsrQueLib        *Char    10


/*-- Global error monitoring:  --------------------------------------*/
     MonMsg     CPF0000     *N       GoTo Error

/*-- Mainline -------------------------------------------------------*/

     RtvJobA    Nbr( &JobNbr )  CurLib( &UsrQueLib )

     ChgVar     &UsrQueNamF   ( &UsrQueNamF *Tcat  &JobNbr )
     ChgVar     &UsrQueNamK   ( &UsrQueNamK *Tcat  &JobNbr )

     If       ( &UsrQueLib =  '*NONE' )    ChgVar  &UsrQueLib  'QGPL'

     DltUsrQ    UsrQ( &UsrQueLib/&UsrQueNamF )
     MonMsg     CPF2105       *N  RcvMsg   MsgType( *EXCP )  Rmv( *YES )

     DltUsrQ    UsrQ( &UsrQueLib/&UsrQueNamK )
     MonMsg     CPF2105       *N  RcvMsg   MsgType( *EXCP )  Rmv( *YES )

     CrtUsrQ    UsrQ( &UsrQueLib/&UsrQueNamF )        +
                ExtAtr( USRQFIFO )                    +
                MaxLen( 1024 )                        +
                Size( 256 )                           +
                IncrSize( 128 )                       +
                Text( 'User queue FIFO test' )

     CrtUsrQ    UsrQ( &UsrQueLib/&UsrQueNamK )        +
                ExtAtr( USRQKEYED )                   +
                Seq( *KEYED )                         +
                KeyLen( 16 )                          +
                MaxLen( 1024 )                        +
                Size( 256 )                           +
                IncrSize( 128 )                       +
                Text( 'User queue keyed test' )

/*-- Submit server function:                                            --*/
     SbmJob     Cmd( Call Pgm( CBX1151 )              +
                          Parm( &UsrQueNamF           +
                                &UsrQueNamK           +
                                &UsrQueLib            +
                              ))                      +
                Job( USRQSVR )                        +
                JobD( *USRPRF )                       +
                JobQ( *JOBD )

/*-- Run client function:                                               --*/
     Call       CBX1152      Parm( &UsrQueNamF        +
                                   &UsrQueNamK        +
                                   &UsrQueLib         +
                                 )

     SndPgmMsg  MsgId( CPF9897 )                      +
                MsgF( QCPFMSG )                       +
                MsgDta( 'Terminating server job.' )   +
                ToPgmQ( *EXT )                        +
                MsgType( *STATUS )

     DlyJob     1

     DltUsrQ    UsrQ( &UsrQueLib/&UsrQueNamF )

     DltUsrQ    UsrQ( &UsrQueLib/&UsrQueNamK )

     SndPgmMsg  Msg( 'User queue test completed normally.' )              +
                MsgType( *COMP )

 Return:
     Return

/*-- Error processor ------------------------------------------------*/
 Error:
     Call      QMHMOVPM    ( '    '                             +
                             '*DIAG'                            +
                             x'00000001'                        +
                             '*PGMBDY   '                       +
                             x'00000001'                        +
                             x'0000000800000000'                +
                           )

     Call      QMHRSNEM    ( '    '                             +
                             x'0000000800000000'                +
                           )
 EndPgm:
     EndPgm

Thanks to Carsten Flensburg and
Club Tech iSeries Programming Tips Newsletter
Back

QP0LROR & QlgLstat & QSPRILSP
QP0LROR: Retrieve object references
QlgLstat : Get file or link information
QSPRILSP : Retrieve identity of last spooled file created

     **  Program . . : CBX116
     **  Description : Display IFS object locks
     **  Author  . . : Carsten Flensburg
     **  Published . : Club Tech iSeries Programming Tips Newsletter
     **  Date  . . . : March 25, 2004
     **
     **
     **  Program summary
     **  ---------------
     **
     **  Unix type APIs:
     **    QP0LROR       Retrieve object       For specific IFS objects access
     **                  references            or lock information is retrieved.
     **
     **                                        This information includes the
     **                                        type of lock or access as well
     **                                        as a list of the jobs holding the
     **                                        lock(s).
     **
     **                                        An IFS object can, however, be
     **                                        flagged as "in use" without a
     **                                        specific job being identified
     **                                        as currently holding a lock.
     **
     **                                        Likewise, the browsing of an IFS
     **                                        stream file does not necessarily
     **                                        generate a lock or set the object
     **                                        in use indicator.
     **
     **    QlgLstat      Get file or link      Gets status information about the
     **                  information           specified directory entry and puts
     **                                        it in the structure pointed to by
     **                                        the pBuf parameter.
     **
     **                                        The path name parameter includes
     **                                        NLS attributes (National Language
     **                                        Support) enabling the API to take
     **                                        these into account when resolving
     **                                        the actual IFS object.
     **
     **  Spooled file API:
     **    QSPRILSP      Retrieve identity of  Returns the subset of spooled file
     **                  last spooled file     attributes that uniquely identifies
     **                  created               the last spooled file created in
     **                                        the current job.
     **
     **  Work management APIs:
     **    QUSRJOBI      Retrieve job          Retrieves a variety of specific
     **                  information           information about a job.
     **
     **                                        The information is grouped in the
     **                                        various formats available.
     **
     **  Message handling API:
     **    QMHSNDPM      Send program message  Sends a message to a program stack
     **                                        entry (current, previous, etc.) or
     **                                        an external message queue.
     **
     **                                        Both messages defined in a message
     **                                        file and immediate messages can be
     **                                        used. For specific message types
     **                                        only one or the other is allowed.
     **
     **  C library function:
     **    system        Run system command    Executes a system command. In the
     **                                        event of an resulting error the
     **                                        error message ID is exported in
     **                                        the _EXCP_MSGID variable.
     **
     **  Sequence of events:
     **    1. The existence of the specified IFS object is verified using
     **       the lstat unix function and if an error is returned during
     **       this process, an escape message is sent back to the caller.
     **
     **    2. Storage is allocated for the Retrieve object reference API return
     **       variable and the API is called. If there's more object reference
     **       information available than allocated, sufficient storage is
     **       reallocated and the API is called again.
     **
     **    3. The retrieved information is formatted and written to the printer
     **       file. The printer file is closed and the allocated storage is
     **       released.
     **
     **    4. If the command is running in batch or a printed list was requested,
     **       a completion message is sent to inform the caller that list is now
     **       available - otherwise the generated spooled file is displayed, and
     **       subsequently deleted.
     **
     **
     **  Programmer's notes:
     **    Both the QP0LROR (Retrieve object references) and QSPRILSP (Retrieve
     **    identity of last spooled file created) were introduced with V5R2 and
     **    this API example will therefore not be available to earlier releases.
     **
     **    QP0LROR documentation and comprehensive usage notes can be found here:
     **    http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qp0lror.htm
     **
     **    The QP0LROR return format RORO0100 is not used in this utility, but
     **    a sample of how to use it and retrieve its information is included
     **    in the non-referenced subroutine RtvObjRef1 and PrcObjRef1.
     **
     **
     **  Compile options:
     **
     **    CrtRpgMod Module( CBX116 )  DbgView( *LIST )
     **
     **    CrtPgm    Pgm( CBX116 )
     **              Module( CBX116 )
     **
     **
     **-- Control specification:  --------------------------------------------**
     H Option( *SrcStmt )  BndDir( 'QC2LE' )
     **-- Printer file:  -----------------------------------------------------**
     FQSYSPRT   O    F  132        Printer  InfDs( PrtLinInf )  OflInd( *InOf )
     F                                      UsrOpn
     **-- 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 Time            s              6s 0
     D Idx             s             10u 0
     D BytAlc          s             10u 0
     D NbrRcds         s             10u 0
     D MsgKey          s              4a
     D ErrTxt          s            256a   Varying
     **
     D IfsObj          s            112a
     D ObjUse          s              4a
     D ChkUsr          s             10a
     **
     D CurCcsId        c                   0
     D CurCtrId        c                   x'0000'
     D CurLngId        c                   x'000000'
     D ChrDlm1         c                   0
     **-- 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
     **-- system function error id:  -----------------------------------------**
     D SysError        s              7a   Import( '_EXCP_MSGID' )
     **-- Api path:  ---------------------------------------------------------**
     D ApiPath         Ds
     D  ApCcsId                      10i 0 Inz( CurCcsId )
     D  ApCtrId                       2a   Inz( CurCtrId )
     D  ApLngId                       3a   Inz( CurLngId )
     D                                3a   Inz( *Allx'00' )
     D  ApPthTypI                    10i 0 Inz( ChrDlm1 )
     D  ApPthNamLen                  10i 0
     D  ApPthNamDlm                   2a   Inz( '/ ' )
     D                               10a   Inz( *Allx'00' )
     D  ApPthNam                   1024a
     **-- Object reference information: --------------------------------------**
     D RORO0100        Ds                  Based( pObjRef )
     D  R1BytRtn                     10u 0
     D  R1BytAvl                     10u 0
     D  R1OfsSmpRef                  10u 0
     D  R1LenSmpRef                  10u 0
     D  R1RefCnt                     10u 0
     D  R1InUseI                     10u 0
     **
     D RORO0200        Ds                  Based( pObjRef )
     D  R2BytRtn                     10u 0
     D  R2BytAvl                     10u 0
     D  R2RefCnt                     10u 0
     D  R2InUseI                     10u 0
     D  R2OfsSmpRef                  10u 0
     D  R2LenSmpRef                  10u 0
     D  R2OfsExtRef                  10u 0
     D  R2LenExtRef                  10u 0
     D  R2OfsJobLst                  10u 0
     D  R2NbrJobRtn                  10u 0
     D  R2NbrJobAvl                  10u 0
     **-- Job using object structure:  ---------------------------------------**
     D JobUsgObj       Ds                   Based( pJobUsgObj )
     D  JuDplSmpRef                  10u 0
     D  JuLenSmpRef                  10u 0
     D  JuDplExtRef                  10u 0
     D  JuLenExtRef                  10u 0
     D  JuDplNxtJobE                 10u 0
     D  JuJobNam                     10a
     D  JuJobUsr                     10a
     D  JuJobNbr                      6a
     **-- Simple object reference types structure:  --------------------------**
     D SmpObjRef       Ds                   Based( pSmpObjRef )
     D  SoReadOnly                   10u 0
     D  SoWrtOnly                    10u 0
     D  SoReadWrt                    10u 0
     D  SoExecute                    10u 0
     D  SoShrRdOnly                  10u 0
     D  SoShrWrtOnly                 10u 0
     D  SoShrRdWrt                   10u 0
     D  SoShrNoRdWrt                 10u 0
     D  SoAtrLck                     10u 0
     D  SoSavLck                     10u 0
     D  SoSavLckInt                  10u 0
     D  SoLnkChgLck                  10u 0
     D  SoChkOut                     10u 0
     D  SoChkOutUsrNm                10a
     D                                2a
     **-- Extended object reference types structure:  ------------------------**
     D ExtObjRef       Ds                   Based( pExtObjRef )
     D  XoRdOnShrRdOn                10u 0
     D  XoRdOnShrWtOn                10u 0
     D  XoRdOnShrRdWt                10u 0
     D  XoRdOnShrNoRW                10u 0
     D  XoWtOnShrRdOn                10u 0
     D  XoWtOnShrWtOn                10u 0
     D  XoWtOnShrRdWt                10u 0
     D  XoWtOnShrNoRW                10u 0
     D  XoRWonShrRdOn                10u 0
     D  XoRWonShrWtOn                10u 0
     D  XoRWonShrRdWt                10u 0
     D  XoRWonShrNoRW                10u 0
     D  XoExOnShrRdOn                10u 0
     D  XoExOnShrWtOn                10u 0
     D  XoExOnShrRdWt                10u 0
     D  XoExOnShrNoRW                10u 0
     D  XoXRonShrRdOn                10u 0
     D  XoXRonShrWtOn                10u 0
     D  XoXRonShrRdWt                10u 0
     D  XoXRonShrNoRW                10u 0
     D  XoAtrLck                     10u 0
     D  XoSavLck                     10u 0
     D  XoSavLckInt                  10u 0
     D  XoLnkChgLck                  10u 0
     D  XoCurDir                     10u 0
     D  XoRootDir                    10u 0
     D  XoFilSvrRef                  10u 0
     D  XoFilSvrWrkDi                10u 0
     D  XoChkOut                     10u 0
     D  XoChkOutUsrNm                10a
     D                                2a
     **-- Spooled file information:  -----------------------------------------**
     D SPRL0100        Ds
     D  SiBytRtn                     10i 0
     D  SiBytAvl                     10i 0
     D  SiSplfNam                    10a
     D  SiJobNam                     10a
     D  SiUsrNam                     10a
     D  SiJobNbr                      6a
     D  SiSplfNbr                    10i 0
     D  SiJobSysNam                   8a
     D  SiSplfCrtDat                  7a
     D                                1a
     D  SiSplfCrtTim                  6a
     **-- File stat-structure:  ----------------------------------------------**
     D Buf             Ds                  Align
     D  st_mode                      10u 0
     D  st_ino                       10u 0
     D  st_nlink                      5u 0
     D                                2a
     D  st_uid                       10u 0
     D  st_gid                       10u 0
     D  st_size                      10i 0
     D  st_atime                     10i 0
     D  st_mtime                     10i 0
     D  st_ctime                     10i 0
     D  st_dev                       10u 0
     D  st_blksize                   10u 0
     D  st_allocsize                 10u 0
     D  st_objtype                   11a
     D                                1a
     D  st_codepage                   5u 0
     D  st_reserv1                   62a
     D  st_ino_gen_id                10u 0
     **
     D pBuf            s               *   Inz( %Addr( Buf ))
     **-- Get file or link information:  -------------------------------------**
     D lstat           Pr            10i 0 ExtProc( 'QlgLstat' )
     D  PthStr                     4096a   Const  Options( *VarSize )
     D  Buf                            *   Value
     **-- Retrieve object references:  ---------------------------------------**
     D RtvObjRef       Pr                  ExtPgm( 'QP0LROR' )
     D  RoRcvVar                  65535a          Options( *VarSize )
     D  RoRcvVarLen                  10u 0 Const
     D  RoFmtNam                      8a   Const
     D  RoPthStr                   4096a   Const  Options( *VarSize )
     D  RoError                   32767a          Options( *VarSize: *NoPass)
     **-- Retrieve job information:  -----------------------------------------**
     D RtvJobInf       Pr                  ExtPgm( 'QUSRJOBI' )
     D  RiRcvVar                  32767a         Options( *VarSize )
     D  RiRcvVarLen                  10i 0 Const
     D  RiFmtNam                      8a   Const
     D  RiJobNamQ                    26a   Const
     D  RiJobIntId                   16a   Const
     D  RiError                   32767a         Options( *NoPass: *VarSize )
     **-- Send program message:  ---------------------------------------------**
     D SndPgmMsg       Pr                  ExtPgm( 'QMHSNDPM' )
     D  SpMsgId                       7a   Const
     D  SpMsgFq                      20a   Const
     D  SpMsgDta                    128a   Const
     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                      10i 0 Const
     **-- Retrieve last spooled file identity:  ------------------------------**
     D RtvLstSplfId    Pr                  ExtPgm( 'QSPRILSP' )
     D  RsRcvVar                  32767a          Options( *VarSize )
     D  RsRcvVarLen                  10i 0 Const
     D  RsFmtNam                      8a   Const
     D  RsError                   32767a          Options( *VarSize )
     **-- Run system command:  -----------------------------------------------**
     D system          Pr            10i 0 ExtProc( 'system' )
     D  command                        *   Value  Options( *String )
     **-- Get job type:  -----------------------------------------------------**
     D GetJobTyp       Pr             1a
     **-- Send escape message:  ----------------------------------------------**
     D SndEscMsg       Pr            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **-- Send completion message:  ------------------------------------------**
     D SndCmpMsg       Pr            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **-- Error identification:  ---------------------------------------------**
     D errno           Pr            10i 0
     D strerror        Pr           128a   Varying
     **-- Parameters:  -------------------------------------------------------**
     D PxPthNam        s            300a   Varying
     D PxOutOpt        s              3a
     **
     C     *Entry        Plist
     C                   Parm                    PxPthNam
     C                   Parm                    PxOutOpt
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   Eval      ApPthNam    = PxPthNam
     C                   Eval      ApPthNamLen = %Len( PxPthNam )
     **
     C                   If        lstat( ApiPath
     C                                  : pBuf
     C                                  )      = -1
     **
     C                   CallP     SndEscMsg( %Char( Errno ) + ': ' + Strerror )
     C                   Else
     **
     C                   Open      QSYSPRT
     **
     C                   Eval      BytAlc      = 65535
     C                   Eval      pObjRef     = %Alloc( BytAlc )
     **
     C                   DoU       R2BytAvl   <= BytAlc
     **
     C                   If        R2BytAvl    > BytAlc
     C                   Eval      BytAlc      = R2BytAvl
     C                   Eval      pObjRef     = %ReAlloc( pObjRef: BytAlc )
     C                   EndIf
     **
     C                   CallP(e)  RtvObjRef( RORO0200
     C                                      : BytAlc
     C                                      : 'RORO0200'
     C                                      : ApiPath
     C                                      : ApiError
     C                                      )
     **
     C                   If        %Error
     C                   CallP     SndEscMsg( 'Release must be V5R2 or higher.')
     C                   EndIf
     C                   EndDo
     **
     C                   If        AeBytAvl    = *Zero
     C                   ExSr      PrcObjRef2
     C                   EndIf
     **
     C                   DeAlloc                 pObjRef
     **
     C                   Close     QSYSPRT
     **
     C                   If        PxOutOpt    = 'DSP'         And
     C                             GetJobTyp() = 'I'
     C                   ExSr      DspLst
     **
     C                   Else
     C                   ExSr      WrtLst
     C                   EndIf
     C                   EndIf
     **
     C                   Eval      *InLr       = *On
     C                   Return
     **
     **-- Display list:  -----------------------------------------------------**
     C     DspLst        BegSr
     **
     C                   CallP     RtvLstSplfId( SPRL0100
     C                                         : %Size( SPRL0100 )
     C                                         : 'SPRL0100'
     C                                         : ApiError
     C                                         )
     C
     **
     C                   CallP     system( 'DSPSPLF '                   +
     C                                     'FILE(' + %Trim( SiSplfNam ) + ') ' +
     C                                     'JOB('  + %Trim( SiJobNbr )  + '/'  +
     C                                               %Trim( SiUsrNam )  + '/'  +
     C                                               %Trim( SiJobNam )  + ') ' +
     C                                     'SPLNBR(' + %Char( SiSplfNbr ) + ')'
     C                                   )
     **
     C                   CallP     system( 'DLTSPLF '                   +
     C                                     'FILE(' + %Trim( SiSplfNam ) + ') ' +
     C                                     'JOB('  + %Trim( SiJobNbr )  + '/'  +
     C                                               %Trim( SiUsrNam )  + '/'  +
     C                                               %Trim( SiJobNam )  + ') ' +
     C                                     'SPLNBR(' + %Char( SiSplfNbr ) + ')'
     C                                   )
     **
     C                   EndSr
     **-- Write list:  -------------------------------------------------------**
     C     WrtLst        BegSr
     **
     C                   CallP     SndCmpMsg( 'List has been printed.' )
     **
     C                   EndSr
     **-- Retrieve object references - format RORO0100:  ---------------------**
     C     RtvObjRef1    BegSr
     **
     **-- Not referenced - included only as a sample!
     **
     C                   Eval      BytAlc      = 65535
     C                   Eval      pObjRef     = %Alloc( BytAlc )
     **
     C                   DoU       R1BytAvl   <= BytAlc
     **
     C                   If        R1BytAvl    > BytAlc
     C                   Eval      BytAlc      = R1BytAvl
     C                   Eval      pObjRef     = %ReAlloc( pObjRef: BytAlc )
     C                   EndIf
     **
     C                   CallP     RtvObjRef( RORO0100
     C                                      : BytAlc
     C                                      : 'RORO0100'
     C                                      : ApiPath
     C                                      : ApiError
     C                                      )
     **
     C                   EndDo
     **
     C                   If        AeBytAvl    = *Zero
     C                   ExSr      PrcObjRef1
     C                   EndIf
     **
     C                   EndSr
     **-- Process object references - format RORO0100:  ----------------------**
     C     PrcObjRef1    BegSr
     **
     C                   If        R1OfsSmpRef > *Zero         And
     C                             R1LenSmpRef = %Size( SmpObjRef )
     **
     C                   Eval      pSmpObjRef  = %Addr( RORO0100 ) +
     C                                           R1OfsSmpRef
     **
     C                   EndIf
     **
     C                   EndSr
     **-- Process object references - format RORO0200:  ----------------------**
     C     PrcObjRef2    BegSr
     **
     C                   Time                    Time
     C                   Except    Header
     **
     C                   If        R2OfsSmpRef > *Zero         And
     C                             R2LenSmpRef = %Size( SmpObjRef )
     **
     C                   Eval      pSmpObjRef  = %Addr( RORO0200 ) +
     C                                           R2OfsSmpRef
     **
     C                   ExSr      WrtLstHdr
     C                   EndIf
     **
     C                   If        R2OfsExtRef > *Zero         And
     C                             R2LenExtRef = %Size( ExtObjRef )
     **
     C                   Eval      pExtObjRef  = %Addr( RORO0200 ) +
     C                                           R2OfsExtRef
     **
     C                   EndIf
     **
     C                   If        R2OfsJobLst > *Zero
     **
     C                   ExSr      PrcJobLst
     C                   EndIf
     **
     C                   If        NbrRcds    =  *Zero
     C                   Except    NoRcds
     C                   EndIf
     **
     C                   EndSr
     **-- Process job list:  -------------------------------------------------**
     C     PrcJobLst     BegSr
     **
     C                   Eval      pJobUsgObj  = %Addr( RORO0200 ) +
     C                                           R2OfsJobLst
     **
     C                   For       Idx = 1  to R2NbrJobRtn
     **
     C                   If        JuDplSmpRef > *Zero
     C                   Eval      pSmpObjRef  = pJobUsgObj + JuDplSmpRef
     **...
     C                   EndIf
     **
     C                   If        JuDplExtRef > *Zero
     C                   Eval      pExtObjRef  = pJobUsgObj + JuDplExtRef
     **...
     C                   EndIf
     **
     C                   ExSr      WrtLckDtl
     **
     C                   If        Idx         < R2NbrJobRtn
     C                   Eval      pJobUsgObj += JuDplNxtJobE
     C                   EndIf
     C                   EndFor
     **
     C                   EndSr
     **-- Write IFS lock detail line:  ---------------------------------------**
     C     WrtLckDtl     BegSr
     **
     C                   If        PlCurLin    > PlOvfLin - 3
     C                   Except    Header
     C                   Except    DtlHdr
     C                   EndIf
     **
     C                   Eval      NbrRcds    =  NbrRcds + 1
     C                   Except    LckDtl
     **
     C                   EndSr
     **-- Write list header:  ------------------------------------------------**
     C     WrtLstHdr     BegSr
     **
     C                   If        ApPthNamLen > %Size( IfsObj )
     C                   EvalR     IfsObj      = ApPthNam
     C                   Eval      %Subst( IfsObj: 1: 3 ) = '...'
     C                   Else
     C                   Eval      IfsObj      = ApPthNam
     C                   EndIf
     **
     C                   If        R2InUseI    = 1
     C                   Eval      ObjUse      = '*YES'
     C                   Else
     C                   Eval      ObjUse      = '*NO '
     C                   EndIf
     **
     C                   If        SoChkOutUsrNm > *Blanks
     C                   Eval      ChkUsr      = SoChkOutUsrNm
     C                   Else
     C                   Eval      ChkUsr      = '*NONE'
     C                   EndIf
     **
     C                   Except    LstHdr
     C                   Except    DtlHdr
     **
     C                   EndSr
     **-- Printer file definition:  ------------------------------------------**
     OQSYSPRT   EF           Header         2  2
     O                       UDATE         Y      8
     O                       Time                18 '  :  :  '
     O                                           70 'Display IFS object locks'
     O                                          107 'Program:'
     O                       PsPgmNam           118
     O                                          126 'Page:'
     O                       PAGE             +   1
     OQSYSPRT   EF           LstHdr         1
     O                                           18 'IFS object . . . :'
     O                       IfsObj             132
     OQSYSPRT   EF           LstHdr         1
     O                                           18 'Object in use  . :'
     O                       ObjUse              24
     OQSYSPRT   EF           LstHdr         1
     O                                           18 'Check out user . :'
     O                       ChkUsr              30
     OQSYSPRT   EF           DtlHdr         1
     O                                           98 '------------- shared ------
     O                                              --------'
     OQSYSPRT   EF           DtlHdr         1
     O                                            8 'Job name'
     O                                           20 'Job user'
     O                                           31 'Job nbr'
     O                                           40 'Rd only'
     O                                           49 'Wr only'
     O                                           56 'Rd/wr'
     O                                           62 'Exec'
     O                                           71 'Rd only'
     O                                           80 'Wr only'
     O                                           88 'Rd/wr'
     O                                           98 'No rd/wr'
     O                                          108 'Atr lock'
     O                                          119 'Save lock'
     **-- Write right->left (prevent overlay):
     OQSYSPRT   EF           LckDtl         1
     O                       SoSavLck      3    115
     O                       SoAtrLck      3    105
     O                       SoShrNoRdWrt  3     95
     O                       SoShrRdWrt    3     86
     O                       SoShrWrtOnly  3     78
     O                       SoShrRdOnly   3     69
     O                       SoExecute     3     61
     O                       SoReadWrt     3     54
     O                       SoWrtOnly     3     47
     O                       SoReadOnly    3     38
     O                       JuJobNbr            30
     O                       JuJobUsr            22
     O                       JuJobNam            10
     **
     OQSYSPRT   EF           NoRcds      1
     O                                           26 '(No IFS locks found)'
     **-- Get job type:  -----------------------------------------------------**
     P GetJobTyp       B
     D                 Pi             1a
     **
     D JOBI0400        Ds
     D  J4BytRtn                     10i 0
     D  J4BytAvl                     10i 0
     D  J4JobNam                     10a
     D  J4UsrNam                     10a
     D  J4JobNbr                      6a
     D  J4JobIntId                   16a
     D  J4JobSts                     10a
     D  J4JobTyp                      1a
     D  J4JobSubTyp                   1a
     **
     C                   CallP     RtvJobInf( JOBI0400
     C                                      : %Size( JOBI0400 )
     C                                      : 'JOBI0400'
     C                                      : '*'
     C                                      : *Blank
     C                                      : ApiError
     C                                      )
     **
     C                   If        AeBytAvl    > *Zero
     C                   Return    *Blank
     **
     C                   Else
     C                   Return    J4JobTyp
     C                   EndIf
     **
     P GetJobTyp       E
     **-- Send escape message:  ----------------------------------------------**
     P SndEscMsg       B
     D                 Pi            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **
     C                   CallP(e)  SndPgmMsg( 'CPF9897'
     C                                      : 'QCPFMSG   *LIBL'
     C                                      : PxMsgDta
     C                                      : %Len( PxMsgDta )
     C                                      : '*ESCAPE'
     C                                      : '*PGMBDY'
     C                                      : 1
     C                                      : MsgKey
     C                                      : *Zero
     C                                      )
     **
     C                   If        %Error
     C                   Return    -1
     **
     C                   Else
     C                   Return    0
     C                   EndIf
     **
     P SndEscMsg       E
     **-- Send completion message:  ------------------------------------------**
     P SndCmpMsg       B
     D                 Pi            10i 0
     D  PxMsgDta                    512a   Const  Varying
     **
     C                   CallP(e)  SndPgmMsg( 'CPF9897'
     C                                      : 'QCPFMSG   *LIBL'
     C                                      : PxMsgDta
     C                                      : %Len( PxMsgDta )
     C                                      : '*COMP'
     C                                      : '*PGMBDY'
     C                                      : 1
     C                                      : MsgKey
     C                                      : *Zero
     C                                      )
     **
     C                   If        %Error
     C                   Return    -1
     **
     C                   Else
     C                   Return    0
     C                   EndIf
     **
     P SndCmpMsg       E
     **-- Get runtime error number:  -----------------------------------------**
     P Errno           B
     D                 Pi            10i 0
     **
     D sys_errno       Pr              *    ExtProc( '__errno' )
     **
     D Error           s             10i 0  Based( pError )  NoOpt
     **
     C                   Eval      pError     =  sys_errno
     C                   Return    Error
     **
     P Errno           E
     **-- Get runtime error text:  -------------------------------------------**
     P Strerror        B
     D                 Pi           128a    Varying
     **
     D sys_strerror    Pr              *    ExtProc( 'strerror' )
     D                               10i 0  Value
     **
     C                   Return    %Str( sys_strerror( Errno ))
     **
     P Strerror        E

/*-------------------------------------------------------------------*/
/*                                                                   */
/*  Compile options:                                                 */
/*                                                                   */
/*    CrtCmd Cmd( DSPIFSLCK )                                        */
/*           Pgm( CBX116 )                                           */
/*           SrcMbr( CBX116X )                                       */
/*           HlpPnlGrp( CBX116H )                                    */
/*           HlpId( *CMD )                                           */
/*                                                                   */
/*-------------------------------------------------------------------*/
     Cmd        Prompt( 'Display IFS Object Locks' )

     Parm       IFSOBJ   *Pname     300               +
                Min( 1 )                              +
                Expr( *YES )                          +
                Vary( *YES *INT2 )                    +
                Case( *MIXED )                        +
                Prompt( 'IFS object' )

     Parm       OUTPUT   *Char        3               +
                Rstd( *YES )                          +
                Dft( * )                              +
                SpcVal(( * DSP ) ( *PRINT  PRT ))     +
                Prompt( 'Output' )

.*-----------------------------------------------------------------------**
.*
.*  Compile options:
.*
.*    CrtPnlGrp PnlGrp( CBX116H )
.*              SrcFile( QPNLSRC )
.*              SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='DSPIFSLCK'.Display IFS Object Locks - Help
:P.
Displayes access and lock information for a specific IFS object.
:P.
This information includes the type of lock or access as well as a list
of the jobs holding the lock(s).
:P.
The length of time it will take this command to complete depends on the
number of jobs active on the system, and the number of jobs currently
using objects through Integrated File System interfaces.
:P.
:NT.
An IFS object can be flagged as "in use" without a specific job being
identified as currently holding a lock.
:P.
Likewise, the browsing of an IFS stream file does not necessarily
generate a lock or set the object in use indicator.
:ENT.
:NT.
This command requires release V5R2 or higher to run.
:ENT.
:EHELP.
:HELP NAME='DSPIFSLCK/IFSOBJ'.IFS object (IFSOBJ) - Help
:XH3.IFS object (IFSOBJ)
:P.
Specify the path name to the IFS object whose lock and access
information is to be displayed.
:P.
This is a required parameter.
:P.
:EHELP.
:HELP NAME='DSPIFSLCK/OUTPUT'.Output (OUTPUT) - Help
:XH3.Output (OUTPUT)
:P.
Specifies where the output from the command is sent.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*:EPK.
:PD.
The output is displayed (if requested by an interactive job) or printed
with the job's spooled output (if requested by a batch job).
:PT.:PK.*PRINT:EPK.
:PD.
The output is printed with the job's spooled output.
:EPARML.
:EHELP.
:EPNLGRP.

Thanks to Carsten Flensburg and
Club Tech iSeries Programming Tips Newsletter

QSPRILSP with CLLE: PGM DCL VAR(&RCVVAR) TYPE(*CHAR) LEN(70) DCL VAR(&RCVVARLEN) TYPE(*CHAR) LEN(4) DCL VAR(&ERRCODE) TYPE(*CHAR) LEN(8) /* FIELDS FROM FORMAT SPRL0100 */ DCL VAR(&BYTESRTN) TYPE(*DEC) LEN(10 0) DCL VAR(&BYTESAVL) TYPE(*DEC) LEN(10 0) DCL VAR(&SPLFNAME) TYPE(*CHAR) LEN(10) DCL VAR(&JOBNAME) TYPE(*CHAR) LEN(10) DCL VAR(&USERNAME) TYPE(*CHAR) LEN(10) DCL VAR(&JOBNBR) TYPE(*CHAR) LEN(6) DCL VAR(&SPLFNBR) TYPE(*DEC) LEN(6 0) DCL VAR(&SYSTEMNAME) TYPE(*CHAR) LEN(8) DCL VAR(&CREATEDATE) TYPE(*CHAR) LEN(7) DCL VAR(&CREATETIME) TYPE(*CHAR) LEN(6) CHGVAR VAR(%BIN(&ERRCODE 1 4)) VALUE(0) /* &RCVVARLEN NEEDS TO BE SET TO THE SIZE OF &RCVVAR. + IF YOU CHANGE THE SIZE OF &RCVVAR, CHANGE IT ON THE + LINE BELOW AS WELL! (CL HAS NO %SIZE BIF!!) */ CHGVAR VAR(%BIN(&RCVVARLEN 1 4)) VALUE(70) CALL PGM(QSPRILSP) PARM( &RCVVAR + &RCVVARLEN + 'SPRL0100' + &ERRCODE ) /* SINCE CL HAS NO SUCH THING AS A DATA STRUCTURE, I'VE + PUT ALL OF THE FIELDS INTO ONE BIG &RCVVAR FIELD, + AND WILL SPLIT IT INTO SUBFIELDS BELOW: */ CHGVAR VAR(&BYTESRTN) VALUE(%BIN(&RCVVAR 1 4)) CHGVAR VAR(&BYTESAVL) VALUE(%BIN(&RCVVAR 5 4)) CHGVAR VAR(&SPLFNAME) VALUE(%SST(&RCVVAR 9 10)) CHGVAR VAR(&JOBNAME) VALUE(%SST(&RCVVAR 19 10)) CHGVAR VAR(&USERNAME) VALUE(%SST(&RCVVAR 29 10)) CHGVAR VAR(&JOBNBR) VALUE(%SST(&RCVVAR 39 6)) CHGVAR VAR(&SPLFNBR) VALUE(%BIN(&RCVVAR 45 4)) CHGVAR VAR(&SYSTEMNAME) VALUE(%SST(&RCVVAR 49 8)) CHGVAR VAR(&CREATEDATE) VALUE(%SST(&RCVVAR 57 7)) CHGVAR VAR(&CREATETIME) VALUE(%SST(&RCVVAR 65 6)) /* THE FIELDS ABOVE NOW CONTAIN INFO ABOUT THE LAST + SPOOLED FILE CREATED IN THE JOB. */ ENDPGM Thanks to Scott Klement and Club Tech iSeries Programming Tips Newsletter

Back

Page #4 Page #6

Back