iSeries & System i

      API - Table of Contents #2

API Name # Description
QCAPCMD 3 Execute Command
QCDRCMDI   Retrieve Command Information
QDBRTVFD 7 Retrieve Database File Description
QDBLDBR   List Database Relations
QHFRTVAT   Retrieve Directory Entry Attributes
Qsn........ 3 Dynamic Screen Manager Api's
QSYRUSRI   Retrieve User Information
QUSCRTUS   Create User Space
QUSLJOB 2 List Job
QUSLMBR   List Database File Members
QUSLOBJ   List Objects
QUSRJOBI 2 Retrieve Job Information
QUSRTVUS   Retrieve User Space
QWCRNETA   Retrieve Network Attributes
QWCRSVAL 2 Retrieve System Values
CEE......   ILE Date Conversion APIs
CEEGPID   Retrieve ILE Version & Platform ID
QWCLOBJL   List Object Locks
QSNDDTAQ   Send Data Queue Entry
QRCVDTAQ   Receive Data Queue Entry
QWCRSSTS   Retrieve System Status
QLICOBJD   Change Object Description
QMHRTVM   Retrieve Message
QECEDT   Edit Code API
QECCVTEC 5 Edit Mask API
QSPGETF   Copy Spooled File to Database File
QSPPUTF   Create Spooled File from Database File
QUSPTRUS   Retrieve Pointer to User Space
QWCLASBS   List Active Subsystems
QSDRSBSD   Retrieve Subsystem Info
QWDLSBSE   List Subsystem Entries
QMHRCVPM   Receive Program Message
QMHSNDPM   Send Program Message
QSNRTVMOD   Retrieve Screen Size Mode
QCDRCMDD   Retrieve Command Definition
QtocLstNetCnn 4 Retrieve TCP/IP connection status
QWVRCSTK 2 Retrieve Call Stack
QLZARTV   Retrieve Processor Tier Group



QCAPCMD

Program: TESTCMD
      * prototype for RunCmd procedure/function
     D RunCmd          PR            10i 0 Extproc('RUNCMD')
     D  cmdTxt                         *   value options(*string)
     D  cmdErr                         *   value

      * set pointer for QUSEC data structure
     D pQusec          S               *
     D
      * Data structure used for APIs (can be copied from
      *  QSYSINC/QRPGLESRC,QUSEC) The structure here has been
      *  modified from the one in QSYSINC to include the
      *  "variable" length data field Qdata.
     DQUSEC            DS
      *                                             Qus EC
     D QUSBPRV                 1      4B 0
      *                                             Bytes Provided
     D QUSBAVL                 5      8B 0
      *                                             Bytes Available
     D QUSEI                   9     15
      *                                             Exception Id
     D QUSERVED               16     16
      *                                             Reserved
     D*QUSED01                17     17
      *                                             Varying length
     D Qdata                  17    216
     D
      * pass in a single CL command up to 50 characters
     C     *entry        Plist
     C                   Parm                    Cmd              50
     C
      * add x'00' (NULL terminator) to string passed to pgm.
     C                   Eval      cmd = %trim(cmd) + x'00'
     C
     C                   callp     RunCmd(%addr(cmd):
     C                             %addr(Qusec))
     C
     C                   Eval      *inlr = *on
     C                   Return


Module: RUNCMD
     H nomain
      ************************************************************************
      * Command execution function                                           *
      ************************************************************************
      * prototype for RunCmd procedure/function
     D RunCmd          PR            10i 0
     D  cmdTxt                         *   value options(*STRING)
     D  cmdErr                         *   value
     D
      * Prototype for QCAPCMD API
     D Qcapcmd         PR                  Extpgm('QCAPCMD')
     D  cTxt                       1000    options(*varsize) const
     D  cLen                         10i 0 const
     D  cCtlBlk                      20    const
     D  cCtlbLen                     10i 0 const
     D  cCtlbName                     8    const
     D  cChgCmd                    1000
     D  cChgCmdAv                    10i 0 const
     D  cChgCmdLen                   10i 0
     D  cErr                        216
     D
      * QCAPCMD structure
      * For clarity I have included this structure in the source
      * member but its probably better to just use /COPY to get it
      * from QSYSINC.
     D*****************************************************************
     DQCAP0100         DS
      *                                             Qca PCMD CPOP0100
     D QCACMDPT                1      4B 0
      *                                             Command Process Type
     D QCABCSDH                5      5
      *                                             DBCS Data Handling
     D QCAPA                   6      6
      *                                             Prompter Action
     D QCACMDSS                7      7
      *                                             Command String Syntax
     D QCAMK                   8     11
      *                                             Message Key
     D QCAERVED               12     20
      *                                             Reserved

     D* set pointer for QUSEC data structure
     D pQusec          S               *
     D
      * QUSEC exception data structure
      *  This structure will need to be placed in the source member
      *   because we need to modify it to be BASED on the pQusec
      *   pointer.
      *  Also, the Qdata field was added to capture the varying
      *   length message data for the exception received (if any).
     DQUSEC            DS                  Based(pQusec)
      *                                             Qus EC
     D QUSBPRV                 1      4B 0
      *                                             Bytes Provided
     D QUSBAVL                 5      8B 0
      *                                             Bytes Available
     D QUSEI                   9     15
      *                                             Exception Id
     D QUSERVED               16     16
      *                                             Reserved
     D*QUSED01                17     17
      *                                             Varying length
     D
     D Qdata                  17    216
      ************************************************************************
      * RunCmd - Command execution procedure/function                        *
      ************************************************************************
     P RunCmd          b                   Export
     D RunCmd          PI            10i 0
     D  cmdTxt                         *   value options(*string)
     D  cmdErr                         *   value
     D
      * API parameter variables
     D ChgCmdStr       S           1000
     D ChgCmdAv        S             10i 0
     D ChgCmdLen       S             10i 0
     D ctlBlkLen       S             10i 0

      * set pQusec to point at the QUSEC struct in the calling program
     C                   Eval      pQusec = cmdErr
      * Set API default values
      *  the values used here are being used to make the QCAPCMD work
      *  in a manner most similar to QCMDEXC.
     C                   Eval      Qcacmdpt = 0
     C                   Eval      Qcabcsdh = '0'
     C                   Eval      Qcapa = '0'
     C                   Eval      Qcacmdss = '0'
     C                   Eval      Qcamk = *blanks
     C                   Eval      Qcaerved = x'000000000000000000'
     C                   Eval      ChgCmdStr = *blanks
     C                   Eval      ChgCmdAv = 1000
     C                   Eval      ChgCmdLen = 0
     C                   Eval      QusbPrv = 216
     C                   Eval      QusbAvl = 0
     C                   Eval      ctlBlkLen = 20
     C
      * execute the command
     C                   Callp     Qcapcmd(%str(cmdTxt):
     C                             %len(%str(cmdTxt)):
     C                             QCAP0100:ctlBlkLen:'CPOP0100':
     C                             ChgCmdStr:
     C                             ChgCmdAv:ChgCmdLen:Qusec)
     C
      * Return 0 if the command executed without errors
     C                   If        QUSBAVL = 0
     C                   Return    0
     C                   Else
     C                   Return    1
     C                   Endif
     P RunCmd          E

Thanks to Jeff Olen
Back

QCDRCMDI

Retrieve Command Information (link).

Back

QDBRTVFD

Retrieve Database File Description (link).

And another example: D wFDSize ds D wFDSize1 9b 0 D wFDSize2 9b 0 D Qdb_Qdbfh ds d Qdbfyret 9b 0 d Qdbfyavl 9b 0 d Qdbfhflg 2 d Reserved_7 4 d Qdbflbnum 4b 0 d Qdbfknum 4b 0 d Qdbfkmxl 4b 0 d Qdbfkflg 1 d Qdbfkfdm 1 d Reserved_10 8 d Qdbfhaut 10 d Qdbfhupl 1 d Qdbfhmxm 4b 0 d Qdbfwtfi 4b 0 d Qdbfhfrt 4b 0 d Qdbfhmnum 4b 0 d Reserved_11 9 d Qdbfbrwt 4b 0 d Qaaf 1 d Qdbffmtnum 4b 0 d Qdbfhfl2 2 d Qdbfvrm 4b 0 d Qaaf2 2 d Qdbfhcrt 13 d Reserved_18 2 d qdbfhtxt 50 d Reserved_19 13 d Qdbfsrcf 10 d Qdbfsrcm 10 d Qdbfsrcl 10 d Qdbfkrcv 1 d Reserved_20 23 d Qdbftcid 5u 0 d Qdbfasp 2 d Reserved_21 1 d Qdbfmxfnum 4b 0 d Reserved_22 76 d Qdbfodic 9b 0 d Reserved_23 14 d Qdbffigl 4b 0 d Qdbfmxrl 4b 0 d Reserved_24 8 d Qdbfgkct 4b 0 d Qdbfos 9b 0 d Reserved_25 8 d Qdbfocs 9b 0 d Reserved_26 4 d Qdbfpact 2 d Qdbfhrls 6 d Reserved_27 20 d Qdbpfof 9b 0 d Qdblfof 9b 0 d Qdbfnlsb 1 d Qdbflang 3 d Qdbfcnty 2 d Qdbfjorn 9b 0 d Reserved_28 18 D* Physical File Attributes D pQdbpf s * D Qdb_Qdbpf ds based(pQdbpf) D qdbfpAlc 2 D qdbfcMPs 1 d Reserved_29 8 D qdbpRNum 9b 0 D qdbfpRI 4b 0 D qdbRINum 4b 0 D qdbfORID 9b 0 D qdbBits33 1 D qdbfOTrg 9b 0 Offset to qdbftrg D qdbfTrgN 4b 0 No of triggers D qdbfOFCS 9b 0 D qdbfCstN 9b 0 D qdbfODL 9b 0 D Reserved_32 6 D pQdbftrg s * D Qdb_Qdbftrg ds based(pQdbftrg) D qdbfTrgT 1 D qdbfTrgE 1 D qdbfTPgm 10 D qdbfTPLb 10 D qdbfTUpd 1 D qdbBits69 1 D Reserved_201 24 D pFD s * D wFD s 1000 dim(1000) based(pFD) D wCurTrg s 4b 0 ** Open file description p OpenFILD0100 b export d pi D xFile 20 const D xRcdFmt 10 const D wErr s 8 inz(x'0000000000000000') D wFDLen s 9b 0 D wFile s 20 D wFmt s 8 inz('FILD0100') D wFmtType s 10 inz('*INT') D wi s 5 0 D wOvr s 1 inz('0') D wRcdFmt s 10 D wSystem s 10 inz('*LCL') C eval wFile = xFile C eval wRcdFmt = xRcdFmt c* get size needed C call 'QDBRTVFD' C parm wFDSize C parm 8 wFDLen C parm wRtnFile C parm wFmt C parm wFile C parm wRcdFmt C parm wOvr C parm wSystem C parm wFmtType C parm wErr C eval pFD = malloc(wFDSize2) C call 'QDBRTVFD' C parm wFD C parm wFDSize2 wFDLen C parm wRtnFile C parm wFmt C parm wFile C parm wRcdFmt C parm wOvr C parm wSystem C parm wFmtType C parm wErr C movea wFD Qdb_Qdbfh C return p OpenFILD0100 e ** Close file description p CloseFILD0100 b export C dealloc pFD C return p CloseFILD0100 e ** Get Number of Triggers p GetNbrTrg b export d pi like(qdbfTrgN) C eval pQdbpf = pFD + Qdbpfof C return qdbfTrgN P GetNbrTrg e ** Get First Trigger p GetFirstTrg b export d pi 1 C eval pQdbpf = pFD + Qdbpfof C eval wCurTrg = 1 C if qdbfOTrg > 0 C eval pQdbfTrg = pFD + qdbfOTrg C return '0' C else C return '1' C endif p GetFirstTrg e ** Get Next Trigger p GetNextTrg b export d pi 1 C if wCurTrg < qdbfTrgN C eval wCurTrg = wCurTrg + 1 C eval pQdbfTrg = pQdbfTrg + %size(qdb_qdbfTrg) C return '0' C else C return '1' C endif p GetNextTrg e ** Get Trigger Time p GetTrgTime b export d pi 10 C select C when qdbfTrgT = '1' C return 'AFTER' C when qdbfTrgT = '2' C return 'BEFORE' C other C return qdbfTrgT C endsl p GetTrgTime e ** Get Trigger Event p GetTrgEvent b export d pi 10 C select C when qdbfTrgE = '1' C return 'INSERT' C when qdbfTrgE = '2' C return 'DELETE' C when qdbfTrgE = '3' C return 'UPDATE' C other C return qdbfTrgE C endsl p GetTrgEvent e ** Get Trigger Program p GetTrgPgm b export d pi like (qdbfTPgm) C return qdbfTPgm p GetTrgPgm e ** Get Trigger Program Library p GetTrgPgmLib b export d pi like (qdbftplb) C return qdbfTPLb p GetTrgPgmLib e ** Get Trigger Update Condition p GetTrgUpdCond b export d pi 10 C select C when qdbfTUpd = '1' C return 'ALWAYS' C when qdbfTUpd = '2' C return 'CHANGE' C other C return qdbfTUpd C endsl p GetTrgUpdCond e (malloc is defined like this:) ** Allocate memory p malloc b export d pi * d xSize 9b 0 const d pPtr s * C alloc xSize pPtr C return pPtr p malloc e Example Usage (pseudo): OpenFilD0100 eval *in99 = GetFirstTrg dow *in99 = *off eval fld1 = GetTrgPgm ... eval *in99 = GetNextTrg enddo CloseFilD0100 Thanks to Njål Fisketjøn

