#1 |
API - Table of Contents |
#3 |
|
|
Open List of ASPs
(not sure if QYASPOL is working as is, because of the '4B 0' vs '10I 0').
D QYASPOL PR ExtPgm('QYASPOL')
D PR_Rcvr 64
D PR_RcvLen 10I 0
D PR_LstInfo 80
D PR_NbrRcds 10I 0
D PR_NbrFltr 10I 0
D PR_FltrInf 13
D PR_FmtCode 8
D PR_Code 116
D AS_FltrInf DS 13
D AS_FltSize 1 4B 0 Inz(9)
D AS_FltKey 5 8B 0 Inz(1)
D AS_SzFltD 9 12B 0 Inz(1)
D AS_FltDta 13 13 Inz('1')
D AS_RcvLen s 10I 0 Inz(64)
D AS_LstInfo s 80
D AS_NbrRcds s 10I 0 Inz(1)
D AS_NbrFltr s 10I 0 Inz(1)
D AS_FmtCode s 8 Inz('YASP0200')
DAS_RCVR DS 64 YASP0200
D QYAUMBER00 1 4B 0
D QYADISKS 5 8B 0 Disks
D QYATOTAL 9 12B 0 Total
D QYAAVAIL 13 16B 0 Avail
D QYAPT 17 20B 0 Prot Total
D QYAPA 21 24B 0 Prot Avail
D QYAUT 25 28B 0 Unprot Total
D QYAUA 29 32B 0 Unprot Avail
D QYASS 33 36B 0 System Stg
D QYAOS 37 40B 0 Ovrflow Stg
D QYAEL 41 44B 0 Error Log
D QYAML 45 48B 0 Mach Log
D QYAMT 49 52B 0 Mach Trace
D QYAMSD 53 56B 0 M S Dump
D QYAOCODE 57 60B 0 Microcode
D QYASHOLD 61 64B 0 Threshold
D ER_Code ds
D ER_BytPrv 1 4b 0 Inz(116)
D ER_BytAvl 5 8b 0
D ER_MsgID 9 15
D ER_ErNbr 16 16
D ER_MsgDta 17 116
C CallP QYASPOL(AS_Rcvr :
C AS_RcvLen :
C AS_LstInfo:
C AS_NbrRcds:
C AS_NbrFltr:
C AS_FltrInf:
C AS_FmtCode:
C ER_Code )
C Eval *InLr = *On
Thanks to Chris Beck
I was trying to make a program using API QYASPOL.
I’ve found a nice source on your website.
But there is a small error in the source:
The ‘filter data’ should be binary instead of character (with effects on the sizes),
it should be like this:
D AS_FltrInf DS 16
D AS_FltSize 1 4B 0 Inz(16)
D AS_FltKey 5 8B 0 Inz(1)
D AS_SzFltD 9 12B 0 Inz(4)
D AS_FltDta 13 16B 0 Inz(1)
Thanks to Jan Wijnants
|
|
Back
Retrieve Job Lock
**-- Header specifications: --------------------------------**
H Option( *SrcStmt )
**-- 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
**-- Global variables: -------------------------------------**
D Idx 5i 0
**-- Job lock information: ---------------------------------**
D JBLK0100 Ds 65535
D JlBytAvl 10i 0
D JlBytRtn 10i 0
D JlNbrObjLck 10i 0
D JlOfsObjLck 10i 0
D JlNbrLckObjRt 10i 0
D JlLckObjEntLn 10i 0
**
D LckInf Ds Based( pLckInf )
D LiObjNam 10a
D LiObjLib 10a
D LiObjTyp 10a
D LiObjExtAtr 10a
D LiLckStt 10a
D 2a
D LiLckSts 10i 0
D LiMbrLcks 10i 0
D LiLckCnt 10i 0
D LiLckScp 1a
D 2a
D LiThrId 8a
**-- Job id: -----------------------------------------------**
D JlJobId Ds
D JiJobNam 10a Inz( '*' )
D JiUsrNam 10a
D JiJobNbr 6a
D JiIntJobId 16a Inz( *Blanks )
D 2a Inz( *Allx'00' )
D JlThrInd 10i 0 Inz( 2 )
D JlThrId 8a
**-- Retrieve job record locks: ----------------------------**
D RtvJobLck Pr ExtPgm( 'QWCRJBLK' )
D JlRcvVar 65535a Options( *VarSize )
D JlRcvVarLen 10i 0 Const
D JlFmtNam 8a Const
D JlJobId 56a Const
D JlFmtJobId 8a Const
D JlError 32767a Options( *VarSize )
**
**-- Mainline: ---------------------------------------------**
C CallP RtvJobLck( JBLK0100
C : %Size( JBLK0100 )
C : 'JBLK0100'
C : JlJobId
C : 'JIDF0100'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C ExSr PrcJobLck
C EndIf
**
C Return
**
**-- Process job locks: ------------------------------------**
C PrcJobLck BegSr
**
C Eval pLckInf = %Addr( JBLK0100 ) +
C JlOfsObjLck
**
C For Idx = 1 to JlNbrLckObjRt
**
**-- Do whatever...
**
C If Idx < JlNbrLckObjRt
C Eval pLckInf = pLckInf + JlLckObjEntLn
C EndIf
C EndFor
**
C EndSr
Dennis Lovelady wrote:
Thanks for sharing that code, Carsten. Yeah, that looks useful in the
right places. :)
Not to fault your code (which, again, I do appreciate!), I'm curious why
you don't use QSYSINC items for some of that stuff (like QUSEC, for example).
If it's because of variable data being left undefined (such as QUSED01), you
might find the following useful:
* PLEASE keep the next two lines TOGETHER!!!
D/Copy qsysinc/qrpglesrc,qusec
D QUSED01 1024
* PLEASE keep the previous two lines TOGETHER!!!
Carsten Flensburg replied:
Well, it's partly due to the circumstance that I started coding APIs before
QSYSINC became an option and thus invented my own set of naming standards -
and partly due to the fact that I've run into some problems actually using the
library because of errors in the header files.
I also just checked the include file for the QWCRJBLK API and though it was
introduced just recently - V5R1- it still uses positional definition of the
structure subfields and defines numeric subfields as Binary instead of Integer
data type... - I prefer using the more recent options in both cases.
On the other hand - as I'm confronted with more and more C code and style -
I really start liking the idea of a general header file set to ease both the
use of APIs and functions and the maintainance of a global coding standard.
Speaking of RPG/IV I just don't think that QSYSINC - in general - has the
adequate level of quality yet.
Thanks to Carsten Flensburg & Dennis Lovelady
|
|
Back
Retrieve Member Description
P SrcChanged B
D SrcChanged PI 13P 0
D peSrcFile 10A const
D peSrcLib 10A const
D peSrcMbr 10A const
D dsEC DS
D dsECBytesP 1 4I 0 Inz(256)
D dsECBytesA 5 8I 0 Inz(0)
D dsECMsgID 9 15
D dsECReserv 16 16
D dsECMsgDta 17 256
D RtvMbrD PR ExtPgm('QUSRMBRD')
D RcvVar 1A
D RcvVarLen 10I 0 Const
D Format 8A Const
D QualDBF 20A Const
D Member 10A Const
D UseOvrDbf 1A Const
D ErrorCode 1A
D dsSM ds
D dsSMBytRtn 10I 0
D dsSMBytAvl 10I 0
D dsSMFilNam 10A
D dsSMFilLib 10A
D dsSMFilMbr 10A
D dsSMFilAtr 10A
D dsSMSrcTyp 10A
D dsSMCrtDat 13A
D dsSMChgDat 13A
D dsSMText 50A
D dsSMSrcFil 1A
D wkReturn s 13P 0
C callp RtvMbrD(dsSM: %size(dsSM):
C 'MBRD0100':
C (peSrcFile+peSrcLib):
C peSrcMbr: '0': dsEC)
c if dsECBytesA>0
c return -1
c endif
c testn dsSMChgDat 99
c if *in99 = *off
c return -2
c endif
c move dsSMChgDat wkReturn
c return wkReturn
P E
Thanks to Scott Klement
|
|
Back
Retrieve CPU Information
H BNDDIR('QC2LE') DFTACTGRP(*NO) ACTGRP(*CALLER)
DsndMsg pr
D msgText 80 const
D matmatr PR EXTPROC('matmatr')
D attributes * VALUE
D attrLen 5I 0 VALUE
D machineAttributes...
D DS INZ
D MMTR_Template_Size...
D 10I 0
D MMTR_Bytes_Used...
D 10I 0
D MMTR_VPD 4096
D VPDOffsets DS INZ
D vRes1 8
D vMemOff 10i 0
D vPrcOff 10i 0
D vColOff 10i 0
D vCecOff 10i 0
D vPnlOff 10i 0
D vRes2 12
D vMemInstalled 5i 0
D vMemRequired 5i 0
d cecVPD DS INZ
d cCEC_read 4
d cManufacturin 4
d creserved1 4
d cType 4
d cModel 4
d cPseudo_Model 4
d cGroup_Id 4
d creserved2 4
d cSys_Type_Ext 1
d cFeature_Code 4
d cSerial_No 10
d creserved3 1
d panelVPD DS INZ
d preserved1 2
d pPanel_Type 4
d pModel 3
d pPart 12
d preserved2 4
d pManufacturin 4
d pROS_Part 12
d pROS_Card 10
d pROS_ID 1
d pROS_Flag 1
d pROS_Fix 1
d pSerial_No 10
D $MMTR_SERIAL_ S 5I 0 INZ(4)
D $MMTR_VPD_ S 5i 0 INZ(x'012c')
D prErrStruc DS inz
D prErrSSize 10i 0 inz(%len(prErrStruc))
D PrErrSUse 10i 0
D prErrSmsgID 7
D prErrSResrv 1
D prErrSData 80
d prRcvr s 128
d prRcvrLen s 10i 0 inz(%size(prRcvr))
d prFormat s 8 inz('PRDR0100')
d prPrdInfo s 27 inz('*OPSYS *CUR 0000*CODE ')
d prErr s like(prErrStruc)
d prRelease s 6
C EVAL MMTR_Template_Size =
%SIZE(machineAttributes)
C CALLP matmatr( %ADDR(machineAttributes) :
C $MMTR_VPD_ )
c eval VPDOffsets = %subst(MMTR_VPD:
c 1:
c %len(VPDOffsets))
c eval cecVPD = %subst(MMTR_VPD:
c vCecOff-7:
c %len(cecVPD))
c eval panelVPD = %subst(MMTR_VPD:
c vPnlOff-7:
c %len(panelVPD))
C eval prErr = prErrStruc
c call 'QSZRTVPR'
c parm prRcvr
c parm prRcvrLen
c parm prFormat
c parm prPrdInfo
c parm prErr
C eval prErrStruc = prErr
C eval prRelease = %subst(prRcvr: 20: 6)
c callp sndMsg('Type ' + %trim(cType) +
c ' model ' + %trim(cModel) +
c ' prc grp ' + %trim(cGroup_ID) +
c ' fc ' + %trim(cFeature_Code)
+
c ' serial ' + %trim(cSerial_No) +
c ' ' + %trim(
c %editc(vMemInstalled:
c 'Z')) + ' meg' +
c ' rel ' + %trim(prRelease)
c )
C SETON LR
C RETURN
PsndMsg b
DsndMsg pi
D inpText 80 const
* Send message API parameters
D msgID s 7 inz('CPF9898')
D msgFil s 20 inz('QCPFMSG *LIBL ')
D msgData s like(inpText)
D msgDataLen s 10i 0 inz(%size(msgData))
D msgType s 10 inz('*INFO')
D msgStackEnt s 10 inz('*')
D msgStackCnt s 10i 0 inz(3)
D msgKey s 4
D msgErrStruc s like(ErrStruc)
* API error structure
D errStruc DS inz
D errSSize 10i 0 inz(%len(errStruc))
D errSUse 10i 0
D errSmsgID 7
D errSResrv 1
D errSData 80
C eval msgData = inpText
C eval msgErrStruc = errStruc
C Call 'QMHSNDPM'
C Parm msgID
C Parm msgFil
C Parm msgData
C Parm msgDataLen
C Parm msgType
C Parm msgStackEnt
C Parm msgStackCnt
C Parm msgKey
C Parm msgErrStruc
C Eval errStruc = msgErrStruc
PsndMsg e
Thanks to Buck Calabro
|
|
Back
Convert Date and Time Format
**--Specifications
H Option( *SrcStmt )
**-- Globalariables:
D DTS s 8a
D LongJul s 17a
D YYMD s 17a
**-- API error datatructure:
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0
D AeExcpId 7a
D 1a
D AaExcpDta 256a
**-- Convert date & time:
D CvtDtf Pr ExtPgm( 'QWCCVTDT' )
D CdInpFmt 10a Const
D CdInpVar 17a Const Options( *VarSize )
D CdOutFmt 10a Const Options( *VarSize )
D CdOutVar 17a Options( *VarSize )
D CdError 32767a Options( *VarSize )
**
C CallP CvtDtf( '*YYMD'
C : '20010919180055000'
C : '*DTS'
C : DTS
C : ApiError
C )
**
C CallP CvtDtf( '*DTS'
C : DTS
C : '*LONGJUL'
C : LongJul
C : ApiError
C )
**
C Return
Thanks to Carsten Flensburg
|
|
Back
List ILE Program Information and List ILE Service Program Information
H DFTACTGRP(*NO) OPTION(*SRCSTMT: *NODEBUGIO)
** This program will find all places that a bound module is called.
** (by searching all ILE programs in the user libraries)
**
** Scott Klement, May 7, 1997
**
FQSYSPRT O F 80 PRINTER OFLIND(*INOF)
D EC_Escape PR
D When 60A const
D CallStackCnt 10I 0 value
D ErrorCode 32766A options(*varsize)
* List ILE program information API
D QBNLPGMI PR ExtPgm('QBNLPGMI')
D UsrSpc 20A const
D Format 8A const
D PgmName 20A const
D Errors 32766A options(*varsize)
* List ILE service program information API
D QBNLSPGM PR ExtPgm('QBNLSPGM')
D UsrSpc 20A const
D Format 8A const
D SrvPgm 20A const
D Errors 32766A options(*varsize)
* Create User Space API
D QUSCRTUS 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 Errors 32766A options(*varsize)
* Retrieve pointer to user space API
D QUSPTRUS PR ExtPgm('QUSPTRUS')
D UsrSpc 20A const
D Pointer *
* API error code structure
D dsEC DS
D dsECBytesP 10I 0 inz(%size(dsEC))
D dsECBytesA 10I 0 inz(0)
D dsECMsgID 7A
D dsECReserv 1A
D dsECMsgDta 240A
* List API generic header structure
D p_Header S *
D dsLH DS BASED(p_Header)
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
* PGML0100 format: modules in program
* SPGL0100 format: modules in service program
* (these fields are the same in both APIs)
D p_Entry S *
D dsPgm DS based(p_Entry)
D dsPgm_Pgm 10A
D dsPgm_PgmLib 10A
D dsPgm_Module 10A
D dsPgm_ModLib 10A
D dsPgm_SrcF 10A
D dsPgm_SrcLib 10A
D dsPgm_SrcMbr 10A
D dsPgm_Attrib 10A
D dsPgm_CrtDat 13A
D dsPgm_SrcDat 13A
D peModule S 10A
D Entry S 10I 0
c *entry plist
c parm peModule
c except PrtHeader
* Create a user space to stuff module info into
c callp QUSCRTUS('MODULES QTEMP': 'USRSPC':
c 1024*1024: x'00': '*ALL':
c 'List of modules': '*YES': dsEC)
c if dsECBytesA > 0
c callp EC_Escape('Calling QUSCRTUS API':3:dsEC)
c endif
c callp QUSPTRUS('MODULES QTEMP': p_Header)
* List all ILE programs modules to space
c callp QBNLPGMI('MODULES QTEMP': 'PGML0100':
c '*ALL *ALLUSR': dsEC)
c if dsECBytesA > 0
c callp EC_Escape('Calling QBNLPGMI API':3:dsEC)
c endif
* List occurrances of our module
c eval p_Entry = p_Header + dsLHLstOff
c for Entry = 1 to dsLHEntCnt
c if dsPgm_Module = peModule
c except PrtModule
c endif
c eval p_Entry = p_Entry + dsLHEntSiz
c endfor
* List all ILE service program modules to space
c callp QBNLSPGM('MODULES QTEMP': 'SPGL0100':
c '*ALL *ALLUSR': dsEC)
c if dsECBytesA > 0
c callp EC_Escape('Calling QBNLSPGM API':3:dsEC)
c endif
* List occurrances of our module
c eval p_Entry = p_Header + dsLHLstOff
c for Entry = 1 to dsLHEntCnt
c if dsPgm_Module = peModule
c except PrtModule
c endif
c eval p_Entry = p_Entry + dsLHEntSiz
c endfor
* And that's about the size of it
c eval *inlr = *on
OQSYSPRT E PrtHeader 2 3
O *DATE Y 10
O +3 'Listing of programs'
O +1 'that use module'
O peModule +1
O 75 'Page'
O PAGE Z 80
O E PrtModule 2 3
O dsPgm_Pgm 10
O dsPgm_PgmLib +1
O dsPgm_SrcF +1
O dsPgm_SrcLib +1
O dsPgm_SrcMbr +1
O dsPgm_SrcDat +1
* Send back an escape message based on an API error code DS
P EC_Escape B
D EC_Escape PI
D When 60A const
D CallStackCnt 10I 0 value
D ErrorCode 32766A options(*varsize)
* Send Program Message API
D QMHSNDPM PR ExtPgm('QMHSNDPM')
D MessageID 7A Const
D QualMsgF 20A Const
D MsgData 256A Const
D MsgDtaLen 10I 0 Const
D MsgType 10A Const
D CallStkEnt 10A Const
D CallStkCnt 10I 0 Const
D MessageKey 4A
D Errors 1A
* API error code (passed from caller)
D p_EC S *
D dsEC DS based(p_EC)
D dsECBytesP 10I 0
D dsECBytesA 10I 0
D dsECMsgID 7A
D dsECReserv 1A
D dsECMsgDta 240A
* API error code (no error handling requested)
D dsNullError DS
D dsNullError0 10I 0 inz(0)
D MsgDtaLen S 10I 0
D MsgKey S 4A
c eval p_EC = %addr(ErrorCode)
c if dsECBytesA <= 16
c eval MsgDtaLen = 0
c else
c eval MsgDtaLen = dsECBytesA - 16
c endif
C* diagnostic msg tells us when the error occurred in our pgm
c callp QMHSNDPM('CPF9897': 'QCPFMSG *LIBL':
c When: %Len(%trimr(when)): '*DIAG':
c '*': 1: MsgKey: dsNullError)
C* send back actual error from API
c callp QMHSNDPM(dsECMsgID: 'QCPFMSG *LIBL':
c dsECMsgDta: MsgDtaLen: '*ESCAPE':
c '*': CallStackCnt: MsgKey:
c dsNullError)
P E
Thanks to Scott Klement
|
|
Back
Q:
I want to get some job's call stack, but the QWVRCSTK API need the Thread
identifier in JIDF0100 Format. How do I get the job thread identifier ?
A:
Here's an example using the QWVRCSTK API without a specific thread identifier:
The open job list API locates the most CPU consuming jobs on a system and
subsequently retrieves the program currently running in that job:
** Open list APIs are located in library QGY.
**
**-- Control spec:
H Option( *SrcStmt: *NoDebugIo ) 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
**-- API parameters:
D JlRtnRcdNbr s 10i 0 Inz( 1 )
D JlNbrFldRtn s 10i 0 Inz( %Elem( JlKeyFld ))
D JlKeyFld s 10i 0 Dim( 3 )
**-- Job information:
D JlJobInf Ds 512
D JbJobId 26a
D JbJobUsd 10a Overlay( JbJobId: 1 )
D JbUsrUsd 10a Overlay( JbJobId: *Next )
D JbNbrUsd 6a Overlay( JbJobId: *Next )
D JbActSts 4a
D JbJobTyp 1a
D JbJobSubTyp 1a
D JbDtaLen 10i 0
D 4a
**-- Key information:
D JlKeyInf Ds
D KiFldNbrRtn 10i 0
D KiKeyInf 20a Dim( %Elem( JlKeyFld ))
D KiFldInfLen 10i 0 Overlay( KiKeyInf : 1 )
D KiKeyFld 10i 0 Overlay( KiKeyInf : 5 )
D KiDtaTyp 1a Overlay( KiKeyInf : 9 )
D 3a Overlay( KiKeyInf : 10 )
D KiDtaLen 10i 0 Overlay( KiKeyInf : 13 )
D KiDtaOfs 10i 0 Overlay( KiKeyInf : 17 )
**-- Sort information:
D JlSrtInf Ds
D SiNbrKeys 10i 0 Inz( 1 )
D SiSrtInf 12a Dim( 10 )
D SiKeyFldOfs 10i 0 Overlay( SiSrtInf : 1 )
D SiKeyFldLen 10i 0 Overlay( SiSrtInf : 5 )
D SiKeyFldTyp 5i 0 Overlay( SiSrtInf : 9 )
D SiSrtOrd 1a Overlay( SiSrtInf : 11 )
D SiRsv 1a Overlay( SiSrtInf : 12 )
**-- List information:
D JlLstInf Ds
D LiRcdNbrTot 10i 0
D LiRcdNbrRtn 10i 0
D LiHandle 4a
D LiRcdLen 10i 0
D LiInfSts 1a
D LiDts 13a
D LiLstSts 1a
D 1a
D LiInfLen 10i 0
D LiRcd1 10i 0
D 40a
**-- Selection information:
D JlSltInf Ds
D SiJobNam 10a Inz( '*ALL' )
D SiUsrNam 10a Inz( '*ALL' )
D SiJobNbr 6a Inz( '*ALL' )
D SiJobTyp 1a Inz( '*' )
D 1a
D SiOfsPriSts 10i 0 Inz( 60 )
D SiNbrPriSts 10i 0 Inz( 0 )
D SiOfsActSts 10i 0 Inz( 70 )
D SiNbrActSts 10i 0 Inz( 0 )
D SiOfsJbqSts 10i 0 Inz( 78 )
D SiNbrJbqSts 10i 0 Inz( 0 )
D SiOfsJbqNam 10i 0 Inz( 88 )
D SiNbrJbqNam 10i 0 Inz( 0 )
**
D SiPriSts 10a Dim( 1 )
D SiActSts 4a Dim( 2 )
D SiJbqSts 10a Dim( 1 )
D SiJbqNam 20a Dim( 1 )
**-- Job information key fields:
D JbKeyDta Ds
D JbPrcUniTim 20u 0
D JbPrcUniPct 10i 0
D JbPrcUniTimE 20u 0
**-- General return data:
D JlGenDta Ds
D GdBytRtn 10i 0
D GdBytAvl 10i 0
D GdElpTim 20u 0
D 16a
**-- Global variables:
D Ix s 5i 0
D Msg s 256a Varying
D MsgKey s 4a
D PgmNam_q s 20a
**-- API constants:
D JOB_RESET_STAT c '1'
D JOB_KEEP_STAT c '0'
**-- Open list of jobs:
D LstJobs Pr ExtPgm( 'QGYOLJOB' )
D LjRcvVar 65535a Options( *VarSize )
D LjRcvVarLen 10i 0 Const
D LjFmtNam 8a Const
D LjRcvVarDfn 65535a Options( *VarSize )
D LjRcvDfnLen 10i 0 Const
D LjLstInf 80a
D LjNbrRcdRtn 10i 0 Const
D LjSrtInf 1024a Const Options( *VarSize )
D LjJobSltInf 1024a Const Options( *VarSize )
D LjJobSltLen 10i 0 Const
D LjNbrFldRtn 10i 0 Const
D LjKeyFldRtn 10i 0 Const Options( *VarSize )
D Dim( 32 )
D LjError 1024a Options( *VarSize )
**
D LjJobSltFmt 8a Const Options( *NoPass )
**
D LjResStc 1a Const Options( *NoPass )
D LjGenRtnDta 32a Options( *NoPass:*VarSize)
D LjGenRtnDtaLn 10i 0 Const Options( *NoPass )
**-- Get list entry:
D GetLstEnt Pr ExtPgm( 'QGYGTLE' )
D GlRcvVar 65535a Options( *VarSize )
D GlRcvVarLen 10i 0 Const
D GlHandle 4a Const
D GlLstInf 80a
D GlNbrRcdRtn 10i 0 Const
D GlRtnRcdNbr 10i 0 Const
D GlError 1024a Options( *VarSize )
**-- Close list:
D CloseLst Pr ExtPgm( 'QGYCLST' )
D ClHandle 4a Const
D ClError 1024a Options( *VarSize )
**-- Copy memory:
D MemCpy Pr * ExtProc( '_MEMMOVE' )
D pOutMem * Value
D pInpMem * Value
D iMemSiz 10u 0 Value
**-- Delay job:
D sleep Pr 10i 0 ExtProc( 'sleep' )
D seconds 10u 0 Value
**-- Get job program:
D GetJobPgmX Pr 20a
D PxJobId 26a Const
**-- Mainline:
C* Eval SiNbrActSts = SiNbrActSts + 1
C* Eval SiActSts(SiNbrActSts) = 'HLD '
**
C Eval JlKeyFld(1) = 312
C Eval JlKeyFld(2) = 314
C Eval JlKeyFld(3) = 315
**
C Eval SiNbrKeys = 1
C Eval SiKeyFldOfs(1) = 49
C Eval SiKeyFldLen(1) = 4
C Eval SiKeyFldTyp(1) = 0
C Eval SiSrtOrd(1) = '2'
C Eval SiRsv(1) = x'00'
**
C CallP LstJobs( JlJobInf
C : %Size( JlJobInf )
C : 'OLJB0300'
C : JlKeyInf
C : %Size( JlKeyInf )
C : JlLstInf
C : 0
C : JlSrtInf
C : JlSltInf
C : %Size( JlSltInf )
C : JlNbrFldRtn
C : JlKeyFld
C : ApiError
C : 'OLJS0100'
C : JOB_RESET_STAT
C : JlGenDta
C : %Size( JlGenDta )
C )
**
C CallP sleep( 30 )
**
C CallP LstJobs( JlJobInf
C : %Size( JlJobInf )
C : 'OLJB0300'
C : JlKeyInf
C : %Size( JlKeyInf )
C : JlLstInf
C : 1
C : JlSrtInf
C : JlSltInf
C : %Size( JlSltInf )
C : JlNbrFldRtn
C : JlKeyFld
C : ApiError
C : 'OLJS0100'
C : JOB_KEEP_STAT
C : JlGenDta
C : %Size( JlGenDta )
C )
**
C If AeBytAvl = *Zero
**
C DoW LiLstSts <> '2' Or
C LiRcdNbrTot > JlRtnRcdNbr
**
C If JbJobTyp <> 'X'
C ExSr GetKeyDta
C ExSr GetJobPgm
C EndIf
**
C Eval JlRtnRcdNbr = JlRtnRcdNbr + 1
**
C CallP GetLstEnt( JlJobInf
C : %Size( JlJobInf )
C : LiHandle
C : JlLstInf
C : 1
C : JlRtnRcdNbr
C : ApiError
C )
**
C If JbPrcUniTimE <= *Zero
C Leave
C EndIf
**
C EndDo
**
C CallP CloseLst( LiHandle
C : ApiError
C )
**
C EndIf
**
C Eval *InLr = *On
**
C Return
**-- Get Key Field Data:
C GetKeyDta BegSr
**
C Clear JbKeyDta
**
C For Ix = 1 To KiFldNbrRtn
**
C Select
C When KiKeyFld(Ix)= 312
C CallP MemCpy( %Addr( JbPrcUniTim )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix)= 314
C CallP MemCpy( %Addr( JbPrcUniPct )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
**
C When KiKeyFld(Ix)= 315
C CallP MemCpy( %Addr( JbPrcUniTimE )
C : %Addr( JlJobInf ) +
C KiDtaOfs(Ix)
C : KiDtaLen(Ix)
C )
C EndSl
**
C EndFor
**
C EndSr
**-- Get job program:
C GetJobPgm BegSr
**
C Eval PgmNam_q = GetJobPgmX( JbJobId )
**
C EndSr
**-- Get job program:
P GetJobPgmX B Export
D Pi 20a
D PxJobId 26a Const
**-- 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
**-- Retrieve call stack API parameters:
D CsRcvVar Ds
D CsBytRtn 10i 0
D CsBytAvl 10i 0
D CsNbrStkE 10i 0
D CsOfsStkE 10i 0
D CsNbrEntRtn 10i 0
D CsThrId 8a
D CsInfSts 1a
D CsCalStk 32767a
**
D CsCalStkE Ds Based( pCalStkE )
D CsStkEntLen 10i 0
D CsOfsStmIds 10i 0
D CsNbrStmIds 10i 0
D CsOfsPrcNam 10i 0
D CsLenPrcNam 10i 0
D CsRqsLvl 10i 0
D CsPgmNam 10a
D CsPgmLib 10a
D CsMiInst 10i 0
D CsModNam 10a
D CsModLib 10a
D CsCtlBdy 1a
D CsRsv 3a
D CsActGrpNbr 10u 0
D CsActGrpNam 10a
D CsAddInf 4096a
**
D CsStmIds 10a Dim( 16 )
D CsPrcNam 512a
**
D CsJobId Ds
D JiJobId 26a
D JiJobNam 10a Overlay( JiJobId: 1 )
D JiUsrNam 10a Overlay( JiJobId: *Next )
D JiJobNbr 6a Overlay( JiJobId: *Next )
D JiIntId 16a
D JiRsv 2a Inz( *Allx'00' )
D JiThrInd 10i 0 Inz( 2 )
D JiThrId 8a Inz( *Allx'00' )
**
D RtvCalStk Pr ExtPgm( 'QWVRCSTK' )
D RcRcvVar 32767a
D RcRcvVarLen 10i 0 Const
D RcRcvInfFmt 8a Const
D RcJobId 56a Const
D RcJobIdFmt 8a Const
D RcError 32767a Options( *VarSize )
**
D EntNbr s 5u 0
**
**-- Mainline:
**
C Eval JiJobId = PxJobId
**
C CallP RtvCalStk( CsRcvVar
C : %Size( CsRcvVar )
C : 'CSTK0100'
C : CsJobId
C : 'JIDF0100'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C Eval pCalStkE = %Addr( CsRcvVar ) +
C CsOfsStkE
**
C For EntNbr = 1 to CsNbrEntRtn
**
C If EntNbr = 1
**
C Eval CsStmIds = *Blanks
C Eval CsPrcNam = *Blanks
**
C If CsOfsStmIds > *Zero
C CallP MemCpy( %Addr( CsStmIds )
C : %Addr( CsCalStkE ) +
C CsOfsStmIds
C : CsNbrStmIds * %Size( CsStmIds )
C )
C EndIf
**
C If CsOfsPrcNam > *Zero
C CallP MemCpy( %Addr( CsPrcNam )
C : %Addr( CsCalStkE ) +
C CsOfsPrcNam
C : CsLenPrcNam
C )
C EndIf
**
C Leave
C EndIf
**
C If EntNbr < CsNbrEntRtn
C Eval pCalStkE = PCalStkE + CsStkEntLen
C EndIf
**
C EndFor
C EndIf
**
C Return CsPgmNam + CsPgmLib
**
P GetJobPgmX E
Thanks to Carsten Flensburg
|
|
Back
Retrieve System Value
h dftactgrp(*no) actgrp('QILE') bnddir('QC2LE')
* Prototype for QWCRSVAL API - Retrieve QUSRLIBL
d QWCRSVALU pr ExtPgm('QWCRSVAL')
d p_Rcvr Like(u_Rcvr)
d p_RcvrLngth Like(u_RcvrLngth)
d p_NbrToRtv Like(u_NbrToRtv)
d p_SysVal Like(u_SysVal)
d p_Error Like(u_APIError)
* Prototype for QWCRSVAL API - Retrieve QSYSLIBL
d QWCRSVALS pr ExtPgm('QWCRSVAL')
d p_Rcvr Like(s_Rcvr)
d p_RcvrLngth Like(s_RcvrLngth)
d p_NbrToRtv Like(s_NbrToRtv)
d p_SysVal Like(s_SysVal)
d p_Error Like(s_APIError)
d #QUSRLIBL pr 250a
d #QSYSLIBL pr 150a
d ds
d UsrLibl 250
d SysLibl 150
d USRLIBLDS ds inz
d u_Rcvr 278a
d u_RcvrLngth 9b 0 inz(%len(u_Rcvr))
d u_NbrToRtv 9b 0 inz(1)
d u_SysVal 10a inz('QUSRLIBL')
d u_APIError 1
d SYSLIBLDS ds inz
d s_Rcvr 178a
d s_RcvrLngth 9b 0 inz(%len(s_Rcvr))
d s_NbrToRtv 9b 0 inz(1)
d s_SysVal 10a inz('QSYSLIBL')
d s_APIError 1
* Program Mainline
c/free
UsrLibl=#QUSRLIBL;
SysLibl=#QSYSLIBL;
*inlr=*on;
/end-free
* #QUSRLIBL - Retrieve the QUSRLIBL library list
p #QUSRLIBL b Export
d #QUSRLIBL pi 250a
d DS_SysValTbl ds inz
d d_ValsRtn 9b 0
d d_Offset 9b 0
d d_SysVal 10a
d d_ValType 1a
d d_InfoSts 1a
d d_DtaLngth 9b 0
d d_Data 250a
c/free
reset u_APIError;
qwcrsvalu(u_Rcvr: u_RcvrLngth: u_NbrToRtv: u_SysVal: u_APIError);
ds_SysValTbl = u_Rcvr;
return %subst(d_Data:1:d_DtaLngth);
/end-free
p #QUSRLIBL e
* #QSYSLIBL - Retrieve the QSYSLIBL library list
p #QSYSLIBL b Export
d #QSYSLIBL pi 150a
d DS_SysValTbl ds inz
d d_ValsRtn 9b 0
d d_Offset 9b 0
d d_SysVal 10a
d d_ValType 1a
d d_InfoSts 1a
d d_DtaLngth 9b 0
d d_Data 150a
c/free
reset s_APIError;
qwcrsvals(s_Rcvr: s_RcvrLngth: s_NbrToRtv: s_SysVal: s_APIError);
ds_SysValTbl = s_Rcvr;
return %subst(d_Data:1:d_DtaLngth);
/end-free
p #QSYSLIBL e
Thanks to Tom H.
And one more ...
D QWCRSVALD PR EXTPGM('QWCRSVAL')
D QRSYS LIKE(QRSYSD)
D QRLEN LIKE(QRLEND)
D QRNUM LIKE(QRNUMD)
D QRVAR LIKE(QRVARD)
D QRERR 200A OPTIONS(*VARSIZE) CONST
D*
D* system value reciver: date format
D QRTVFMTD DS
D QRSYSD 31A INZ(' ') Receiver variable
D QRLEND 10I 0 INZ(%len(QRSYSD)) Length recevr var
D QRNUMD 10I 0 INZ(1) Number of sys val
D QRVARD 10A INZ('QDATFMT') System value name
D*
D QFORMAT DS
D QNBR 10I 0 INZ(0) Number of sys val
D QOFF 10I 0 INZ(0) Offset to sys val
D QVAL 5000A INZ(' ') System value info
D*
D SYSDATA DS
D SYSVAL 10A INZ(' ')
D SYSTYP 1A INZ(' ')
D SYSSTA 1A INZ(' ')
D SYSLEN 10I 0 INZ(0)
D SYSDAT 3000A INZ(' ')
D*
D ERRC0100 DS
D ERRBYT 10I 0 INZ(0) Bytes provided
D ERRAVAL 10I 0 INZ(0) Bytes available
D ERREXC 7A INZ(' ') Exception ID
D ERRRES 1A INZ(' ') Reserved
D ERROUT 84A INZ(' ') Output
/FREE
// get QDATFMT system value using API's
CALLP QWCRSVALD (QRSYSD : QRLEND : QRNUMD : QRVARD :
ERRC0100);
EVAL QFORMAT = QRSYSD;
EVAL SYSDATA = QVAL;
/END-FREE
Thanks Joe M. Wesson
|
|
Back
Get Profile Handle
I am developing a web front end using ASP on W2K. I would like the user to
sign in using AS/400 UserId and PWD. Is there a way I can pass those to an
API which will verify on the AS/400 and confirm if the userid and pwd is
correct ??
**** copy of QUSEC error code data structure from QSYSINC/QRPGLESRC
D/Copy QSYSINC/QRPGLESRC,QUSEC
*
C Call 'QSYGETPH'
C Parm WKUser
C Parm WKPassword
C Parm ProfileHandle
C Parm QUSEC
*
C If QUSBAVL > 0
C Eval Error = *ON
C Endif
*
Call with userprofile and password. If it is valid (QUSBAVL = 0) then it returns
with a 12 byte profile handle which can be used to set the server job to run as the
user or just ignored.
If it is invalid the QUSEC data structure will contain error information which is
explained in the system API manual
The API with CLLE:
V5R3:
PGM PARM(&Usr &Pwd &Error)
*/
DCL &Usr *CHAR LEN(10)
DCL &Pwd *CHAR LEN(10)
DCL &Err *CHAR LEN(1024)
DCL &PwdLen *INT Len(4) VALUE(10)
DCL &PwdCcsid *INT Len(4) VALUE(0) /* job CCSID */
DCL VAR(&ERROR) TYPE(*CHAR) LEN(5)
DCL VAR(&PH) TYPE(*CHAR) LEN(12)
CHGVAR VAR(&ERROR) VALUE(' ')
*/
CALL PGM(QSYGETPH) PARM(&USR &PWD &PH &ERR &PwdLen &PwdCcsid)
MONMSG MSGID(CPF22E2 CPF22E3 CPF22E4 CPF22E5 +
CPF2203 CPF2204) EXEC(DO)
CHGVAR VAR(&ERROR) VALUE('Error')
ENDDO
RETURN
ENDPGM
Prior to V5R3:
DCL &PwdLen *CHAR Len(4)
DCL &PwdCcsid *CHAR Len(4)
CHGVAR %BIN(&PwdLen) 10
CHGVAR %BIN(&PwdCcsid) 37 /* CCSID 37 */
Thanks to Bryan Yates, Pete Helgren and Barbara Morris
|
|
Back
Move Program Messages & Resend Escape Message
To disallow *PUBLIC to see messages in a message queue but still be able to send
messages to it, set *PUBLIC authority to *CHANGE and remove read data authority.
- And check that the user profile relating to the message queue has *ALL authority
to avoid problems on that account.
Here's a small CL program that will do it for a single user profile message queue:
/*-- Compile instructions: ------------------------------------------*/
/*-- USRPRF(*OWNER) and transfer ownership to QSECOFR */
/*-- Parameters: ---------------------------------------------------*/
Pgm &UsrPrf
Dcl &UsrPrf *Char 10
/*-- Global variables: ---------------------------------------------*/
Dcl &MsgQ *Char 10
Dcl &MsgQlib *Char 10
Dcl &UsrPrf *Char 10
Dcl &MsgKey *Char 4 ' '
Dcl &ToCalStkE *Char 38
/*-- Global monitor: -----------------------------------------------*/
MonMsg CPF0000 *None GoTo Error
/*-- Message API parameter inz: ------------------------------------*/
ChgVar %Bin( &ToCalStkE 1 4 ) 1
ChgVar %Sst( &ToCalStkE 5 20 ) '*NONE *NONE '
ChgVar %Bin( &ToCalStkE 25 4 ) 10
ChgVar %Sst( &ToCalStkE 29 10 ) '*PGMBDY '
/*-- Set user message queue authority: -----------------------------*/
If ( &UsrPrf = ' ' ) Do
ChgVar &UsrPrf '*CURRENT'
EndDo
Else Do
ChkObj &UsrPrf *USRPRF
EndDo
RtvUsrPrf &UsrPrf MsgQ( &MsgQ ) MsgQlib( &MsgQlib ) +
RtnUsrPrf( &UsrPrf )
AlcObj (( &MsgQlib/&MsgQ *MSGQ *EXCL )) Wait( 0 )
RvkObjAut &MsgQlib/&MsgQ *MSGQ +
User( *ALL ) Aut( *ALL )
GrtObjAut &MsgQlib/&MsgQ *MSGQ +
User( *PUBLIC ) Aut( *OBJOPR *ADD *UPD *DLT *EXECUTE )
GrtObjAut &MsgQlib/&MsgQ *MSGQ +
User( &UsrPrf ) Aut( *ALL )
DlcObj (( &MsgQlib/&MsgQ *MSGQ *EXCL ))
/*-- Return: -------------------------------------------------------*/
Return:
Call QMHMOVPM ( &MsgKey +
'*COMP' +
x'00000001' +
'*PGMBDY ' +
x'00000001' +
x'0000000000000008' +
)
Return
/*-- Error routines: -----------------------------------------------*/
Error:
Call QMHMOVPM ( &MsgKey +
'*DIAG' +
x'00000001' +
'*PGMBDY ' +
x'00000001' +
x'0000000000000008' +
)
Call QMHRSNEM ( &MsgKey +
x'0000000000000008' +
&ToCalStkE +
x'00000026' +
'RSNM0100' +
'* ' +
x'00000000' +
)
EndPgm:
EndPgm
Thanks to Carsten Flensburg
|
|
Back
Review documentation for the Retrieve Nonprogram Message Queue Attributes
(QMHRMQAT) API. The following CLP might help illustrate the documentation:
pgm
dcl &ErrCod *char 8 value( x'0000000000000000' )
dcl &qMQ *char 20
dcl &rcvvar *char 150
dcl &MQfull *char 10
dcl &CurSiz *dec ( 9 0 )
chgvar &qMQ ( 'JIMD ' *cat '*LIBL ' )
call QMHRMQAT ( +
&rcvvar +
x'00000096' +
'RMQA0100' +
&qMQ +
&ErrCod +
)
chgvar &MQFull %sst( &RcvVar 141 10 )
chgvar &CurSiz %bin( &RcvVar 33 4 )
dmpclpgm
return
endpgm
Thanks to Tom Liotta
|
|
Back
List Job
H DFTACTGRP(*NO)
* List jobs API
D QUSLJOB PR ExtPgm('QUSLJOB')
D UsrSpc 20A const
D Format 8A const
D QualJob 26A const
D Status 10A const
D ErrorCode 32767A options(*varsize)
D JobType 1A const options(*nopass)
D NumFldsToRtn 10I 0 const options(*nopass)
D FldsToRtn 10I 0 const options(*nopass)
* Create User Space API
D QUSCRTUS PR ExtPgm('QUSCRTUS')
D UserSpc 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)
* retrieve pointer to user space API
D QUSPTRUS PR ExtPgm('QUSPTRUS')
D UserSpc 20A CONST
D Pointer *
* API error code structure
* (we inz to 0 to cause the APIs to return errors using normal
* OS/400 error handling)
D dsEC DS
D dsECBytesP 10I 0 INZ(0)
D dsECBytesA 10I 0 INZ(0)
D*****************************************************
D* List API header data structure
D*****************************************************
D p_UsrSpc S *
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 p_Job S *
D dsJob DS based(p_Job)
D dsJobName 10A
D dsJobUser 10A
D dsJobNbr 6A
D dsJobIntID 16A
D dsJobSts 10A
D dsJobType 1A
D dsJobSubType 1A
D dsJobReserv 2A
D dsJobInfSts 1A
D dsJobReserv2 3A
D dsJobNbrFlds 10I 0
D dsJobKeyAry 1A
D p_KeyAry S *
D dsKeyAry DS based(p_KeyAry)
D dsKA_Len 10I 0
D dsKA_Field 10I 0
D dsKA_Type 1A
D dsKA_Reserv 3A
D dsKA_DtaLen 10I 0
D dsKA_Data 20A
D JOBLIST C 'JOBLIST QTEMP'
D SBSDNAME C 1906
D peSbsName S 10A
D msg s 50A
D Ent s 10I 0
* Check parms
C *entry plist
c parm peSbsName
c if %parms < 1
c eval msg = 'You need to pass a subsystem name'
c dsply msg
c eval *inlr = *on
c return
c endif
* Create a user space
c callp QUSCRTUS(JOBLIST: 'USRSPC':
c %size(dsJob) * 1000: *Blank:
c '*ALL': 'List of jobs on system':
c '*YES': dsEC)
* List jobs to the user space
c callp QUSLJOB(JOBLIST: 'JOBL0200':
c '*ALL *ALL *ALL': '*ACTIVE':
c dsEC: '*': 1: SBSDNAME)
* Read entries in user space
c callp QUSPTRUS(JOBLIST: p_UsrSpc)
c for Ent = 0 to (dsLHEntCnt - 1)
c eval p_Job = p_UsrSpc + dsLHLstOff +
c (dsLhEntSiz * Ent)
c eval p_KeyAry = %addr(dsJobKeyAry)
c if dsKA_Field <> SBSDNAME
c or dsKA_Type <> 'C'
c or dsKA_DtaLen <> 20
c eval msg = 'Unknown key in key array'
c dsply msg
c leave
c endif
** only print jobs in requested subsystem.
** and ignore subsystem monitor jobs.
c if %subst(dsKA_Data: 1: 10) = peSbsName
c and dsJobType <> 'M'
c eval msg = %trim(dsJobNbr) + '/' +
c %trim(dsJobUser) + '/' +
c %trim(dsJobName)
c msg dsply
c endif
c endfor
c eval msg = 'Hit ENTER when done'
c dsply msg
c eval *inlr = *on
Thanks to Scott Klement
|
|
Back
Retrieve Subsystem Information
PGM PARM(&SBS &LIB)
DCL &NBR *CHAR 4
DCL &TOT *CHAR 4
DCL &SBS *CHAR 10
DCL &LIB *CHAR 10
DCL &LEN *CHAR 4
DCL &ACT *CHAR 10
DCL &SPACE *CHAR 100
DCL &SBSLIB *CHAR 20
DCL &ERROR *CHAR 8 (X'0000000000000000')
CHGVAR %SST(&SBSLIB 1 10) &SBS
CHGVAR %SST(&SBSLIB 11 10) &LIB
CHGVAR VAR(%BIN(&LEN)) VALUE('100')
CALL PGM(QWDRSBSD) PARM(&SPACE &LEN SBSI0100 +
&SBSLIB &ERROR)
CHGVAR VAR(&NBR) VALUE(%SST(&SPACE 73 4))
CHGVAR VAR(&TOT) VALUE(%BIN(&NBR))
CHGVAR VAR(&ACT) VALUE(%SST(&SPACE 29 10))
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('The +
number of jobs active in ' || &SBS *BCAT +
'is ' || &TOT || ' & the sbs is ' || &ACT)
END: ENDPGM
CMD PROMPT('Number of Jobs in Subsystem')
PARM KWD(SBSNAME) TYPE(*CHAR) LEN(10) MIN(1) +
PROMPT('Subsystem Name')
PARM KWD(LIBRARY) TYPE(*CHAR) LEN(10) DFT(*LIBL) +
PROMPT('Library Name')
Another example
DCL VAR(&RCVDTA) TYPE(*CHAR) LEN(360)
DCL VAR(&RCVLEN) TYPE(*DEC) LEN(3 0) VALUE(360)
DCL VAR(&RCVLENB) TYPE(*CHAR) LEN(4)
DCL VAR(&FMTNAM) TYPE(*CHAR) LEN(8) VALUE('SBSI0100')
DCL VAR(&JOBCNT#) TYPE(*DEC) LEN(3 0)
DCL VAR(&RTVSBS) TYPE(*CHAR) LEN(20) +
VALUE('SBSNAME SBSLIB')
DCL VAR(&ERRCOD) TYPE(*CHAR)
CHGVAR VAR(%BIN(&RCVLENB)) VALUE(&RCVLEN)
/* Retrieve subsystem information */
CALL PGM(QWDRSBSD) PARM( &RCVDTA +
&RCVLENB +
&FMTNAM +
&RTVSBS +
&ERRCOD )
IF COND(%SST(&RCVDTA 29 10) = '*ACTIVE ') THEN(DO)
CHGVAR VAR(&JOBCNT#) VALUE(%BIN(&RCVDTA 73 4))
ENDDO
Thanks to Jon Erickson
|
|
Back
Search System Directory
**-- Header specifications: ----------------------------------**
H NoMain Option( *SrcStmt )
**-- System Info Data Structure: -----------------------------**
D PgmSts SDs
D PsJobUsr 10a Overlay( PgmSts: 254 )
D PsCurUsr 10a Overlay( PgmSts: 358 )
**-- Get user SMTP address: ----------------------------------**
D GetSmtpAddr Pr 321a
D PxUser 10a
D PxAddr 8a Options( *NoPass )
**-- Get user SMTP address: ----------------------------------**
P GetSmtpAddr B Export
D Pi 321a
D PxUser 10a
D PxAddr 8a Options( *NoPass )
**-- API error data structure: -------------------------------**
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**-- Search directory parameters: ----------------------------**
D Sreq0100 Ds
D SrCcsId 10i 0 Inz( 0 )
D SrChrSet 10i 0 Inz
D SrCodPag 10i 0 Inz
D SrWldCrd 4a Inz
D SrCvtRcv 1a Inz( '0' )
D SrSchDta 1a Inz( '0' )
D SrRunVfy 1a Inz( '1' )
D SrConHdl 1a Inz( '0' )
D SrRscHdl 16a Inz
D SrSrqFmt 8a Inz( 'SREQ0101' )
D SrSrqOfs 10i 0 Inz( 110 )
D SrSrqNbrElm 10i 0 Inz
D SrRtnFmt 8a Inz( 'SREQ0103' )
D SrRtnOfs 10i 0 Inz( 100 )
D SrRtnNbrElm 10i 0 Inz( 1 )
D SrRcvFmt 8a Inz( 'SRCV0101' )
D SrRcvNbrElm 10i 0 Inz( 1 )
D SrUsrFmt 8a Inz( 'SRCV0111' )
D SrOrdFmt 8a Inz
D SrOrdRtnOpt 1a Inz( '0' )
D 3a
D Sr0103 Like( Sreq0103 )
D Sr0101 Like( Sreq0101 )
**
D Sreq0101 Ds Inz
D S1Entry Dim( 2 )
D S1EntLen 10i 0 Inz( %Size( S1Entry ))
D Overlay( S1Entry: 1 )
D S1CmpVal 1a Inz( '1' )
D Overlay( S1Entry: *Next )
D S1FldNam 10a Overlay( S1Entry: *Next )
D S1PrdId 7a Inz( '*IBM' )
D Overlay( S1Entry: *Next )
D S1DtaCas 1a Overlay( S1Entry: *Next )
D 1a Overlay( S1Entry: *Next )
D S1ValLen 10i 0 Inz( %Size( S1ValMtc ))
D Overlay( S1Entry: *Next )
D S1ValMtc 10a Overlay( S1Entry: *Next )
**
D Sreq0103 Ds
D S3SpcRtn 10a Inz( '*SMTP' )
**
D Srcv0100 Ds 32767
D R00BytRtn 10i 0
D R00OrdFldOfs 10i 0
D R00UsrEntOfs 10i 0
D R00DirEntNbr 10i 0
D R00ConHdl 1a
D R00RscHdl 16a
D R00UsrMtcAry Like( Srcv0101 )
**
D Srcv0101 Ds Based( pSrcv0101 )
D R01UsrDtaLen 10i 0
D R01RtnNbrFld 10i 0
D Srcv0111 Ds Based( pSrcv0111 )
D R11FldNam 10a
D R11PrdId 7a
D 3a
D R11CcsId 10i 0
D R11CodPag 10i 0
D R11RtnFldLen 10i 0
D Srcv0111v Ds Based( pSrcv0111v )
D R11RtnFld 256a
**-- Local constanst & variables: ----------------------------**
D SmtpDmn s 256a Varying
D SmtpUsrId s 64a Varying
**
D At c '@'
**-- Search directory: ---------------------------------------**
D SchDir Pr Extpgm( 'QOKSCHD' )
D SdRcvVar Like( Srcv0100)
D SdRcvVarLen 10i 0 Const
D SdFmtNam 8a Const
D SdFunction 10a Const
D SdKeepTmpRsc 1a Const
D SdRqsVar Const Like( Sreq0100 )
D SdRqsVarLen 10i 0 Const
D SdRqsFmtNam 8a Const
D SdError 8a
**
**-- Get SMTP address: ---------------------------------------**
**
C If PxUser = '*CURRENT'
C Eval PxUser = PsCurUsr
C EndIf
**
C If %Parms = 1
C Eval SrSrqNbrElm = 1
C Eval S1ValMtc(1) = PxUser
C Eval S1FldNam(1) = 'USER '
**
C Else
C Eval SrSrqNbrElm = 2
C Eval S1ValMtc(1) = PxUser
C Eval S1ValMtc(2) = PxAddr
C Eval S1FldNam(1) = 'USRID '
C Eval S1FldNam(2) = 'USRADDR'
C EndIf
**
C Eval Sr0103 = Sreq0103
C Eval Sr0101 = Sreq0101
**
C Callp SchDir( Srcv0100
C : %size( Srcv0100 )
C : 'SRCV0100'
C : '*SEARCH'
C : '0'
C : Sreq0100
C : %Size( Sreq0100 )
C : 'SREQ0100'
C : ApiError
C )
**
C If AeBytAvl > 0 Or
C R00DirEntNbr = 0
**
C Return *Blanks
**
C Else
C Eval pSrcv0101 = %Addr( Srcv0100 ) +
C R00UsrEntOfs
C Eval pSrcv0111 = pSrcv0101 +
C %Size( Srcv0101 )
**
C Do R01RtnNbrFld
**
C Eval pSrcv0111v = pSrcv0111 +
C %Size( Srcv0111 )
**
C Select
C When R11FldNam = 'SMTPUSRID'
C Eval SmtpUsrId = %Subst( R11RtnFld
C : 1
C : R11RtnFldLen )
**
C When R11FldNam = 'SMTPDMN'
C Eval SmtpDmn = %Subst( R11RtnFld
C : 1
C : R11RtnFldLen )
C EndSl
**
C Eval pSrcv0111 = pSrcv0111 +
C %Size( Srcv0111 ) +
C R11RtnFldLen
C EndDo
**
C Return SmtpUsrId + At + SmtpDmn
C
C EndIf
**
P GetSmtpAddr E
Thanks to Carsten Flensburg
|
|
Back
List Server Information
*** Use it as a guideline ***
pgm
dcl &NSDate *char 7 /* NetServer start date */
dcl &X00 *char 1 value( x'00' )
dcl &a_pos *char 4 /* Data Start Pos.-Binary */
dcl &InfoQual *char 15 value( '*ALL ' )
/* Create a *usrspc to work with... */
call QUSCRTUS ( +
'NETS QTEMP ' +
'TMPLST ' +
x'00001000' +
X'00' +
'*ALL ' +
'Temporary IFS space ' +
'*YES ' +
x'0000000000000000' +
)
/* List NetServer status info into our *usrspc... */
call QZLSLSTI ( +
'NETS QTEMP ' +
'ZLSL0400' +
&InfoQual +
x'0000000000000000' +
)
/* Get the starting position of the list from the header... */
call QUSRTVUS ( +
'NETS QTEMP ' +
x'0000007D'
x'00000004' +
&a_pos +
)
/* NetServer Start-Date is at offset 60 into the list... */
chgvar %bin( &a_pos ) ( %bin( &a_pos ) + 60 + 1 )
/* Get the NetServer Start-Date from the *usrspc... */
call QUSRTVUS ( +
'NETS QTEMP ' +
&a_pos +
x'00000007' +
&NSDate +
)
/* If the StartDate is binary zeroes, then NetServer isn't started... */
if ( %sst( &NSDate 1 1 ) *eq &X00 ) do
sndusrmsg 'NetServer is NOT active.' tomsgq( *EXT )
enddo
/* ...otherwise NetServer is started... */
else do
sndusrmsg 'NetServer IS active. ' tomsgq( *EXT )
enddo
return
endpgm
Thanks to Tom Liotta
|
|
Back
Retrieve library description
It is used in a loop based on DSPOBJD *ALL *LIB OUTPUT(*OUTFILE).
It puts the library name, size, and description to your joblog.
dcl &rtnvar *char 104
dcl &rtnlen *char 4 x'00000068'
dcl &attrib *char 12 x'000000020000000500000006'
dcl &desc *char 50
dcl &size *dec (9 0)
dcl &mult *dec (9 0)
dcl &sizedec *dec (15 0)
dcl &sizechar *char 15
call qlirlibd (&rtnvar +
&rtnlen +
&odobnm +
&attrib +
x'0000000000000000')
chgvar &desc %sst(&rtnvar 29 50)
chgvar &size %bin(&rtnvar 93 4)
chgvar &mult %bin(&rtnvar 97 4)
chgvar &sizedec (&size * &mult)
chgvar &sizechar &sizedec
sndpgmmsg (&odobnm *cat ' ' *cat &sizechar +
*cat ' ' *cat &desc)
Thanks to Vern Hamberg
|
|
Back
List Spooled Files
Here's a program written in free-form RPG which demonstrates a simple use
of the QUSLSPL API. Perhaps you can use this to help you understand what
needs to be changed in your program...
H DFTACTGRP(*NO)
D QUSLSPL PR ExtPgm('QUSLSPL')
* required parameters
D UsrSpc 20A const
D Format 8A const
D UserName 10A const
D QualOutQ 20A const
D FormType 10A const
D UserData 10A const
* optional group 1:
D ErrorCode 32766A options(*nopass: *varsize)
* optional group 2:
D QualJob 26A options(*nopass) const
D FieldKeys 10I 0 options(*nopass: *varsize)
D dim(9999)
D NumFields 10I 0 options(*nopass) const
* optional group 3:
D AuxStgPool 10I 0 options(*nopass) const
* optional group 4:
D JobSysName 8A options(*nopass) const
D StartCrtDate 7A options(*nopass) const
D StartCrtTime 6A options(*nopass) const
D EndCrtDate 7A options(*nopass) const
D EndCrtTime 6A options(*nopass) const
D QUSCRTUS PR ExtPgm('QUSCRTUS')
D UsrSpc 20A CONST
D ExtAttr 10A CONST
D InitialSize 10I 0 CONST
D InitialVal 1A CONST
D PublicAuth 10A CONST
D Text 50A CONST
D Replace 10A CONST
D ErrorCode 32766A options(*nopass: *varsize)
D QUSPTRUS PR ExtPgm('QUSPTRUS')
D UsrSpc 20A CONST
D Pointer *
D QUSDLTUS PR ExtPgm('QUSDLTUS')
D UsrSpc 20A CONST
D ErrorCode 32766A options(*varsize)
D GetStatus PR 4A
D StatusCode 10I 0 value
D p_UsrSpc s *
D dsLH DS BASED(p_UsrSpc)
D qualified
D Filler1 103A
D Status 1A
D Filler2 12A
D HdrOffset 10I 0
D HdrSize 10I 0
D ListOffset 10I 0
D ListSize 10I 0
D NumEntries 10I 0
D EntrySize 10I 0
D p_Entry s *
D dsSF DS BASED(p_Entry)
D qualified
D JobName 10A
D UserName 10A
D JobNumber 6A
D SplfName 10A
D SplfNbr 10I 0
D SplfStatus 10I 0
D OpenDate 7A
D OpenTime 6A
D Schedule 1A
D SysName 10A
D UserData 10A
D FormType 10A
D OutQueue 10A
D OutQueueLib 10A
D AuxPool 10I 0
D SplfSize 10I 0
D SizeMult 10I 0
D TotalPages 10I 0
D CopiesLeft 10I 0
D Priority 1A
D Reserved 3A
D dsEC DS qualified
D BytesProvided 10I 0 inz(%size(dsEC))
D BytesAvail 10I 0 inz(0)
D MessageID 7A
D Reserved 1A
D MessageData 240A
D MYSPACE C CONST('SPLLIST QTEMP ')
D Keys s 10I 0 dim(1)
D size s 10I 0
D sf s 10I 0
D msg s 52A
/free
// set this to zero to let OS/400 handle errors, instead
// of handling them ourselves...
dsEC.BytesProvided = 0;
// Create a user space.. make space for (approx) 300
// spooled files to be listed.
size = %size(dsLH) + 512 + (%size(dsSF) * 300);
QUSCRTUS(MYSPACE: 'USRSPC': size: x'00': '*ALL':
'Temp User Space for QUSLSPL API': '*YES': dsEC);
// List spooled files to the user space
QUSLSPL(MYSPACE: 'SPLF0300': *blanks: *blanks: *blanks: *blanks:
dsEC: '*': Keys: 0);
// Get a pointer to the returned user space
QUSPTRUS(MYSPACE: p_UsrSpc);
// Loop through list, for each spooled file, display the
// spooled file name, number and status.
p_Entry = p_UsrSpc + dsLH.ListOffset;
for sf = 1 to dsLH.NumEntries;
if (dsSF.SplfStatus <> 10);
msg = %trim(dsSF.SplfName) + ' ' +
%trim(%editc(dsSF.SplfNbr:'L')) + ' ' +
GetStatus(dsSF.SplfStatus);
dsply msg;
endif;
p_Entry += dsLH.EntrySize;
endfor;
// delete user space, we're done with it
QUSDLTUS(MYSPACE: dsEC);
// give user a chance to read the screen before ending
msg = 'Press ENTER to end';
dsply '' '' msg;
*inlr = *on;
/end-free
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* get human-readable status code for a numeric status code:
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P GetStatus B
D GetStatus PI 4A
D StatusCode 10I 0 value
/free
if (StatusCode = 1);
return 'RDY';
elseif (StatusCode = 2);
return 'OPN';
elseif (StatusCode = 3);
return 'CLO';
elseif (StatusCode = 4);
return 'SAV';
elseif (StatusCode = 5);
return 'WTR';
elseif (StatusCode = 6);
return 'HLD';
elseif (StatusCode = 7);
return 'MSGW';
elseif (StatusCode = 8);
return 'PND';
elseif (StatusCode = 9);
return 'PRT';
elseif (StatusCode = 10);
return 'FIN';
elseif (StatusCode = 11);
return 'SND';
elseif (StatusCode = 12);
return 'DFR';
else;
return '???';
endif;
/end-free
P E
Thanks to Scott Klement
|
|
Back
Retrieve Member Description
Here's an example of call the Retrieve Member Description API in RPG IV.
I use this with CodeStudio to retrieve information about the member via FTP
which unfortunately requires you to send and Escape message. :(
But look at the example call to the QUSRMBRD API for an example of calling
it.
H BNDDIR('QC2LE') actgrp('QILE') DFTACTGRP(*NO)
**----------------------------------------------------------------
** RTVMBRD - Retrieve a member description
** and write as an *ESCAPE message to the FTP client.
** Used by CodeStudio to retrieve a member description
** (i.e., Source Type - SEU Attributes)
**----------------------------------------------------------------
** COMPILING INSTRUCTIONS:
** NOTE: This program is NOT Release Sensitive
** 1. Upload to the AS/400
** 2. Compile to the library of your choice
** a) CRTBNDRPG PGM(QGPL/RTVMBRD) SRCFILE(mylib/QRPLESRC) +
** DFTACTGRP(*NO)
** 3. In CodeStudio, on the TOOLS menu, select OPTIONS
** 4. Select the "Add-Ins" tab/page
** 5. Set the host program to call to this program name:
** a) Heading: CL command to retrieve member description...
** b) Entry: CALL QGPL/RTVMBRD PARM(&F &L &M)
**
** When these steps have been completed, this add-in will
** transfer the Source Member's SEU Type, Text, Last Change Date
** to CodeStudio when a member is selected for download.
**----------------------------------------------------------------
** int sprintf( char *buffer, const char *format [, argument] ... );
D sprintf4 PR 10I 0 ExtProc('sprintf')
D szRecvVar * VALUE Options(*STRING)
D szFormat * VALUE Options(*STRING)
D szData1 * VALUE OPTIONS(*STRING)
D szData2 * VALUE OPTIONS(*STRING: *NOPASS)
D szData3 * VALUE OPTIONS(*STRING: *NOPASS)
D szData4 * VALUE OPTIONS(*STRING: *NOPASS)
** The general purpose API error data structure that is usually ignored.
D api_error S 21A
** The fields used by the SndPgmMsg API
D szMsgID S 7A Inz('CPF9898')
D szMsgFile S 20A Inz('QCPFMSG QSYS' )
D szMsgText S 255A
D nMsgLen S 10I 0
D szMsgType S 10A
D szToPgmQ S 10A
D nToPgmQ S 10I 0
D szMsgKey S 4A
** A pointer to the receiving buffer, used by sprintf
D pBuffer S *
D szBuffer S Like(szMsgText)
** Tells the APIs how long the buffers are that are being used.
D nBufLen S 10I 0
**----------------------------------------------------------------
**----------------------------------------------------------------
** The structure returned by the QusRMBRD API.
**----------------------------------------------------------------
**----------------------------------------------------------------
D szMbrd0100 DS INZ
D nBytesRtn 10I 0
D nBytesAval 10I 0
D szFileName 10A
D szLibName 10A
D szMbrName 10A
D szFileAttr 10A
D szSrcType 10A
D dtCrtDate 13A
D dtLstChg 13A
D szMbrText 50A
D bIsSource 1A
D pMbrText S *
**----------------------------------------------------------------
** Input Parameters for the program.
**----------------------------------------------------------------
** Source file name
D szSrcFile S 10A
D szSrcLib S 10A
D szSrcMbr S 10A
**----------------------------------------------------------------
** Input Parameters to the QUSRMBRD API
**----------------------------------------------------------------
** Format to be returned
D szFmt S 8A Inz('MBRD0100')
** Qualified source file and library name
D szQualName S 20A
** Whether or not to ignore overrides (0=Ignore, 1 = Apply)
D bOvr S 1A Inz('0')
**----------------------------------------------------------------
** Call this program with 3 parameters:
** Parm(QRPGLESRC myLibr ORDENTRY)
** srcfile srclib srcmbr
**----------------------------------------------------------------
C *ENTRY PLIST
C Parm szSrcFile
C Parm szSrcLib
C Parm szSrcMbr
** If we don't have at least 3 parameters, too bad for the caller!
C if %Parms < 3
C Eval szMsgText = 'CE3-Invalid parameter list'
C else
**----------------------------------------------------------------
** Call QusRMBRD to retrieve the specified source member's attributes
**----------------------------------------------------------------
C Eval szQualName = szSrcFile + szSrcLib
C Eval nBufLen = %size(szMbrD0100)
**----------------------------------------------------------------
C Call(E) 'QUSRMBRD'
C Parm szMbrD0100
C Parm nBufLen
C Parm szFmt
C Parm szQualName
C Parm szSrcMbr
C Parm bOvr
**----------------------------------------------------------------
** If RTFMBRD failed, we tell the FTP client that it failed.
**----------------------------------------------------------------
C if %Error
C Eval szMsgText = 'CE3-RTVMBRD Failed'
** Otherwise, just keep on going!
C else
** Although not required, C like NULL terminated strings
C Eval szBuffer= *ALLX'00'
C Eval pBuffer = %addr(szBuffer)
C eval szMbrText = %TrimR(szMbrText)+X'00'
C eval pMbrText = %addr(szMbrText)
**----------------------------------------------------------------
** Use the C runtime sprintf() to concatenate everything nicely
**----------------------------------------------------------------
C CallP sprintf4(pBuffer :
C 'CX3%s%s%s%s' :
C szSrcType :
C bIsSource :
C dtLstChg :
C pMbrText )
** The formatted response text gets sent as msg data
C Eval szMsgText = %str(pBuffer)
C endif
C endif
** Tell the API how long the message text (actually Msgdata) is.
C Eval nMsgLen = %Len(%trimr(szMsgText))
**----------------------------------------------------------------
** SndPgmMsg MSGID(CPF9898) MSGF(QSYS/QCPFMSG) TOPGMQ(*PRV) +
** MSGDTA(szMsgText) MSGTYPE(*ESCAPE)
**----------------------------------------------------------------
C Call 'QMHSNDPM'
C Parm 'CPF9898' szMsgID
C Parm szMsgFile
C Parm szMsgText
C Parm nMsgLen
C Parm '*ESCAPE' szMsgType
C Parm '*PGMBDY' szToPgmQ
C Parm 1 nToPgmQ
C Parm szMsgKey
C Parm api_error
** Note, we return here to improve performance for subsequent calls
** The program will end when the FTP server's job itself ends.
** If you are uncomfortable with this, uncomment the *INLR line:
C**** MOVE *ON *INLR
C return
Thanks to Bob Cozzi
|
|
Back
List Network Interfaces
Q: Greetings! I would like to check the status of a TCP/IP interface. If the status
is not *active I would want to get a notification to the system operator, and if the
status is failed to vary off and on. Can this be accomplished in a CL?
A: Netstat has no output other than the display. And the Work with interfaces option
of CFGTCP menu has no command equivalent. But if you are on v5r1, or later, there are
now APIs that let you retrieve the status of interfaces, as well as other TCP/IP
operational info. In tnis case, List Network Interface (QtocLstNetIfc) puts all the
interface info into a user space.
You'd need to poll the status from time to time. This can be called (CALLPRC) from a
CLLE - Service Program: QTOCNETSTS. You don't need to name the service program in the
compile - it's included automatically.
CALLPRC PRC('QtocLstNetIfc') +
PARM('X QTEMP ' +
'NIFC0100' +
X'0000000000000000')
does the trick, putting the data into *USRSPC QTEMP/X. Then use the appropriate user
space APIs to get the information. Look up CL & APIs under Programming in InfoCenter.
Thanks to Vern Hamberg
And with RPG:
* CRTRPGMOD MODULE(NETIFCR) SRCFILE(xxx/QRPGLESRC) SRCMBR(NETIFCR)
* CRTPGM PGM(NETIFCR) BNDSRVPGM(QTOCNETSTS)
*
H DEBUG OPTION(*SRCSTMT:*NODEBUGIO) BNDDIR('QC2LE')
H dftactgrp(*NO)
FQSYSPRT O F 198 Printer USROPN
D uSpaceName s 20 inz('NETIFC 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 InetAdr 15 overlay(uListEntry1:1)
D Reservedr 1 overlay(uListEntry1:16)
D InetAdrb 10i 0 overlay(uListEntry1:17)
D NetAdr 15 overlay(uListEntry1:21)
D Reserved1 1 overlay(uListEntry1:36)
D NetAdrb 10i 0 overlay(uListEntry1:37)
D NetName 10 overlay(uListEntry1:41)
D LineDsc 10 overlay(uListEntry1:51)
D IfcName 10 overlay(uListEntry1:61)
D Reserved2 2 overlay(uListEntry1:71)
D IfcSts 10i 0 overlay(uListEntry1:73)
D IfcTypSrv 10i 0 overlay(uListEntry1:77)
D IfcMtu 10i 0 overlay(uListEntry1:81)
D IfcLinTyp 10i 0 overlay(uListEntry1:85)
D HostAdr 15 overlay(uListEntry1:89)
D Reserved3 1a overlay(uListEntry1:104)
D HostAdrb 10i 0 overlay(uListEntry1:105)
D IfcSbnMask 15 overlay(uListEntry1:109)
D Reserved4 1a overlay(uListEntry1:124)
D IfcSbnMaskb 10i 0 overlay(uListEntry1:125)
D DrtBrdCstAdr 15 overlay(uListEntry1:129)
D Reserved5 1a overlay(uListEntry1:144)
D DrtBrdCstAdrb 10i 0 overlay(uListEntry1:145)
D ChgDate 8 overlay(uListEntry1:149)
D ChgTime 6 overlay(uListEntry1:157)
D AsoLclIfc 15 overlay(uListEntry1:163)
D Reserved6 3a overlay(uListEntry1:178)
D AsoLclIfcb 10i 0 overlay(uListEntry1:181)
D ChgSts 10i 0 overlay(uListEntry1:185)
D PacketRules 10i 0 overlay(uListEntry1:189)
D AutoStart 10i 0 overlay(uListEntry1:193)
D TorkenRingSeq 10i 0 overlay(uListEntry1:197)
D IfcType 10i 0 overlay(uListEntry1:201)
D ProxyARPEbl 10i 0 overlay(uListEntry1:205)
D ProxyARPAlw 10i 0 overlay(uListEntry1:209)
D CfgMTU 10i 0 overlay(uListEntry1:213)
D NetNameFull 24 overlay(uListEntry1:217)
D IfcNameFull 24 overlay(uListEntry1:241)
*----------------------------------------------------------------
* 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
*----------------------------------------------------------------
* 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 LstNetIfc PR ExtProc('QtocLstNetIfc')
D 20
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('NETIFCR')
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 LstNetIfc(
C uSpaceName:
C 'NIFC0100':
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 IfcStsC 11
C Select
C When IfcSts = 0
c eval IfcStsC = 'Inactive'
C When IfcSts = 1
c eval IfcStsC = 'Active'
C When IfcSts = 2
c eval IfcStsC = 'Starting'
C When IfcSts = 3
c eval IfcStsC = 'Ending'
C When IfcSts = 4
c eval IfcStsC = 'RCYPND'
C When IfcSts = 5
c eval IfcStsC = 'RCYCNL'
C When IfcSts = 6
c eval IfcStsC = 'Failed'
C When IfcSts = 7
c eval IfcStsC = 'Failed(TCP)'
C When IfcSts = 8
c eval IfcStsC = 'DOD'
C EndSl
C EndSr
OQSYSPRT E HEAD 1
O 8 'Inet Adr'
O 23 'Net Adr'
O 40 'Net Name'
O 51 'Line Dsc'
O 61 'Ifc Name'
O 75 'Ifc Status'
O 85 'Host Adr'
O E OUT 1
O InetAdr
O NetAdr + 1
O NetName + 1
O LineDsc + 1
O IfcName + 1
O IfcStsC + 1
O HostAdr + 1
Thanks to Vengoal Chang
|
|
Back
Convert Case
Here is a sample of converting one paramter to lowercase using the
current CCSID of the requesting job. The one value that would need
changing is &DATASIZE and the LEN() of &PARM1 -- these two must match
and represent the size of the variable to lowercase.
To handle three input parameters simply vary the second and fourth
parameters being passed to QLGCNVCS (Convert Case).
PGM PARM(&PARM1)
DCL VAR(&PARM1) TYPE(*CHAR) LEN(10)
DCL VAR(&REQCTLBLK) TYPE(*CHAR) LEN(22) +
VALUE(X'00000001000000000000000100000000000+
000000000') /* Use Job CCSID to convert +
input data to lowercase */
/* DCL VAR(&REQCTLBLK) TYPE(*CHAR) LEN(22) +
VALUE(X'00000001000000000000000000000000000+
000000000') */ /* Use Job CCSID to convert +
input data to uppercase */
DCL VAR(&DATASIZE) TYPE(*DEC) LEN(2 0) VALUE(10)
DCL VAR(&DATALEN) TYPE(*CHAR) LEN(4)
CHGVAR %BINARY(&DATALEN) VALUE(&DATASIZE)
CALL PGM(QLGCNVCS) PARM(&REQCTLBLK &PARM1 +
&PARM1 &DATALEN 0)
ENDPGM
Thanks to Bruce Vining
|
|
Back
Page #1
Page #3