And one more example: * List Key Fields (QDBRTVFD retrieve file desc)API Procedure DListFileDesc pr ExtPgm('QDBRTVFD') d OutputData 32766a Options(*Varsize) d OutputDataLen 10i 0 Const d CUSPFNameRet 20a D PFRcdFmt 8a Const d CUSPFName 20a Const D RcdFmt 8a Const d OverrideProc 1a Const d System 10a Const d FormatType 10a Const d ErrorCode 32766a options(*varsize) * List File Description Header DS D FDHDS ds D FDHBytesRet 10i 0 D FDHBytesAvail 10i 0 D FDHMaxKeyLen 5i 0 D FDHKeyCount 5i 0 D FDHReserved 10a D FDHFormatCnt 5i 0 D KeyRecFmt 10a D KeyReserve 2a D Key#OfKeys 5i 0 D KeyReserv1 14a D KeyInfoOffset 10i 0 * List Key Information DS D KeyDS ds D KeyIntName 10a D KeyExtName 10a D KeyDtaType 5i 0 D KeyFldLen 5i 0 D Key#OfDigits 5i 0 D KeyDecPos 5i 0 D KeyAttrFlg 1a D KeyAltLen 5i 0 D KeyAltName 30a D KeyReserv3 1a D KeyAttrFlg1 1a D KeyReserv4 1a c CallP(E) ListFileDesc(OutputData: c OutputDataLen: c CUSPFNameRet: c 'FILD0300': C CUSPFName: c RcdFmtName: c OverrideProc: c '*LCL': c '*EXT': c ErrorDS) * If Any Errors Occur or No Key Fields Found, Set Number Of Keys To 0 c If OutputData=*Blanks C OR %Error c OR %len(%Trim(OutputData))=0 c Eval Key#OfKeys=0 c Else c MoveL OutputData FDHDS c EndIf * Process Key Information Stored in the OutputData Variable c Eval StrPos=KeyInfoOffset+1 c Do Key#OfKeys c Eval KeyDS=%Subst(OutputData:StrPos: c +%Size(KeyDS)) Thanks to Tommy Holden

Back

QDBLDBR

List Database Relations (link).

Back

QHFRTVAT

Retrieve Directory Entry Attributes (link).

Back

Qsn........ (DSM Api's)

	FDSMREADPT O    E             PRINTER
	 *
	D Str             S              4  0 inz(1)
	**-- Global variables:  -------------------------------------------------**
	D InpBufHdl       s             10i 0
	D InpDtaPtr       s               *
	**-- Parameters:  -------------------------------------------------------**
	D Parm            Ds
	D Row                           10i 0
	D Col                           10i 0
	D NbrBytRtn                     10i 0
	D Screen                      3564a
	**-- Prototype for DSM API's:  ------------------------------------------**
	D GetCsrAdr       Pr            10i 0 ExtProc( 'QsnGetCsrAdr' )
	D  Row                          10i 0
	D  Col                          10i 0
	D  LlvEnvHdl                    10i 0 Const  Options( *Omit )
	D  ApiError                   1024a          Options( *Omit: *VarSize )
	**
	D CrtInpBuf       Pr            10i 0 ExtProc( 'QsnCrtInpBuf' )
	D  InpBufSiz                    10i 0 Const
	D  BufIncSiz                    10i 0 Const  Options( *Omit )
	D  BufMaxSiz                    10i 0 Const  Options( *Omit )
	D  InpBufHdl                    10i 0        Options( *Omit )
	D  ApiError                   1024a          Options( *Omit: *VarSize )
	**
	D ReadScr         Pr            10i 0 ExtProc( 'QsnReadScr' )
	D  NbrBytRead                   10i 0        Options( *Omit )
	D  InpBufHdl                    10i 0 Const  Options( *Omit )
	D  CmdBufHdl                    10i 0 Const  Options( *Omit )
	D  LlvEnvHdl                    10i 0        Options( *Omit )
	D  ApiError                   1024a          Options( *Omit: *VarSize )
	**
	D RtvDta          Pr              *   ExtProc( 'QsnRtvDta' )
	D  InpBufHdl                    10i 0 Const
	D  InpDtaPtr                      *          Options( *Omit )
	D  ApiError                   1024a          Options( *Omit: *VarSize )
	**
	D*Beep            Pr            10i 0 ExtProc( 'QsnBeep' )
	D* CmdBufHdl                    10i 0 Const  Options( *Omit )
	D* LlvEnvHdl                    10i 0 Const  Options( *Omit )
	D* ApiError                   1024a          Options( *Omit: *VarSize )
	**
	D DltBuf          Pr            10I 0 ExtProc( 'QsnDltBuf' )
	D  BufferHdl                    10I 0 Const
	D  ApiError                   1024a          Options( *Omit: *VarSize )
	**--
	D MemCpy          Pr              *   ExtProc( 'memcpy' )
	D pOutMem                         *   Value
	D pInpMem                         *   Value
	D InpMemSiz                     10u 0 Value
	 **************************************************************************
	 * $GetScrn
	 **************************************************************************
	C     $GetScrn      BEGSR
	C                   Eval      InpBufHdl  =  CrtInpBuf( 27 * 132
	C                                                    : *Omit
	C                                                    : *Omit
	C                                                    : *Omit
	C                                                    : *Omit )
	 *
	C                   CallP     GetCsrAdr( Row
	C                                      : Col
	C                                      : *Omit
	C                                      : *Omit )
	 *
	C                   Eval      NbrBytRtn  =  ReadScr( *Omit
	C                                                  : InpBufHdl
	C                                                  : *Omit
	C                                                  : *Omit
	C                                                  : *Omit )
	 *
	C                   Eval      InpDtaPtr  =  RtvDta( InpBufHdl
	C                                                 : *Omit
	C                                                 : *Omit )
	 *
	C                   CallP     MemCpy( %Addr( Screen )
	C                                   : InpDtaPtr
	C                                   : NbrBytRtn  )
	 *
	C*                  CallP     Beep( *Omit
	C*                                : *Omit
	C*                                : *Omit )
	 *
	C                   CallP     DltBuf( InpBufHdl: *Omit )
	 *
	C                   ENDSR
	 **************************************************************************
	 * $PrtScrn
	 **************************************************************************
	C     $PrtScrn      BEGSR
	 *
	C                   dow       Str < %len(%trim(Screen))
	C                   eval      PT80 =  %subst(Screen:Str:80)
	C                   write     RDSMREAD
	C                   eval      Str = Str + 80
	C                   enddo
	 *
	C                   ENDSR
	 **************************************************************************
	 * *INZSR
	 **************************************************************************
	C     *INZSR        BEGSR
	 *
	C                   exsr      $GetScrn
	C                   exsr      $PrtScrn
	C                   eval      *INLR = *ON
	 *
	C                   ENDSR

Back

QSYRUSRI

Retrieve User Information (link).


Q: Is there an API for determining if a user profile is a member of a group? A: There isn't anything THIS simple, but you could certainly write a service program, and IT could be this simple to use. :) In fact, here's one that I wrote, along with an example of using it: Example of calling GROUP service program: D/COPY QRPGLESRC,GROUP_H D Msg S 50A c *entry plist c parm UserID 10 c parm Group 10 c if IsInGroup(UserID: Group) = 1 c eval Msg = 'User is in that group!' C else c eval Msg = 'User is not in that group!' c endif c dsply Msg c eval *inlr = *on Start of header file for GROUP service program (GROUP_H): D IsInGroup PR 10I 0 D UsrPrf 10A const D GrpPrf 10A const Start of source for GROUP service program: D/COPY QRPGLESRC,GROUP_H P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P* IsInGroup( UserProfile : GroupProfile) P* Checks if a user is in a given group profile. P* P* Returns: -1 = Error, 0 = Not In Group, 1 = Is In Group P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P IsInGroup B export D IsInGroup PI 10I 0 D UsrPrf 10A const D GrpPrf 10A const D RtvUsrPrf PR ExtPgm('QSYRUSRI') D RcvVar 32766A OPTIONS(*VARSIZE) D RcvVarLen 10I 0 const D Format 8A const D UsrPrf 10A const D Error 32766A OPTIONS(*VARSIZE) D dsEC DS D* Bytes Provided (size of struct) D dsECBytesP 1 4B 0 INZ(256) D* Bytes Available (returned by API) D dsECBytesA 5 8B 0 INZ(0) D* Msg ID of Error Msg Returned D dsECMsgID 9 15 D* Reserved D dsECReserv 16 16 D* Msg Data of Error Msg Returned D dsECMsgDta 17 256 D dsRU DS D* Bytes Returned D dsRUBytRtn 10I 0 D* Bytes Available D dsRUBytAvl 10I 0 D* User Profile Name D dsRUUsrPrf 10A D* User Class D dsRUClass 10A D* Special Authorities D dsRUSpcAut 15A D* Group Profile Name D dsRUGrpPrf 10A D* Owner D dsRUOwner 10A D* Group Authority D dsRUGrpAut 10A D* Limit Capabilities D dsRULmtCap 10A D* Group Authority Type D dsRUAutTyp 10A D* (reserved) D dsRUResrv1 3A D* Offset to Supplemental Groups D dsRUoffSG 10I 0 D* Number of Supplemental Groups D dsRUnumSG 10I 0 D* Supplemental Groups D dsRUSupGrp 10A DIM(15) D X S 5I 0 C* Get User Profile c callp RtvUsrPrf( dsRU: %Size(dsRU): 'USRI0200': c UsrPrf: dsEC) C* Check for errors c if dsECBytesA > 0 c return -1 c endif c if dsRUnumSG<0 or dsRUnumSG>15 c return -1 c endif C* In primary group? c if dsRUGrpPrf = GrpPrf c return 1 c endif C* In supplemental group? c do dsRUnumSG X c if dsRUSupGrp(X) = GrpPrf c return 1 c endif c enddo C* Not in group. c return 0 P E Thanks to Scott Klement
Back

QUSCRTUS

Create User Space (link).

Back

QUSLJOB

List Job (link).

Back

QUSLMBR

List Database File Members (link).

Back

QUSLOBJ

List Objects (link).

Another example: Here's my meger offering for a member-finding application. The application posted before has beauty in its simplicity, and I will not argue with that. I put this out although there was already another application posted, for a few reasons: I believe in the QSYSINC copy code, and make extensive use of it. You may (or may not) find the pointer use to get around some of the QSYSINC limitations interesting. I believe also in extensive error handling, and in modularization of code. This application, which I culled from a bigger special-purpose application, could be more modular, but .... There are no external requirements (such as DB files) used by this application.
SO for what it's worth, here is the command source: CMD PROMPT('Find a file member by name') PARM KWD(MEMBER) TYPE(*GENERIC) LEN(10) MIN(1) + PROMPT('Member name') PARM KWD(LIB) TYPE(*NAME) LEN(10) DFT(*USRLIBL) + SNGVAL((*USRLIBL) (*LIBL) (*CURLIB) + (*ALLUSR) (*ALL)) MAX(50) + PROMPT('Library/ies to search') PARM KWD(INFILE) TYPE(*GENERIC) LEN(10) DFT(*ALL) + SPCVAL((*ALL)) PROMPT('File name(s) to + search') PARM KWD(FILTYP) TYPE(*NAME) RSTD(*YES) + DFT(*PHYSICAL) SPCVAL((*PHYSICAL PF) + (*LOGICAL LF) (*ANY) (PF) (PF38) (LF) + (LF38)) PROMPT('Type of files to search')
And the ILE RPG source: H/TITLE Find a file member on the system FNDMBR H OPTION(*NOSHOWCPY:*NOEXPDDS:*NODEBUGIO) *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * * *+Find a member by name anywhere in the system -* * * * This application will find and list (via message) all the members * * that match the specified name, in any files on the system * * * * Parameters: * * Member name (generic* OK) CHAR 10 * * Libraries CHAR 502 * * Files to search (Generic*) CHAR 10 * * Filetype CHAR 10 PF LF *ANY PF38... * * * * ---Log---------------------------------------Author-------Date--- * *+Original version Lovelady 8Nov2002-* * ---End of log---------------------------------------------------- * *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* *+ PLEASE keep the next two lines TOGETHER!!! - D/Copy qsysinc/qrpglesrc,qusec D QUSED01 1024 *+ PLEASE keep the previous two lines TOGETHER!!! - D/Copy qsysinc/qrpglesrc,quslobj D/Copy qsysinc/qrpglesrc,quslmbr D/Copy qsysinc/qrpglesrc,qusgen * IBM API QMHSNDPM will send a message to a program message queue. * We use this API to log CL commands before executing them, and * to inform the user of invalid / exceptional conditions. DQUSLOBJ_API PR ExtPgm('QUSLOBJ') D UserSpace const like(QualName) D FormatName 8 const D QualObj const like(QualName) D ObjectType 10 const D ErrorStruct like(QUSEC) Options(*varsize) DQMHSNDPM_API PR ExtPgm('QMHSNDPM') D MessageID const like(QUSEI) D MessageFile const like(MsgFile) D MessageData 1 const Options(*varsize) D LengthMsgDta 10I 0 const D MessageType 10 const D CallStackEnt 10 const Options(*varsize) D CallStkEntCtr 10I 0 const D MessageKey like(MsgKey) D ErrorStruct like(QUSEC) Options(*varsize) * IBM API QUSLMBR will list the members in a file. Output is to a * user space. D QUSLMBR_API PR ExtPgm('QUSLMBR') D UserSpace const like(QualName) D FormatName 8 const D FileName const like(QualName) D MbrName 10 const D Overrides 1 const D ErrorStruct like(QUSEC) D CrtUsrSpace PR * D UsrSpcName Const Like(QualName) D UsrSpcDescr 50 Const D SendEscape PR D MsgID Const Like(QUSEI) D MsgData Const Like(QUSED01) D SndMsg PR D MSGID Const Like(QUSEI) D MSGDTA Const Like(QUSED01) D TOPGMQ 10 Const D MSGTYPE 10 Const * IBM API QUSDLTUS will delete a user space. DQUSDLTUS_API PR ExtPgm('QUSDLTUS') D SpaceName const like(QualName) D ErrorParm like(QUSEC) D ObjUsrSpc C 'FINDMBROBJQTEMP' D MbrUsrSpc C 'FINDMBRMBRQTEMP' D QCPFMSG C 'QCPFMSG *LIBL' * Parameters D ParmMbrName S 10 D ParmLibNames DS D InLibCount 5I 0 D InLibName 10 Dim(50) D ParmInFile S 10 D ParmFileType S 10 * Pointers D pCurrObj S * D pCurrMbr S * D pMbrSpace S * D pObjSpace S * D pSpace S * * Other variables D CmdString S 2048 D Encountered S 9 0 D ErrorsOK S 1N Inz(*Off) D i S 5 0 D j S 5 0 D LibNbr S 9 0 D LogCommand S 1N Inz(*Off) D MbrNbr S 9 0 D NbrMembers S 10I 0 D NbrObjects S 10I 0 D ObjNbr S 9 0 D QualName DS D ObjName 10 D LibName 10 D ReturnLib S 10 D SizMbrEntry S 10I 0 D SizObjEntry S 10I 0 D MsgFile S 20 Inz(QCPFMSG) D MsgKey S 4 D MsgPgmQ S 10 Inz('*') D MsgType S 10 Inz('*COMP') D Processed S 5 0 D ResultCmd S 2048 D ResultCmdLen S 10I 0 D StackCnt S 10I 0 Inz(*Zero) D NotProcessed S 5 0 D MbrProcessed S 1N D VarStruct S 32767 Based(pSpace) C *Entry Plist C Parm ParmMbrName C Parm ParmLibNames C Parm ParmInFile C Parm ParmFileType * Move input and output filenames into work fields (we may change * our copy, and shouldn't touch the original). C Exsr InzFields C Eval pObjSpace = C CrtUsrSpace(ObjUsrSpc: C 'Files on the system') C Eval pMbrSpace = C CrtUsrSpace(MbrUsrSpc: C 'Members in files') C For LibNbr = 1 to InLibCount C ExSR GetObjList C EndFOR C Eval *INLR=*On * Delete user space and work file. C ExSR CleanUp CSR InzFields BegSR * Initialize our internal message work area C Eval QUSEC = *Loval C Eval QUSBPRV = %Size(QUSEC) CSR EndSR CSR GetObjList BegSR C CallP QUSLOBJ_API( C ObjUsrSpc C : 'OBJL0200' C : ParmInFile + C InLibName(LibNbr) C : '*FILE' C : QUSEC) C If (QUSBAVL > 0) C CallP SendEscape(QUSEI: QUSED01) C EndIF C Eval pSpace = pObjSpace C Eval QUSH0100 = VarStruct C Eval NbrObjects = QUSNBRLE C Eval SizObjEntry = QUSSEE C Eval pCurrObj = pObjSpace + QUSOLD C For ObjNbr = 1 to NbrObjects C Eval pSpace = pCurrObj C Eval QUSL020002 = VarStruct C If ParmFileType = '*ALL' C or ParmFileType = C %Subst(QUSEOA:1: C %Len(%Trim(ParmFileType))) C Eval QualName = QUSOBJNU00 + QUSOLNU00 C ExSR GetMbrList C EndIF C Eval pCurrObj = pCurrObj + SizObjEntry C EndFOR CSR EndSR CSR GetMbrList BegSR ********************************************************************* * Retrieve list of members into user space. * ********************************************************************* C CallP QUSLMBR_API( C MbrUsrSpc C : 'MBRL0200' C : QualName C : ParmMbrName C : '0' C : QUSEC C ) C If (QUSBAVL > 0) C CallP SendEscape(QUSEI: QUSED01) C EndIF C Eval pSpace = pMbrSpace C Eval QUSH0100 = VarStruct C Eval NbrMembers = QUSNBRLE C Eval SizMbrEntry = QUSSEE C Eval pCurrMbr = pMbrSpace + QUSOLD C For MbrNbr = 1 to NbrMembers C Eval pSpace = pCurrMbr C Eval QUSL0200 = VarStruct C ExSR MatchMbr C Eval pCurrMbr = pCurrMbr + SizMbrEntry C EndFOR CSR EndSR CSR MatchMbr BegSR C CallP SndMsg(' ' C : %Trim(LibName) + '/' + C %Trim(ObjName) + '(' + C %Trim(QUSMN01) + ') srctype=' + C %Trim(QUSST) + ' text="' + C %Trim(QUSMD) + '"' C : '*' : '*INFO') CSR EndSR CSR CleanUp BegSR ********************************************************************* * Delete the user spaces * ********************************************************************* C CallP QUSDLTUS_API( C ObjUsrSpc C : QUSEC C ) C CallP QUSDLTUS_API( C MbrUsrSpc C : QUSEC C ) CSR EndSR P CrtUsrSpace B D CrtUsrSpace PI * D UsrSpcName Const Like(QualName) D UsrSpcDescr 50 Const D SpcPointer S * * IBM API QUSCRTUS will create a user space, which we will need for * QUSLMBR output D CrtUsrSpc PR ExtPgm('QUSCRTUS') D SpaceName const like(QualName) D Attr 10 const D InlSize 10I 0 const D InlValue 1 const D Authority 10 const D TextDescr 50 const D Replace 10 const D ErrorParm like(QUSEC) * IBM API QUSCHGUS will change a user space's attributes. We use * this to make a user space extendable D ChgUsrSpc PR ExtPgm('QUSCUSAT') D RtnLib like(ReturnLib) D SpaceName const like(QualName) D AttrList const like(ChangeAttrs) D ErrorParm like(QUSEC) D* Structure to change the USRSPC attr to extendable D ChangeAttrs DS * Description field-by-field * Number_Attrs = Number of attributes (1) * 1-element array of attribute definitions as follows: * Attr_Key1 = Identify attribute to change (3=Extendable attr.) * Attr_Siz1 = Length of the attribute itself (1) * Attr_Dta1 = New value for this attribute (1="yes") D Number_Attrs 10I 0 Inz(1) D Attr_Key1 10I 0 Inz(3) D Attr_Siz1 10I 0 Inz(1) D Attr_Dta1 1 Inz('1') * IBM API QUSPTRUS will obtain a pointer to a user space. D RtvPtrUsrSpc PR ExtPgm('QUSPTRUS') D SpaceName const like(QualName) D ReturnPtr * D ErrorParm like(QUSEC) ********************************************************************* * Create our user space for retrieving list of members * * * * We need to retrieve a list of members in the file. IBM API * * QUSLMBR returns that information. This API requires a User Space * * to store its result. Because we don't know how big the User * * Space needs to be, we'll create it fairly small and then make it * * extendable. API QUSCRTUS will create the User Space and * * QUSCHGUS will allow us to change its attributes (extendable). * ********************************************************************* * Create our user space C Callp CrtUsrSpc(UsrSpcName : '"MbrList"' C : 4096 : x'00' : '*USE' C : UsrSpcDescr C : '*NO' : QUSEC C ) C If QUSEI = 'CPF9870' * Ignore "Object exists" message. This is not a problem. C Eval QUSBAVL = 0 C Eval QUSEI = *Blanks C EndIf C If (QUSBAVL = 0) * Change user space to be extendable C Callp ChgUsrSpc(ReturnLib : UsrSpcName C : ChangeAttrs : QUSEC C ) C EndIF * Retrieve pointer to the user space C Callp RtvPtrUsrSpc(UsrSpcName : SpcPointer C : QUSEC C ) * If any error occurred, pass it on to the user and escape C If (QUSBAVL > 0) C CallP SendEscape(QUSEI: QUSED01) C EndIF C Return SpcPointer P CrtUsrSpace E P SendEscape B D SendEscape PI D MSGID Const Like(QUSEI) D MSGDTA Const Like(QUSED01) ********************************************************************* * This routine will send an escape message to this program's msgq * ********************************************************************* C Eval MsgPgmQ = '*PGMBDY' C Eval MsgType = '*ESCAPE' C CallP SndMsg(MSGID: MSGDTA: C '*PGMBDY':'*ESCAPE') P SendEscape E P SndMsg B D SndMsg PI D MSGID Const Like(QUSEI) D MSGDTA Const Like(QUSED01) D TOPGMQ 10 Const D MSGTYPE 10 Const ********************************************************************* * Send an error message to the program. *ESCAPE messages will * * cause this program to abort. * ********************************************************************* C Select C When MsgType = '*ESCAPE' * Escape messages are sent to the caller C Eval StackCnt = 1 C When MsgType = '*COMP' * Completion messages are sent to the caller of the caller C Eval StackCnt = 2 C Other * All other messages are sent to our own joblog message queue C Eval StackCnt = *Zero C EndSL C CallP QMHSNDPM_API( C MSGID C : MsgFile C : MSGDTA C : %Len(%TrimR(MSGDTA)) C : MSGTYPE C : TOPGMQ C : StackCnt C : MsgKey C : QUSEC C ) C Eval QUSED01 = *Blank C Eval MsgPgmQ = '*' C Eval MsgFile = QCPFMSG P SndMsg E
Thanks to Dennis Lovelady
Back

QUSRJOBI

Retrieve Job Information (link).

Back

QUSRTVUS

Retrieve User Space (link).

Back

QWCRNETA

Retrieve Network Attributes (link).

Another example: ** Note: To do this right, we should put this prototype into * a /COPY member. (but will work okay as-is) D RtvSysName PR 10I 0 D SystemName 8A C if RtvSysName(MyName) < 0 c eval Msg = 'RtvSysName ended in error!' c dsply Msg 50 c else c dsply MyName 8 c endif c eval *inlr = *on ** Note: If we wanted to do this right, the code below should * be seperated into a service program (but will work * okay as-is) *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * Retrieve System Name procedure: RtvSysName * * Parm: SysName = name of system returned. * * Returns: 0 = Success * negative value if an error occurred. See below * for a list of possible negative values. *++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P RtvSysName B Export D RtvSysName PI 10I 0 D SysName 8A D QWCRNETA PR ExtPgm('QWCRNETA') D RcvVar 32766A OPTIONS(*VARSIZE) D RcvVarLen 10I 0 const D NbrNetAtr 10I 0 const D AttrNames 10A const D ErrorCode 256A D* Error code structure D EC DS D* Bytes Provided (size of struct) D EC_BytesP 1 4B 0 INZ(256) D* Bytes Available (returned by API) D EC_BytesA 5 8B 0 INZ(0) D* Msg ID of Error Msg Returned D EC_MsgID 9 15 D* Reserved D EC_Reserve 16 16 D* Msg Data of Error Msg Returned D EC_MsgDta 17 256 D* Receiver variable for QWCRNETA with only one attribute D RV ds D* Number of Attrs returned D RV_Attrs 10I 0 D* Offset to first attribute D RV_Offset 10I 0 D* Add'l data returned. D RV_Data 1A DIM(1000) D* Network attribute structure D p_NA S * D NA ds based(p_NA) D* Attribute Name D NA_Attr 10A D* Type of Data. C=Char, B=Binary D NA_Type 1A D* Status. L=Locked, Blank=Normal D NA_Status 1A D* Length of Data D NA_Length 10I 0 D* Actual Data (in character) D NA_DataChr 1000A D* Actual Data (in binary) D NA_DataInt 10I 0 overlay(NA_DataChr:1) C* Call API to get system name C* -1 = API returned an error C callp QWCRNETA(RV: %size(RV): 1: 'SYSNAME': EC) c if EC_BytesA > 0 c return -1 c endif C* -2 = RcvVar contained data that we C* dont understand :( c if RV_Attrs <> 1 c or RV_Offset < 8 c or RV_Offset > 1000 c return -2 c endif C* Attach NetAttr structure c eval RV_Offset = RV_Offset - 7 c eval p_NA = %addr(RV_Data(RV_Offset)) C* -3 = NetAttr structure had data C* that we don't understand :( c if NA_Attr <> 'SYSNAME' c or NA_Length < 1 c or NA_Length > 8 c return -3 c endif C* -4 = Network attributes are locked c if NA_Status = 'L' c return -4 c endif C* Ahhh... we got it! c eval SysName = %subst(NA_DataChr:1:NA_Length) c return 0 P E Thanks to Scott Klement

Back

QWCRSVAL

Retrieve System Value (link).

Another example:

	DQWCRDR00         DS
	D*                                             Qwc Rsval Data Rtnd
	D QWCNSVR                 1      4B 0
	D*                                             Number Sys Vals Rtnd
	D QWCOSVT                 5      8B 0
	D*
	D Data                           1    dim(2096)

	D QWCSV00         DS          2096
	D  QWCSV01                      10    OVERLAY(QWCSV00:00001)
	D  QWCTD01                       1    OVERLAY(QWCSV00:00011)
	D  QWCIS03                       1    OVERLAY(QWCSV00:00012)
	D  QWCLD01                       9B 0 OVERLAY(QWCSV00:00013)
	D  QWCDATA01                  2080    OVERLAY(QWCSV00:00017)

	DQUSEC            DS           116    inz
	D QUSBPRV                 1      4B 0 inz(116)
	D QUSBAVL                 5      8B 0 inz(0)
	D QUSEI                   9     15
	D QUSERVED               16     16
	D QUSED01                17    116

	D LockedCon       c                   'System value was locked'
	D MoveInd         S              5  0
	D NbrOfVals       S             10i 0 Inz(1)
	D OutData         s             50
	D ReceiveLen      S             10i 0 Inz(2104)
	D SysValue        s             10

	DBinaryCvt        DS
	D BinaryNbr               1      4B 0

	c     *entry        Plist
	c                   Parm                    SysValue

	 * Call the api to get the information you want
	C                   Call      'QWCRSVAL'
	C                   Parm                    QwcRdr00
	C                   Parm                    ReceiveLen
	C                   Parm                    NbrofVals
	C                   Parm                    SysValue
	C                   Parm                    QusEc

	 * Process the data from the API
	c                   Eval      MoveInd = Qwcosvt - 7
	c                   Movea     Data(MoveInd) QwcSV00

	c                   Select
	 *  Value was locked, couldn't get it
	c                   When      QwcIs03 = 'L'
	c                   Movel     LockedCon     OutData
	 *  Character data
	c                   When      QwcTd01 = 'C'
	c                   Movel     QwcData01     OutData
	 *  Binary data
	c                   When      QwcTd01 = 'B'
	c                   Movel     QwcData01     BinaryCvt
	c                   Movel     BinaryNbr     OutData
	c                   Endsl

	 * Display system value
	c     OutData       dsply
	c                   Eval      *inlr = *on

Thanks to Ron Hawkins

and another example in CL: pgm dcl &rcvvar *char 999 dcl &lenrcvvar *char 4 dcl &nbrsysval *char 4 dcl &sysvalnam *char 80 dcl &errcod *char 8 chgvar %bin( &lenrcvvar ) ( 999 ) chgvar %bin( &nbrsysval ) ( 2 ) chgvar &sysvalnam ( + 'QSYSLIBL ' *cat + 'QUSRLIBL ' + ) call QWCRSVAL ( + &rcvvar + &lenrcvvar + &nbrsysval + &sysvalnam + &errcod + ) dmpclpgm return endpgm Thanks to Tom Liotta

Back

CEELOCT, CEEDATM & CEEUTCO

Q:	I have a need to retrieve the current time (seconds, not milliseconds) and
	format it.

A:	There's an API which will do MOST (but not all) of the work for you.
	Specifically, it does not know how to format an offset from UTC (the
	"-0500" part)

	The API that does all of the formatting is the "CEEDATM" API which can
	be found in the "ILE CEE APIs" manual.

	Here's an example of what you're trying to do:


	 ** Get local time API
	d CEELOCT         PR                  opdesc
	d   output_lil                        Like(discard1)
	d   output_secs                       Like(cur_time)
	d   output_greg                       Like(discard2)
	d   output_fc                         Like(Fc) Options(*Nopass)
	 ** Convert to arbitrary timestamp API
	d CEEDATM         PR                  opdesc
	d   input_secs                        Like(cur_time)
	d   picture_str                       Like(Pictureds) const
	d   output_ts                         Like(Pictureds)
	d   output_fc                         Like(Fc) Options(*Nopass)
	 * Get offset from UTC API
	d CEEUTCO         PR
	d  hours                              Like(hrs2utc)
	d  minutes                            Like(mins2utc)
	d  seconds                            Like(cur_time)
	d  output_fc                          Like(Fc) Options(*Nopass)

	d discard1        S             10I 0
	d cur_time        S              8F
	d discard2        S             23A
	d hrs2utc         s             10I 0
	d mins2utc        s                   Like(hrs2utc)
	d hh              s              2A
	d mm              s              2A
	d discard3        s                   Like(cur_time)
	d WDate           s                   Like(Pictureds)

	d Fc              ds
	d  sev                           5U 0
	d  msgno                         5U 0
	d  flags                         1A
	d  facid                         3A
	d  isi                          10U 0
	d Pictureds       ds
	d  Piclen1                1      2I 0
	d  Picture                3     34A
	d  Piclen2                1      4I 0
	d  Picture2               5     36A

	 * Get current local time from clock:
	c                   Callp     CEELOCT(discard1 : cur_time : discard2)
	 * Convert to e-mail format:
	c                   Callp     CEEDATM(cur_time :
	c                                     'Www, DD Mmm YYYY HH:MI:SS' :
	c                                     WDate)
	 * Retrieve offset from UTC
	c                   Callp     CEEUTCO(hrs2utc : mins2utc : discard3)
	 * Format the UTC offset nicely
	 *   and tack it onto the string...
	c                   If        hrs2utc < *Zero
	c                   Eval      WDate = %trimr(WDate) + ' -'
	c                   Eval      hrs2utc = 0 - hrs2utc
	c                   Else
	c                   Eval      WDate = %trimr(WDate) + ' +'
	c                   EndIf
	c                   Move      hrs2utc       hh
	c                   Move      mins2utc      mm
	c                   Eval      WDate = %TrimR(WDate) + hh + mm

	C* Let's see if that worked :)
	c                   dsply                   wDate
	c                   eval      *inlr = *on

A visitor to my site warned me about using *NOPASS and instead use the *OMIT, as iSeries Information Center writes the following: The ILE CEE APIs have parameters that can be omitted. The parameter table for each ILE CEE API uses the term omissible for these parameters. Warning: It is essential to pass the correct number of parameters, including omitted parameters. You need to use the language-specific syntax for omitted parameters; failure to do so may result in unpredictable results, including a system failure. ITjungle has an article with examples using both *NOPASS and *OMIT

Thanks to Scott Klement & Jon A. Erickson

Back

CEEGPID

Retrieve ILE Version and Platform ID


	D VerRelMod       S             10I 0
	D OSPlatform      S             10I 0

	C                   CallB     'CEEGPID'
	C                   Parm                    VerRelMod
	C                   Parm                    OSPlatform
	C                   If        VerRelMod >= 510
	 * Insert V5R1 and later code here
	C                   endif

Thanks to Bob Cozzi
Back

QWCLOBJL

Can anybody out there point me to an example of using QWCLOBJL (List Object Locks)
API in ILE RPG?  I've not made much use of list API's, and I'm having a little trouble
wrapping my head around retreival and presentation.


     H DFTACTGRP(*NO) ACTGRP(*NEW) OPTION(*SRCSTMT)

     D CrtUsrSpc       PR                  ExtPgm('QUSCRTUS')
     D   UsrSpc                      20A   CONST
     D   ExtAttr                     10A   CONST
     D   InitSize                    10I 0 CONST
     D   InitVal                      1A   CONST
     D   PublicAuth                  10A   CONST
     D   Text                        50A   CONST
     D   Replace                     10A   CONST
     D   ErrorCode                32766A   options(*varsize)

     D RtvPtrUS        PR                  ExtPgm('QUSPTRUS')
     D   UsrSpc                      20A   CONST
     D   Pointer                       *

     D LstObjLck       PR                  ExtPgm('QWCLOBJL')
     D   UsrSpc                      20A   const
     D   Format                       8A   const
     D   Object                      20A   const
     D   ObjType                     10A   const
     D   Member                      10A   const
     D   ErrorCode                32766A   options(*varsize)

     D*****************************************************
     D* API error code data structure
     D*****************************************************
     D dsEC            DS
     D*                                    Bytes Provided (size of struct)
     D  dsECBytesP             1      4I 0 INZ(256)
     D*                                    Bytes Available (returned by API)
     D  dsECBytesA             5      8I 0 INZ(0)
     D*                                    Msg ID of Error Msg Returned
     D  dsECMsgID              9     15
     D*                                    Reserved
     D  dsECReserv            16     16
     D*                                    Msg Data of Error Msg Returned
     D  dsECMsgDta            17    256

     D*****************************************************
     D* List API generic header data structure
     D*****************************************************
     D dsLH            DS                   BASED(p_UsrSpc)
     D*                                     Filler
     D   dsLHFill1                  103A
     D*                                     Status (I=Incomplete,C=Complete
     D*                                             F=Partially Complete)
     D   dsLHStatus                   1A
     D*                                     Filler
     D   dsLHFill2                   12A
     D*                                     Header Offset
     D   dsLHHdrOff                  10I 0
     D*                                     Header Size
     D   dsLHHdrSiz                  10I 0
     D*                                     List Offset
     D   dsLHLstOff                  10I 0
     D*                                     List Size
     D   dsLHLstSiz                  10I 0
     D*                                     Count of Entries in List
     D   dsLHEntCnt                  10I 0
     D*                                     Size of a single entry
     D   dsLHEntSiz                  10I 0

     D*****************************************************
     D*  List Object Locks API format OBJL0100
     D*****************************************************
     D dsOL            DS                  based(p_Entry)
     D*                                     Job Name
     D  dsOL_JobName                 10A
     D*                                     Job User Name
     D  dsOL_UserName                10A
     D*                                     Job Number
     D  dsOL_JobNbr                   6A
     D*                                     Lock State
     D  dsOL_LckState                10A
     D*                                     Lock Status
     D  dsOL_LckSts                  10i 0
     D*                                     Lock Type
     D  dsOL_LckType                 10i 0
     D*                                     Member (or *BLANK)
     D  dsOL_Member                  10A
     D*                                     1=Shared File, 0=Not Shared
     D*                                        (or 0=not applicable)
     D  dsOL_Share                    1A
     D*                                     Lock Scope
     D  dsOL_LckScope                 1A
     D*                                     Thread identifier
     D  dsOL_ThreadID                 8A


     D p_UsrSpc        S               *
     D p_Entry         S               *
     D Msg             S             50A
     D x               S             10I 0

     C     *entry        plist
     c                   parm                    ObjName          10
     C                   parm                    ObjLib           10
     c                   parm                    ObjType          10
     c                   parm                    Member           10

     c                   eval      *inlr = *on

     c                   if        %parms < 4
     c                   eval      Msg = 'Usage: objlock NAME LIB TYPE MBR'
     c                   dsply                   Msg
     c                   return
     c                   endif

     C*******************************************
     C* Create a user space to store output of
     C*  the list object locks API
     C*******************************************
     c                   callp     CrtUsrSpc('OBJLOCKS  QTEMP': 'USRSPC':
     c                               1: x'00': '*ALL': 'Output of List ' +
     c                               'Object Locks API': '*YES': dsEC)
     c                   if        dsECBytesA > 0
     c                   eval      Msg = 'QUSCRTUS error ' + dsECMsgID
     c                   dsply                   msg
     c                   return
     c                   endif

     C*******************************************
     C* Dump the Object Locks to the user space
     C*******************************************
     c                   callp     LstObjLck('OBJLOCKS  QTEMP': 'OBJL0100':
     c                               ObjName+ObjLib: ObjType: Member: dsEC)
     c                   if        dsECBytesA > 0
     c                   eval      Msg = 'QWCLOBJL error ' + dsECMsgID
     c                   dsply                   msg
     c                   return
     c                   endif

     C*******************************************
     C*  Get a pointer to the user space
     C*******************************************
     c                   callp     RtvPtrUS('OBJLOCKS  QTEMP': p_UsrSpc)

     C*******************************************
     C* Read each entry in the list
     C*   and (for sake of example) display
     C*   the lock details
     C*******************************************
     c                   for       x = 0 to (dsLHEntCnt-1)
     c                   eval      p_Entry = p_UsrSpc +
     c                                 (dsLHLstOff + (dsLHEntSiz*x))

     c                   eval      Msg = 'Job = '+%trimr(dsOL_JobNbr) +'/'+
     c                                            %trimr(dsOL_UserName)+'/'+
     c                                            %trimr(dsOL_JobName)
     c     Msg           dsply

     c                   eval      Msg = 'Lock State = ' + dsOL_LckState
     c     Msg           dsply

     c                   select
     c                   when      dsOL_LckSts = 1
     c                   eval      Msg = 'Lock Status = HELD'
     c                   when      dsOL_LckSts = 2
     c                   eval      Msg = 'Lock Status = WAIT'
     c                   when      dsOL_LckSts = 2
     c                   eval      Msg = 'Lock Status = REQ'
     c                   endsl
     c     Msg           dsply

     c                   select
     c                   when      dsOL_LckType = 1
     c                   eval      Msg = 'Lock Type = OBJECT'
     c                   when      dsOL_LckType = 2
     c                   eval      Msg = 'Lock Type = MBR CTL BLK'
     c                   when      dsOL_LckType = 3
     c                   eval      Msg = 'Lock Type = MBR ACC PTH'
     c                   when      dsOL_LckType = 3
     c                   eval      Msg = 'Lock Type = MBR DATA'
     c                   endsl
     c     Msg           dsply

     c                   eval      Msg = 'Member = ' + dsOL_Member
     c     Msg           dsply

     c                   if        dsOL_Share = '1'
     c                   eval      Msg = 'Share lock = YES'
     c                   else
     c                   eval      Msg = 'Share lock = NO'
     c                   endif
     c     Msg           dsply

     c                   if        dsOL_LckScope = '1'
     c                   eval      Msg = 'Scope = THREAD'
     c                   else
     c                   eval      Msg = 'Scope = JOB'
     c                   endif
     c     Msg           dsply

     c                   eval      Msg = '<< PRESS ENTER >>'
     c                   dsply                   Msg

     c                   endfor

Thanks to Scott Klement
Back

QSNDDTAQ

Send Data Queue Entry (link).

Back

QRCVDTAQ

Receive Data Queue Entry (link).
Back

QWCRSSTS
CLLE example: 

   Pgm
/*- Global variables:  ------------------------------------*/
    Dcl        &PxSysAsp     *Dec    ( 11  3 )
    Dcl        &PxSysAspUs   *Dec    ( 11  4 )
    Dcl        &PxTotAuxSt   *Dec    ( 11  3 )

    Dcl        &SsRcvVar     *Char     64
    Dcl        &SsRcvVarLn   *Char      4    x'00000040'
    Dcl        &SsFmtNam     *Char      8    'SSTS0200'
    Dcl        &SsResStc     *Char     10    '*NO'
    Dcl        &ApiError     *Char      4    x'00000000'

/*- Global error monitor:  --------------------------------*/
    MonMsg     CPF0000       *N        GoTo  EndPgm

/*- Mainline:  --------------------------------------------*/
    Call       QWCRSSTS    ( &SsRcvVar                +
                             &SsRcvVarLn              +
                             &SsFmtNam                +
                             &SsResStc                +
                             &ApiError                )

    ChgVar     &PxSysAsp   ( %Bin( &SsRcvVar  49  4 ) / 1000  )
    ChgVar     &PxSysAspUs ( %Bin( &SsRcvVar  53  4 ) / 10000 )
    ChgVar     &PxTotAuxSt ( %Bin( &SsRcvVar  57  4 ) / 1000  )

EndPgm:
    EndPgm

Thanks to Carsten Flensburg

RPGLE example: ** Parameter section for QWCRSSTS (Retrieve System Info) API D SysIRcv DS 80 D SysName 8A Overlay(SysIRcv:17) D SysILen S 10I 0 Inz(%Len(SysIRcv)) D SysIFormat S 8A Inz('SSTS0100') D SysIReset S 10A Inz('*YES') ** General error code structure for APIs D ErrorCode DS 16 D ByteIn 10I 0 Inz(%Len(ErrorCode)) D ByteRet 10I 0 D Qwcrssts PR ExtPgm('QWCRSSTS') D 80A D 10I 0 D 8A D 10A D 16A ***************************************************************** ** Obtain System Name * ***************************************************************** C CallP(E) Qwcrssts(SysIRcv:SysILen:SysIFormat: C SysIReset:ErrorCode) C If (Not %Error) And (ByteRet = 0) C SysName Dsply '*REQUESTER' C Endif C Eval *INLR = *ON C Return Thanks to Brian Parkins
Back

QLICOBJD

Change Object Description (Documentation)
D* Change Object Description (QLICOBJD) API D* D QLICOBJD PR EXTPGM('QLICOBJD') D QRTNLIB 10A CONST Returnd library name D QOBJNAM 20A CONST Object/library name D QOBJTYP 20A CONST Object type D QOBJCHG 100A OPTIONS(*VARSIZE) CONST Changed object info D QUERR 200A OPTIONS(*VARSIZE) CONST D* D QJOBIN DS D QUSR 20A INZ('QZUSLJOB QTEMP ') user space name D QUNAM 10A OVERLAY(QUSR : 1) D QULIB 10A OVERLAY(QUSR : 11) D QFRM 8A INZ('JOBL0200') Format name D QJOB 26A INZ(' ') job name D QJNAM 10A OVERLAY(QJOB : 1) D QJUSR 10A OVERLAY(QJOB : 11) D QJNUM 6A OVERLAY(QJOB : 21) D QSTS 10A INZ('*ALL ') status of incl. jobs D QERR 200A INZ(' ') Error code D QJTYP 1A INZ('B') type of job D QFNUM 10I 0 INZ(6) number fields return D QFKEY 10I 0 INZ(0) DIM(10) list field keys D CHGHDR DS D QCNUM 10I 0 INZ(0) number of records D QCDAT 90A INZ(' ') fields to change D* D CHGVAR DS D CHGKEY 10I 0 INZ(0) Key D CHGLEN 10I 0 INZ(0) Length of data D CHGDAT 90A INZ(' ') Data D* D KEYOPTS DS D KEY01 10I 0 INZ(1) Source file D KEY02 10I 0 INZ(2) Src last chg dte/tim D KEY03 10I 0 INZ(3) Compiler D KEY04 10I 0 INZ(4) Object control level D KEY05 10I 0 INZ(5) Licensed program D KEY06 10I 0 INZ(6) Prog temp fix (PTF) D KEY07 10I 0 INZ(7) Auth prog analys rep D KEY08 10I 0 INZ(8) Allow change by prog D KEY09 10I 0 INZ(9) User-defined attr. D KEY10 10I 0 INZ(10) Text D KEY11 10I 0 INZ(11) Days used count D KEY12 10I 0 INZ(12) Prod. option load ID D KEY13 10I 0 INZ(13) Prod. option ID D KEY14 10I 0 INZ(14) Component ID D KEY15 10I 0 INZ(15) Last used date D KEY16 10I 0 INZ(16) Chg date/time stamp D KEY17 10I 0 INZ(17) Mbr. days used count D* D DATOPTS DS D DAT01 30A INZ(' ') File/Library/Member D DAT02 13A INZ(' ') CYYMMDDHHMMSS D DAT03 13A INZ(' ') name/VxRxMy D DAT04 8A INZ(' ') see documentation D DAT05 13A INZ(' ') prog name/Version D DAT06 7A INZ(' ') p-fix ID/prog chg ID D DAT07 6A INZ(' ') upper-alpha/5 dec. D DAT08 1A INZ(' ') value of '0' or '1' D DAT09 10A INZ(' ') not extended attr. D DAT10 50A INZ(' ') Text Description D DAT11 1A INZ(' ') value of '0' or '1' D DAT12 4A INZ(' ') see documentation D DAT13 4A INZ(' ') see documentation D DAT14 4A INZ(' ') see documentation D DAT15 1A INZ(' ') value of '0' or '1' D DAT16 1A INZ(' ') value of '0' or '1' D DAT17 10A INZ(' ') file-member name D* D DS D TODAT 10D D TOMM 2A OVERLAY(TODAT : 6) D TODD 2A OVERLAY(TODAT : 9) D TOCC 2A OVERLAY(TODAT : 1) D TOYY 2A OVERLAY(TODAT : 3) /Free EVAL TODAT = %DATE(); EVAL QCNUM = 1; EVAL CHGKEY = 10; Text EVAL CHGLEN = 10; EVAL CHGDAT = TOMM + '/' + TODD; EVAL QCDAT = CHGVAR; EVAL QUNAM = NEWOBJ; EVAL QULIB = 'RMCDTA'; CALLP QLICOBJD (QULIB : QUSR : QSTS : CHGHDR : QERR); /End-Free Thanks to Joe M. Wesson
Back

QMHRTVM

dGetMsg           pr                  extpgm('QMHRTVM')
d Receiver                       1
d SizRcv                        10i 0 const
d Format                         8    const
d MsgID                          7    const
d Msgf                          20    const
d RplData                        1    const
d SizRplDta                     10i 0 const
d RplSubVal                     10    const
d RtnCtls                       10    const
d ErrCod                        10i 0 const
dGetSize          ds
d GetBytRtn                     10i 0
d GetBytAvl                     10i 0
dFmt0400          ds                  based(FmtPtr)
d BytRtn                        10i 0
d BytAvl                        10i 0
d MaxRpyLen             117    120i 0
d OffVldRpy             125    128i 0
d NbrVldRpyR            129    132i 0
d LenVldRpyR            133    136i 0
d LenVldRpyA            137    140i 0
d LenVldRpyE            141    144i 0
dVldRpyE          s             32    based(VldRpyPtr)
c     *entry        plist
c                   parm                    MsgID             7
c* How much storage is needed for everything?
c                   callp     GetMsg( GetSize       :%size(GetSize)
c                                    :'RTVM0400'    :MsgID
c                                    :'QCPFMSG   QSYS      '
c                                    :' '           :0
c                                    :'*NO'         :'*NO'
c                                    :0)
c* Allocate it and then call the API again
c                   eval      FmtPtr = %alloc(GetBytAvl)
c                   callp     GetMsg( Fmt0400       :GetBytAvl
c                                    :'RTVM0400'    :MsgID
c                                    :'QCPFMSG   QSYS      '
c                                    :' '           :0
c                                    :'*NO'         :'*NO'
c                                    :0)
c* If any valid replies returned display them
c                   if        NbrVldRpyR > 0
c                   eval      VldRpyPtr = FmtPtr + OffVldRpy
c                   do        NbrVldRpyR
c     VldRpyE       dsply
c                   eval      VldRpyPtr = VldRpyPtr + LenVldRpyE
c                   enddo
c                   endif
c                   eval      *inlr = '1'
c                   return

Thanks to Bruce Vining
Back

QECEDT

Edit Code API (link).

Back

QECCVTEC

Edit Mask API (link).

Back

QSPGETF

Copy Spooled File to Database File (link).

Back

QSPPUTF

Create Spooled File from Database File (link).

Back

QUSPTRUS

Retrieve Pointer to User Space (link).

Back

QWCLASBS

List Active Subsystems (link).

Back

QSDRSBSD

Retrieve Subsystem Info (link).

Back

QWDLSBSE

List Subsystem Entries (link).

Back

QMHRCVPM

	 * System API error code
	D Qusec           DS
	D  QusBPrv                1      4B 0
	D  QusBAvl                5      8B 0
	D  Qusei                  9     15
	D  Quserved              16     16

	 * Type definition for the RCVM0200 format
	D RCVM0200        DS           120
	D  Program              111    120

	 *Program message parameters
	D Pm_MsgId        S              7    Inz(*Blanks)
	D Pm_MsgF         S             20    Inz(*Blanks)
	D Pm_MsgDta       S             12    Inz('Who are you')
	D Pm_Length       S              9B 0
	D Pm_MType        S             10    Inz('*INFO')
	D Pm_MKey         S              4    Inz(*Blanks)
	D Pm_CSEntry      S             10    Inz('*')
	D Pm_Counter      S              9B 0 Inz(4)
	D Pm_Format       S              8    Inz('RCVM0200')
	D Pm_Wait         S              9B 0 Inz(0)
	D Pm_Action       S             10    Inz('*REMOVE')

	C     *Entry        Plist
	C                   Parm                    Caller           10

	 * Set error code structure not to use exceptions
	C                   Z-add     16            QusBPrv

	 * Set length of message data
	C                   Z-add     12            Pm_Length

	 * Send program message
	C                   Call      'QMHSNDPM'
	C                   Parm                    Pm_MsgId
	C                   Parm                    Pm_MsgF
	C                   Parm                    Pm_MsgDta
	C                   Parm                    Pm_Length
	C                   Parm                    Pm_MType
	C                   Parm                    Pm_CSEntry
	C                   Parm                    Pm_Counter
	C                   Parm                    Pm_MKey
	C                   Parm                    Qusec

	 * Check for errors
	C                   If        QusBAvl > 0
	C                   ExSR      *PSSR
	C                   EndIF

	 * Clear return data astructure
	C                   Clear                   RCVM0200

	 * Set Length of message information
	C                   Z-add     120           Pm_Length

	 * Recieve program message
	C                   Call      'QMHRCVPM'
	C                   Parm                    RCVM0200
	C                   Parm                    Pm_Length
	C                   Parm                    Pm_Format
	C                   Parm                    Pm_CSEntry
	C                   Parm                    Pm_Counter
	C                   Parm                    Pm_MType
	C                   Parm                    Pm_MKey
	C                   Parm                    Pm_Wait
	C                   Parm                    Pm_Action
	C                   Parm                    Qusec

	 * Check for errors
	C                   If        QusBAvl > 0
	C                   ExSR      *PSSR
	C                   EndIF
	C                   Move      Program       Caller
	C                   Return

	C     *PSSR         BegSR
	C                   Return
	C                   EndSR

Back

QMHSNDPM

	 * The prototype:
	D SndPgmMsg       pr                  extpgm('QMHSNDPM')
	D  MsgID                         7a   Const
	D  MsgFName                     20a   Const
	D  MsgDta                    32767a   Const Options(*Varsize)
	D  MsgDtaLength                  9b 0 Const
	D  MsgType                      10a   Const
	D  CallStackE                   10a   Const Options(*Varsize)
	D  CallStackC                    9b 0 Const
	D  MsgKey                        4a
	D  Error                     32767a         Options(*Varsize)
	 *  Optional Parameter Group 1
	D  CallStackEL                   9b 0 Const Options(*Nopass)
	D  CallStackEQ                  20a   Const Options(*Nopass)
	D  DspPgmMsgWait                 9b 0 Const Options(*Nopass)
	 *  Optional Parameter Group 2
	D  CallStackEDT                 10a   Const Options(*Nopass)
	D  MsgCCSID                      9b 0 Const Options(*Nopass)

	 * Procedure for sending:
	P SndMsgErr       b                   export
	D*
	D SndMsgErr       pi
	D  MsgID                         7a   Const
	D* PgmMsgQ                      10a   Const
	D  MsgDta                    32767a   Const Options(*Varsize : *Nopass)
	D  MsgDtaLen                     9b 0 Const Options(*Nopass)
	D*
	D  PgmMsgDta      s                   like(MsgDta)
	D  PgmDtaLen      s                   like(MsgDtaLen)
	D  MsgKeyA        s              4a
	D* PgmCllStck     s             10a   inz('*')
	D  PgmCllStck     s             10a   inz(*blanks)
	D  PgmCllStckC    s              9b 0 inz(0)
	D  CallStackEL    s              9b 0 inz(10)
	D  CallStackEQ    s             20a   inz('*NONE')
	D  DspPgmMsgWait  s              9b 0 inz(*zeros)
	D  CallStackEDT   s             10a   inz('*CHAR')
	D  MsgCCSID       s              9b 0 inz(0)
	 *
	C                   reset                   errc0100
	 *	This contains the name of program invoking the Procedure
	C                   eval      PgmCllStck = ZZPgmofProc
	 *  This is used when defining the PGMMSGQ for DSPF
	C                   if        %parms = 1
	C                   eval      PgmMsgDta = *blanks
	C                   eval      PgmDtaLen = *zeros
	C                   else
	C                   eval      PgmMsgDta = MsgDta
	C                   eval      PgmDtaLen = MsgDtaLen
	C                   endif
	C                   callp     SndPgmMsg(MsgId:
	 * Named constant, can be replaced
	C                                       DwhMsg:
	C                                       PgmMsgDta:
	C                                       PgmDtaLen:
	C                                       msgtypinfo:
	C                                       PgmCllStck:
	C                                       PgmCllStckC:
	C                                       MsgKeyA:
	C                                       errc0100)
	C                   return
	P SndMsgErr       e

	 *The System Data Structure;
	Dpsds            sds
	D ZZProcName                    10a
	D ZZStatus                       5s 0
	D ZZPrevSts                      5s 0
	D ZZSrcLneNbr                    8a
	D ZZRoutine                      8a
	D ZZParms                        3s 0
	D ZZExcType                      3a
	D ZZExcNbr                       4a
	D ZZReserve1                     4a
	D ZZMsgWrkAra                   30a
	D ZZPgmLib                      10a
	D ZZExcDta                      80a
	D ZZ9001ID                       4a
	D ZZLastFile1                   10a
	D ZZUnused1                      6a
	D ZZJobDate                      8a
	D ZZCentury                      2s 0
	D ZZLastFile2                    8a
	D ZZFileSts                     35a
	D ZZJobName                     10a
	D ZZUserID                      10a
	D ZZJobNbr                       6s 0
	D ZZJobRunDte                    6s 0
	D ZZSysDate                      6s 0
	D ZZSysTime                      6s 0
	D ZZCompDate                     6
	D ZZCompTime                     6
	D ZZCompLvl                      4a
	D ZZSrcFileName                 10a
	D ZZSrcFileLib                  10a
	D ZZSrcFileMbr                  10a
	D ZZPgmOfProc                   10a
	D ZZModOfProc                   10a
	D ZZSid2128                      2s 0
	D ZZSid228235                    2s 0
	D ZZCurrentUser                 10a
	D ZZUnused2                     62a

In the program which wants to send a message, a simple CALLP works as
	C               callp   SndMsgErr('CPF9898':MsgDta:%size(MsgDta))

Thanks to John C. Boblitz Jr.
Back

QSNRTVMOD

Retrieve Screen Size Mode (link).

Back

QCDRCMDD

Here's a sample program you can place in debug and have a look at the API output:


     **-- API Error Data Structure:  -----------------------------------------**
     D ApiError        Ds
     D  AeBytPro                     10i 0 Inz(%Size(ApiError))
     D  AeBytAvl                     10i 0
     D                                1a
     D  AeExcpId                      7a
     D  AeExcpDta                   126a
     **-- Global variables:  -------------------------------------------------**
     D OutStrLenRt     s             10i 0
     D NotSup          s             10i 0
     D FB              s             10i 0 Dim( 3 )
     **-- Command return variable:  ------------------------------------------**
     D CdCmdd0100      Ds
     D  CdBytRtn                     10i 0
     D  CdBytAvl                     10i 0
     D  CdCmdXml                  10240a
     **-- Retrieve Command Text:  --------------------------------------------**
     D RtvCmdTxt       Pr                  ExtPgm( 'QCDRCMDD' )
     D  RcCmdNamQ                    20a   Const
     D  RcDst                        10i 0 Const
     D  RcDstFmt                      8a   Const
     D  RcRcvVar                  32767a         Options( *VarSize )
     D  RcRcvFmt                      8a   Const
     D  RcError                   32767a         Options( *VarSize )
     **-- Convert String: ----------------------------------------------------**
     D CvtString       Pr                  ExtPgm( 'QTQCVRT' )
     D  CsInpCcsId                   10i 0 Const
     D  CsInpStrTyp                  10i 0 Const
     D  CsInpStr                  32767a   Const Options( *VarSize )
     D  CsInpStrSiz                  10i 0 Const
     D  CsOutCcsId                   10i 0 Const
     D  CsOutStrTyp                  10i 0 Const
     D  CsOutCvtAlt                  10i 0 Const
     D  CsOutStrSiz                  10i 0 Const
     D  CsOutStr                  32767a         Options( *VarSize )
     D  CsOutStrLenRt                10i 0
     D  CsNotSup                     10i 0
     D  CsFB                         10i 0 Dim( 3 )
     **
     **-- Mainline:  ---------------------------------------------------------**
     **
     C                   CallP     RtvCmdTxt( 'WRKJOB    QSYS      '
     C                                      : %Size( CdCmdd0100 )
     C                                      : 'DEST0100'
     C                                      : CdCmdd0100
     C                                      : 'CMDD0100'
     C                                      : ApiError
     C                                      )
     **
     C                   CallP     CvtString( 1208
     C                                      : 0
     C                                      : CdCmdXml
     C                                      : CdBytRtn
     C                                      : 37
     C                                      : 0
     C                                      : 0
     C                                      : CdBytRtn
     C                                      : CdCmdXml
     C                                      : OutStrLenRt
     C                                      : NotSup
     C                                      : FB
     C                                      )
     **
     C                   Return

Thanks to Carsten Flensburg
Back

QtocLstNetCnn

Retrieve TCP/IP connection status:


      * CRTRPGMOD MODULE(NETSTATR) SRCFILE(xxx/QRPGLESRC) SRCMBR(NETSTATR)
      * CRTPGM PGM(NETSTATR) BNDSRVPGM(QTOCNETSTS)
      *
     H DEBUG  OPTION(*SRCSTMT:*NODEBUGIO) BNDDIR('QC2LE')

     FQSYSPRT   O    F  198        Printer USROPN

     D uSpaceName      s             20    inz('NETSTAT   QTEMP     ')

     D cmdStr1         s            256    inz('OVRPRTF FILE(QSYSPRT) PAGESIZE(-
     D                                         *N 198) CPI(15) OVRSCOPE(*JOB)')
     D cmdStr2         s            256    inz('DLTOVR FILE(QSYSPRT) LVL(*JOB)')

      *----------------------------------------------------------------
      * Get user space list info from header section.
      *----------------------------------------------------------------
     D                 ds                  based(uHeadPtr)
     D uOffSetToList         125    128i 0
     D uNumOfEntrys          133    136i 0
     D uSizeOfEntry          137    140i 0
      *
     D uListEntry1     ds                  Based(uListPtr )
     D rmtAdr                        15    overlay(uListEntry1:1)
     D Reservedr                      1    overlay(uListEntry1:16)
     D rmtadrb                       10i 0 overlay(uListEntry1:17)
     D lclAdr                        15    overlay(uListEntry1:21)
     D Reserved1                      1    overlay(uListEntry1:36)
     D lcladrb                       10i 0 overlay(uListEntry1:37)
     D rmtPort                       10i 0 overlay(uListEntry1:41)
     D lclPort                       10i 0 overlay(uListEntry1:45)
     D tcpipState                    10i 0 overlay(uListEntry1:49)
     D idletime                      10i 0 overlay(uListEntry1:53)
     D byteIn                        20i 0 overlay(uListEntry1:57)
     D byteOut                       20i 0 overlay(uListEntry1:65)
     D cnnOpenType                   10i 0 overlay(uListEntry1:73)
     D netCnnType                    10a   overlay(uListEntry1:77)
     D Reserved2                      1a   overlay(uListEntry1:87)
      *----------------------------------------------------------------
      * Error return code parm for APIs.
      *----------------------------------------------------------------
     D vApiErrDs       ds
     D  vbytpv                       10i 0 inz(%size(vApiErrDs))
     D  vbytav                       10i 0 inz(0)
     D  vmsgid                        7a
     D  vresvd                        1a
     D  vrpldta                      50a
      *----------------------------------------------------------------
      * NetCnn  selection data structure.
      *----------------------------------------------------------------
     D CnnSelectDS     ds
     D  netCnnTyp...
     D                               10    inz('*ALL')  overlay(CnnSelectDS:1)
     D  lstRqsTyp...
     D                               10    inz('*ALL')  overlay(CnnSelectDS:11)
     D  lstReserved...
     D                               12    overlay(CnnSelectDS:21)
     D  lclAdrLowVal...
     D                               10i 0 inz(0) overlay(CnnSelectDS:33)
     D  lclAdrUpVal...
     D                               10i 0 inz(0) overlay(CnnSelectDS:37)
     D  lclPortLowVal...
     D                               10i 0 inz(0) overlay(CnnSelectDS:41)
     D  lclPortUpVal...
     D                               10i 0 inz(0) overlay(CnnSelectDS:45)
     D  rmtAdrLowVal...
     D                               10i 0 inz(0) overlay(CnnSelectDS:49)
     D  rmtAdrUpVal...
     D                               10i 0 inz(0) overlay(CnnSelectDS:53)
     D  rmtPortLowVal...
     D                               10i 0 inz(0) overlay(CnnSelectDS:57)
     D  rmtPortUpVal...
     D                               10i 0 inz(0) overlay(CnnSelectDS:61)
      *----------------------------------------------------------------
      * Create Prototypes for calls
      *----------------------------------------------------------------
      **-- Create user space: -----------------------------------------
     D quscrtus        PR                  ExtPgm('QUSCRTUS')
     D                               20
     D                               10    const
     D                               10i 0 const
     D                                1    const
     D                               10    const
     D                               50    const
     D                               10    const
     Db                                    like(vApiErrDS)
     **-- Delete user space: ------------------------------------------
     D qusdltus        Pr                  ExtPgm( 'QUSDLTUS' )
     D                               20    Const
     Db                                    like(vApiErrDS)
      **-- Call system command: ---------------------------------------
     D system          PR            10I 0 extproc('system')
     D  i_cmd                          *   value options(*string)
      *
     D EXCP_MSGID      S              7A   import('_EXCP_MSGID')
      **-- List network connections: ----------------------------------
     D LstNetCnn       PR                  ExtProc('QtocLstNetCnn')
     D                               20
     D                                8    const
     Db                                    like(CnnSelectDs)
     D                               10i 0 const
     D                                8    const
     Db                                    like(vApiErrDS)
      **-- Retrieve pointer to user space: ----------------------------
     D qusptrus        PR                  ExtPgm('QUSPTRUS')
     D                               20
     D                                 *
     Db                                    like(vApiErrDS)

     D main            PR                  extpgm('NETSTATR')
     D main            PI
      *----------------------------------------------------------------
      * Create user space
     C                   callp     QUSCRTUS(
     C                             uSpaceName:
     C                             'TEST':
     C                             1500000:
     C                             x'00':
     C                             '*ALL':
     C                             'User Space JCR ':
     C                             '*NO':
     C                             vApiErrDs)
      * Get pointer to user space
     C                   callp     QUSPTRUS(
     C                             uSpaceName:
     C                             uHeadPtr:
     C                             vApiErrDs)
      * call api to load job log into user space.
     C                   callp     LstNetCnn(
     C                             uSpaceName:
     C                             'NCNN0100':
     C                             CnnSelectDS:
     C                             %len(CnnSelectDS):
     C                             'NCLQ0100':
     C                             vApiErrDs)
      * Process elements
      *
     C                   callp     system(cmdStr1)
     C                   open      QSYSPRT
     C                   eval      uListPtr  = uHeadPtr + uOffSetToList

     C                   except    Head

 1B  C                   do        uNumOfEntrys
     C                   exsr      cvtTxtSr
     C                   except    Out
     C                   eval      uListPtr  = uListPtr  + uSizeOfEntry
 1E  C                   enddo

     C                   close     QSYSPRT
     C                   callp     system(cmdStr2)
      * Delete user space
     C                   callp     qusdltus(
     C                             uSpaceName:
     C                             vApiErrDs)
      *
     C                   eval      *inlr = *on
     C                   return
     **-- Convert text : ----------------------------------------------
     C     cvtTxtSr      BegSr
     C                   move      *blanks       tcpipStateC      13
     C                   select
     C                   when      tcpipState = 0
     C                   eval      tcpipStateC = 'Listen'
     C                   when      tcpipState = 1
     C                   eval      tcpipStateC = 'SYN-sent'
     C                   when      tcpipState = 2
     C                   eval      tcpipStateC = 'SYN-receievd'
     C                   when      tcpipState = 3
     C                   eval      tcpipStateC = 'Established'
     C                   when      tcpipState = 4
     C                   eval      tcpipStateC = 'FIN-wait-1'
     C                   when      tcpipState = 5
     C                   eval      tcpipStateC = 'FIN-wait-2'
     C                   when      tcpipState = 6
     C                   eval      tcpipStateC = 'Close-wait'
     C                   when      tcpipState = 7
     C                   eval      tcpipStateC = 'Closing'
     C                   when      tcpipState = 8
     C                   eval      tcpipStateC = 'Last-ACK'
     C                   when      tcpipState = 9
     C                   eval      tcpipStateC = 'Time-wait'
     C                   when      tcpipState = 10
     C                   eval      tcpipStateC = 'Closed'
     C                   when      tcpipState = 11
     C                   eval      tcpipStateC = 'Not Supported'
     C                   endsl

     C                   move      *blanks       cnnOpenTypeC      7
     C                   select
     C                   when      cnnOpenType = 0
     C                   eval      cnnOpenTypeC = 'Passive'
     C                   when      cnnOpenType = 1
     C                   eval      cnnOpenTypeC = 'Active'
     C                   when      cnnOpenType = 2
     C                   eval      cnnOpenTypeC = '      '
     C                   endsl
     C                   EndSr

     OQSYSPRT   E            HEAD           1
     O                                           14 'Remote Address'
     O                                           26 'Remote Port'
     O                                           41 'Local Address'
     O                                           54 'Local Port'
     O                                           61 'State'
     O                                           76 'OpnTyp'
     O                                           84 'CnnTyp'
     O                                          109 'Byte In'
     O                                          131 'Byte Out'
     O          E            OUT            1
     O                       rmtAdr
     O                       rmtPort       L  +   1
     O                       lclAdr           +   1
     O                       lclPort       L  +   1
     O                       tcpipStateC      +   1
     O                       cnnOpenTypeC     +   1
     O                       netCnnType       +   1
     O                       byteIn        L  +   1
     O                       byteOut       L  +   1

Thanks to Vengoal Chang
Back

QWVRCSTK

Retrieve Call Stack:


	D GetCaller       PR                  Extpgm('QWVRCSTK')
	D                             2000
	D                               10I 0
	D                                8    CONST
	D                               56
	D                                8    CONST
	D                               15

	D Var             DS          2000
	D  BytAvl                       10I 0
	D  BytRtn                       10I 0
	D  Entries                      10I 0
	D  Offset                       10I 0
	D  EntryCount                   10I 0
	D VarLen          S             10I 0 Inz(%size(Var))
	D ApiErr          S             15

	D JobIdInf        DS
	D  JIDQName                     26    Inz('*')
	D  JIDIntID                     16
	D  JIDRes3                       2    Inz(*loval)
	D  JIDThreadInd                 10I 0 Inz(1)
	D  JIDThread                     8    Inz(*loval)

	D Entry           DS           256
	D  EntryLen                     10I 0
	D  PgmNam                       10    Overlay(Entry:25)
	D  PgmLib                       10    Overlay(Entry:35)
	D
	C                   CallP     GetCaller(Var:VarLen:'CSTK0100':JobIdInf
	C                             :'JIDF0100':ApiErr)
	C                   Do        EntryCount
	C                   Eval      Entry = %subst(Var:Offset + 1)
	C                   Eval      Offset = Offset + EntryLen
	C                   Enddo
	C                   Eval      *InLR = *on

Thanks to Peter Connell
Back

QLZARTV

Retrieve Processor Tier Group


Pgm
   Dcl        Var(&Result ) Type(*Char) Len(64)
   Dcl        Var(&RstLen ) Type(*Char) Len(4 )
   Dcl        Var(&Format ) Type(*Char) Len(8 ) Value('PRDR0100')
   Dcl        Var(&OSInfo ) Type(*Char) Len(27) Value('*OPSYS *CUR  0000*CODE     ')
   Dcl        Var(&ErrCde ) Type(*Char) Len(4 )
   Dcl        Var(&Rcvr   ) Type(*Char) Len(64)
   Dcl        Var(&RcvrLen) Type(*Char) Len(4 ) Value(X'00000040')
   Dcl        Var(&RcvrFmt) Type(*Char) Len(8 ) Value('LICR0200')
   Dcl        Var(&PrdID  ) Type(*Char) Len(17) Value('             5050')
   Dcl        Var(&PrdFmt ) Type(*Char) Len(8 ) Value('LICP0100')
   Dcl        Var(&EC     ) Type(*Char) Len(4 ) Value(X'00000000')
   Dcl        Var(&PrcGrp ) Type(*Char) Len(64)

   ChgVar     Var(%bin(&RstLen 1 4)) Value(64       )
   ChgVar     Var(%bin(&ErrCde 1 4)) Value(0        )

   Call       Pgm(QSys/QSZRtvPr) Parm(&Result &RstLen &Format &OSInfo &ErrCde)

   ChgVar     Var(%sst(&PrdID 1 13))  Value(%sst(&Result 13 13))

   Call       Pgm(QSys/QLZARtv) Parm(&Rcvr &RcvrLen &RcvrFmt &PrdID &PrdFmt &EC)

   ChgVar     Var(&PrcGrp    )  Value(%sst(&Rcvr 48 3))

   SndPgmMsg  MsgID(CPF9898) MsgF(QCPFMsg) MsgDta('Processor group is' *bcat
                     &PrcGrp) MsgType(*Comp  )
EndPgm

Thanks to Kevin Wright & Todd Kidwell
Back

Page #2

Back