|
#4 |
API - Table of Contents |
#6 |
|
|
|
Convert edit code mask
** Program . . : CBX109S
** Description : Get file field value by key
**
** Program summary
** ---------------
** Object - User space APIs:
** QUSCRTUS Create user space Creates a user space in either
** user domain or system domain.
** Only user domain user spaces are
** accessible by the user space APIs.
**
** QUSDLTUS Delete user space Deletes the user space specified.
**
** QUSPTRUS Retrieve pointer to The address of the first byte
** user space of the storage allocated by the
** user space requested is returned.
**
** Database and file APIs:
** QUSLFLD List fields Lists the fields of the specified
** file record format to user space.
**
** The list includes information
** about each field's attributes and
** record buffer position.
**
** Work management API:
** QUSRJOBI Retrieve job Retrieves specific information
** information about a specific job, covering
** all attributes and other state
** and runtime related information.
**
** Edit function API:
** QECCVTEC Convert edit code Converts an edit code into an
** mask edit mask, which is a set of
** instructions used by the edit
** function to format a numeric
** value into a character string.
**
** MI builtins:
** _LBEDIT Late bound edit Transforms a numeric value from
** its internal format to character
** form, using the provided edit
** mask. Late bound here refers to
** the source value location not
** having to be provided until
** runtime.
**
**
** _MEMMOVE Copy memory Copies a string from one pointer
** specified location to another.
**
** C library functions:
** _Ropen Open record file Opens the record file specified
** as defined by the keywords in the
** mode parameter. If the file does
** not exist it will not be created.
**
** The mode parameter specifies the
** type of file access as well as
** optional parameters to control
** f.x. whether the file is read in
** arrival or keyed order.
**
** The *LIBL & *CURLIB special values
** are supported for the library
** name and an optional member name
** is possible to specify in the
** format library/file(member).
**
** _Rclose Close record file This API closes the previously
** opened record file identified by
** the file pointer parameter.
**
** Storage allocated is freed and
** all buffers are flushed.
**
** _Rreadk Read by key Reads a record in a keyed file
** matching the key value parameter.
** This key value can be partial.
** The record is locked unless the
** No_Lock option is set.
**
**
** Service program procedures:
** GetFldVal Get field value Based on a file name, field name
** and key value, the corresponding
** field value is returned in left
** adjusted character format.
**
** The library list is searched to
** locate the file specified.
**
** This function can be called as
** a single request performing all
** involved steps at once. Or - if
** repeated retrievals from the same
** file are required - as a session
** performing the initialization and
** termination process only once.
**
** If an error occurs in the process
** the resulting error message id is
** returned as the field value.
**
** LstFld List fields Lists to the specified user space
** a list of the specified file's
** fields, including name, data type
** and length.
**
** Chain Read record by key Performs the actual keyed access
** to the file identified by the
** file pointer passed and returns,
** if a match is found, the record
** buffer retrieved.
**
** RtvFld Retrieve field The buffer offset, data type and
** field length of the field name
** specified is retrieved from the
** user space field list.
**
** Based on these field attributes
** the field's value is extracted
** and, if necessary, converted to
** character format and eventually
** returned to the caller.
**
** The record buffer is available
** to this procedure by means of a
** global variable.
**
** EditC Edit by edit code Converts the specified buffer
** location containing a numeric
** value in internal format to a
** readable character format as
** defined by the specified edit
** code.
**
** ApyDecFmt Apply decimal Applies the current job's decimal
** format format to binary fields having
** decimal positions.
**
**
** Programmer's notes:
** This API example's intention is to demonstrate the ability to parse
** an externally defined record buffer using various APIs, MI builtins
** and C library functions.
**
** The flexibility achieved by the parameterized field value level
** access to an externally defined file could be further extended to
** enable the reverse functionality. The _CVTEFN and _LBCPYNV(R) MI
** builtins offer functionality that enables you to update a numeric
** field in a record buffer, based on a character representation of a
** numeric value, respectively another buffer location containing a
** numeric value.
**
** This way many types of file and data exchanges could be soft coded
** throughout the whole exchange process. Note however, that updating
** production data at the buffer level requires careful design and a
** high level of precaution - the above lines only intents to point
** out the possibility - in case that need should arise at some point.
**
**
** Compile options required:
** CrtRpgMod CBX109S +
** DbgView( *LIST )
**
** CrtSrvPgm CBX109S +
** Module( CBX109S ) +
** Export( *ALL ) +
** ActGrp( QSRVPGM )
**
**
**-- Header specifications: --------------------------------------------**
H NoMain BndDir( 'QC2LE' ) Option( *SrcStmt )
**-- System information: -----------------------------------------------**
D PgmSts SDs
D PsPgmNam *Proc
D PsMsgId 7a Overlay( PgmSts: 40 )
**-- Api error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**-- I/O feedback structure & constants: -------------------------------**
D RIOFB Ds Based( pRIOFB )
D pKey *
D pSysParm *
D IoRcdRrn 10u 0
D IoNbrBytRw 10i 0
D IoBlkCnt 5i 0
D IoBlkFllBy 1a
D IoBitFld 1a
D IoRsv 20a
**
D Key_Lt c x'09000100'
D Key_Le c x'0A000100'
D Key_Eq c x'0B000100'
D Key_Eq_N c x'0B000101'
D Key_Ge c x'0C000100'
D Key_Gt c x'0D000100'
**
D No_Lock c x'00000001'
**-- Edit template & constants: ----------------------------------------**
D DPA_Template_T Ds
D SclTyp 1a
D SclLen 5i 0
D DecPos 3i 0 Overlay( SclLen: 1 )
D DecLen 3i 0 Overlay( SclLen: 2 )
D Rsv 10i 0 Inz
**
D T_SIGNED c x'00'
D T_FLOAT c x'01'
D T_ZONED c x'02'
D T_PACKED c x'03'
D T_UNSIGNED c x'0A'
**-- Global variables: -------------------------------------------------**
D RcdBuf s 4096a
D pRFILE s *
D rc s 10i 0
**-- Global constants: -------------------------------------------------**
D Null c ''
D UsrSpc c 'DBFLST QTEMP'
**-- Create user space: -------------------------------------------------**
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D CsSpcNamQ 20a Const
D CsExtAtr 10a Const
D CsInzSiz 10i 0 Const
D CsInzVal 1a Const
D CsPubAut 10a Const
D CsText 50a Const
**-- Optional 1:
D CsReplace 10a Const Options( *NoPass )
D CsError 32767a Options( *NoPass: *VarSize )
**-- Optional 2:
D CsDomain 10a Const Options( *NoPass )
**-- Retrieve pointer to user space: ------------------------------------**
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**-- Delete user space: ------------------------------------------------**
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- List fields to user space: ----------------------------------------**
D LstFldSpc Pr ExtPgm( 'QUSLFLD' )
D LfSpcNamQ 20a Const
D LfFmtNam 8a Const
D LfFilNamQual 20a Const
D LfRcdFmtNam 10a Const
D LfOvrPrc 1a Const
D LfError 32767a Options( *NoPass: *VarSize )
**-- Convert edit code to mask: ----------------------------------------**
D CvtCdeMsk Pr ExtPgm( 'QECCVTEC' )
D CcEdtMsk 256a
D CcEdtMskLen 10i 0
D CcRcvVarLen 10i 0
D CcZroFilChr 1a
D CcEdtCde 1a Const
D CcCcyInd 1a Const
D CcSrcVarPrc 10i 0 Const
D CcSrcVarDec 10i 0 Const
D CcError 32767a Options( *VarSize )
**-- Retrieve job information: -----------------------------------------**
D RtvJobInf Pr ExtPgm( 'QUSRJOBI' )
D RiRcvVar 32767a Options( *VarSize )
D RiRcvVarLen 10i 0 Const
D RiFmtNam 8a Const
D RiJobNamQ 26a Const
D RiJobIntId 16a Const
**-- Optional 1:
D RiError 32767a Options( *NoPass: *VarSize )
**-- Optional 2:
D RiRstStc 1a Options( *NoPass )
**-- Open file: --------------------------------------------------------**
D Ropen Pr * ExtProc( '_Ropen' )
D pRFile * Value Options( *String )
D pMode * Value Options( *String )
**-- Close file: -------------------------------------------------------**
D Rclose Pr 10i 0 ExtProc( '_Rclose' )
D pRFile * Value
**-- Read by key: ------------------------------------------------------**
D Rreadk Pr * ExtProc( '_Rreadk' )
D pRFile * Value
D pBuffer * Value
D BufLength 10u 0 Value
D Options 10i 0 Value
D pKey * Value
D KeyLength 10u 0 Value
**-- Copy memory: ------------------------------------------------------**
D MemCpy Pr * ExtProc( '_MEMMOVE' )
D pOutMem * Value
D pInpMem * Value
D iMemSiz 10u 0 Value
**-- Edit function: ----------------------------------------------------**
D Edit Pr ExtProc( '_LBEDIT' )
D RcvVar * Value
D RcvVarLen 10u 0 Const
D SrcVar * Value
D SrcVarAtr Const Like( DPA_Template_T )
D EdtMsk 256a Const
D EdtMskLen 10u 0 Const
**-- Get field value: --------------------------------------------------**
D GetFldVal Pr 1024a Varying
D PxRqsTyp 10i 0 Const
D PxFilNam 10a Const Options( *NoPass )
D PxFldNam 10a Const Options( *NoPass )
D PxKey 256a Const Varying Options( *NoPass )
**-- List fields: ------------------------------------------------------**
D LstFld Pr 7a Varying
D PxUsrSpc 20a Const
D PxFilNam 10a Const
**-- Read file by key: -------------------------------------------------**
D Chain Pr 10240a Varying
D PxFilPtr * Const
D PxKeyVal 256a Const
**-- Retrieve field: ---------------------------------------------------**
D RtvFld Pr 1024a Varying
D PxUsrSpc 20a Const
D PxFldNam 10a Const
**-- Edit code: --------------------------------------------------------**
D EditC Pr 256a Varying
D PxDecVar * Value
D PxDecTyp 1a Const
D PxDecDig 5u 0 Const
D PxDecPos 5u 0 Const
D PxEdtCde 1a Const
**-- Apply decimal format: ---------------------------------------------**
D ApyDecFmt Pr 32a Varying
D PxInpStr 32a Value Varying
D PxDecPos 5u 0 Const
**-- Get field value: --------------------------------------------------**
P GetFldVal B Export
D Pi 1024a Varying
D PxRqsTyp 10i 0 Const
D PxFilNam 10a Const Options( *NoPass )
D PxFldNam 10a Const Options( *NoPass )
D PxKey 256a Const Varying Options( *NoPass )
**-- Local variables:
D FldVal s 1024a Varying
**-- Get field value: --------------------------------------------------**
**
C Eval FldVal = Null
**
C If %Parms >= 2
C
C If PxRqsTyp = 0 Or
C PxRqsTyp = 1
**
C CallP CrtUsrSpc( UsrSpc
C : *Blanks
C : 65535
C : x'00'
C : '*CHANGE'
C : *Blanks
C : '*YES'
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Eval FldVal = AeMsgId
**
C Else
C Eval FldVal = LstFld( UsrSpc
C : PxFilNam
C )
**
C Monitor
C Eval pRFILE = Ropen( PxFilNam
C : 'rr, nullcap=Y'
C )
**
C On-Error
C Eval FldVal = PsMsgId
C EndMon
C EndIf
**
C EndIf
C EndIf
**
C If %Parms = 4 And
C FldVal = Null And
C pRFILE > *Null
C
C If PxRqsTyp = 0 Or
C PxRqsTyp = 2
**
C Eval RcdBuf = Chain( pRFILE: PxKey )
**
C If RcdBuf <> Null
**
C Eval FldVal = RtvFld( UsrSpc
C : PxFldNam
C )
C EndIf
**
C EndIf
C EndIf
**
C If %Parms >= 1
C
C If PxRqsTyp = 0 Or
C PxRqsTyp = 3
**
C Eval rc = Rclose( pRFILE )
**
C CallP DltUsrSpc( UsrSpc
C : ApiError
C )
**
C EndIf
C EndIf
**
C Return FldVal
**
P GetFldVal E
**-- List fields: ------------------------------------------------------**
P LstFld B Export
D Pi 7a Varying
D PxUsrSpc 20a Const
D PxFilNam 10a Const
**-- List fields: ------------------------------------------------------**
**
C CallP LstFldSpc( PxUsrSpc
C : 'FLDL0100'
C : PxFilNam + '*LIBL'
C : '*FIRST'
C : '0'
C : ApiError
C )
**
C If AeBytAvl = *Zero
C Return Null
**
C Else
C Return AeMsgId
C EndIf
**
P LstFld E
**-- Read file by key: -------------------------------------------------**
P Chain B Export
D Pi 10240a Varying
D PxFilPtr * Const
D PxKeyVal 256a Const
**
D StrBuf s 10240a
D RtnBuf s 10240a Varying
D KeyFld s 256a
**-- Chain: ------------------------------------------------------------**
**
C Eval KeyFld = PxKeyVal
**
C Eval pRIOFB = Rreadk( PxFilPtr
C : %Addr( StrBuf )
C : %Size( StrBuf )
C : Key_Eq_N
C : %Addr( KeyFld )
C : %Len( %TrimR( KeyFld ))
C )
**
C If IoNbrBytRw > 0
C Eval RtnBuf = %SubSt( StrBuf: 1: IoNbrBytRw )
C EndIf
**
C Return RtnBuf
**
P Chain E
**-- Retrieve field: ---------------------------------------------------**
P RtvFld B Export
D Pi 1024a Varying
D PxUsrSpc 20a Const
D PxFldNam 10a Const
**-- Local variables:
D FldVal s 1024a
D Idx s 10u 0
**-- API format FLDL0100:
D FldLst100 Ds Based( pLstEnt )
D F1FldNam 10a
D F1DtaTyp 1a
D F1DtaUse 1a
D F1OutBufPos 10i 0
D F1InpBufPos 10i 0
D F1Len 10i 0
D F1Digits 10i 0
D F1DecPos 10i 0
D F1TxtDsc 50a
D F1EdtCod 2a
D F1EdtWrdLen 10i 0
D F1EdtWrd 64a
D F1ColHdg1 20a
D F1ColHdg2 20a
D F1ColHdg3 20a
D F1IntFldNam 10a
D F1AltFldNam 30a
D F1AltFldNamLn 10i 0
D F1NbrChrDbcs 10i 0
D F1AlwNull 1a
D F1HstVarInd 1a
D F1DatTimFmt 4a
D F1DatTimSep 1a
D F1VarFldLenIn 1a
D F1TxtDscCcsId 10i 0
D F1DtaCcsId 10i 0
D F1ColHdgCcsId 10i 0
D F1EdtWrdCcsId 10i 0
D F1Ucs2DspFldL 10i 0
**-- API header information:
D HdrInf Ds Based( pHdrInf )
D FlFilNamU 10a
D FlFilLibU 10a
D FlFilTyp 10a
D FlRcdFmtNamU 10a
D FlRcdLen 10i 0
D FlRcdFmtId 13a
D FlRcdTxtDsc 50a
D 1a
D FlRcdTxtCcsId 10i 0
D FlVarLenFldIn 1a
D FlGphFldInd 1a
D FlDatTimFldIn 1a
D FlNulCapFldIn 1a
**-- User space generic header:
D UsrSpc Ds Based( pUsrSpc )
D UsOfsHdr 10i 0 Overlay( UsrSpc: 117 )
D UsOfsLst 10i 0 Overlay( UsrSpc: 125 )
D UsNumLstEnt 10i 0 Overlay( UsrSpc: 133 )
D UsSizLstEnt 10i 0 Overlay( UsrSpc: 137 )
**-- User space pointers:
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- Retrieve field: ---------------------------------------------------**
**
C CallP RtvPtrSpc( PxUsrSpc: pUsrSpc )
**
C Eval pHdrInf = pUsrSpc + UsOfsHdr
C Eval pLstEnt = pUsrSpc + UsOfsLst
**
C For Idx = 1 To UsNumLstEnt
**
C If F1FldNam = PxFldNam
**
C Select
C When F1DtaTyp = 'A' Or
C F1DtaTyp = 'L' Or
C F1DtaTyp = 'T' Or
C F1DtaTyp = 'Z'
**
C CallP MemCpy( %Addr( FldVal )
C : %Addr( RcdBuf ) +
C F1InpBufPos - 1
C : F1Len
C )
**
C When F1DtaTyp = 'P' Or
C F1DtaTyp = 'Z' Or
C F1DtaTyp = 'B'
**
C Eval FldVal = EditC( %Addr( RcdBuf ) +
C F1InpBufPos - 1
C : F1DtaTyp
C : F1Digits
C : F1DecPos
C : 'P'
C )
**
C EndSl
**
C Leave
C EndIf
**
C If Idx < UsNumLstEnt
C Eval pLstEnt = pLstEnt + UsSizLstEnt
C EndIf
C EndFor
**
C Return %TrimR( FldVal )
**
P RtvFld E
**-- Edit code: --------------------------------------------------------**
P EditC B Export
D Pi 256a Varying
D PxDecVar * Value
D PxDecTyp 1a Const
D PxDecDig 5u 0 Const
D PxDecPos 5u 0 Const
D PxEdtCde 1a Const
**-- Local variables & constants:
D EdtMsk s 256a
D EdtMskLen s 10i 0
D RcvVar s 256a
D RcvVarLen s 10i 0
D ZroFilChr s 1a
D DecDig s 10u 0
**
**-- Edit: -------------------------------------------------------------**
**
C Select
C When PxDecTyp = 'P' Or
C PxDecTyp = 'Z'
**
C If PxDecTyp = 'P'
C Eval SclTyp = T_PACKED
C Else
C Eval SclTyp = T_ZONED
C EndIf
**
C Eval DecDig = PxDecDig
C Eval DecPos = PxDecPos
C Eval DecLen = PxDecDig
**
C When PxDecTyp = 'B'
**
C Eval SclTyp = T_SIGNED
**
C Eval DecDig = PxDecDig
C Eval DecPos = *Zero
**
C If DecDig > 5
C Eval DecDig = 10
C Eval DecLen = 4
C Else
C Eval DecDig = 5
C Eval DecLen = 2
C EndIf
C EndSl
**
C CallP CvtCdeMsk( EdtMsk
C : EdtMskLen
C : RcvVarLen
C : ZroFilChr
C : PxEdtCde
C : ' '
C : DecDig
C : DecPos
C : ApiError
C )
**
C CallP(e) Edit( %Addr( RcvVar )
C : RcvVarLen
C : PxDecVar
C : DPA_Template_T
C : EdtMsk
C : EdtMskLen
C )
**
C If %Error
C Return Null
**
C ElseIf PxDecTyp = 'B' And
C PxDecPos > *Zero
**
C Return ApyDecFmt( %SubSt( RcvVar: 1: RcvVarLen )
C : PxDecPos
C )
**
C Else
C Return %TrimL( %SubSt( RcvVar: 1: RcvVarLen ))
C EndIf
**
P EditC E
**-- Apply decimal format: ---------------------------------------------**
P ApyDecFmt B
D Pi 32a Varying
D PxInpStr 32a Value Varying
D PxDecPos 5u 0 Const
**-- Local variables:
D ZroOfs s 5u 0
D DecOfs s 5u 0
**-- Job info format JOBI0400:
D J4RcvDta Ds
D J4BytRtn 10i 0
D J4BytAvl 10i 0
D J4JobNam 10a
D J4UsrNam 10a
D J4JobNbr 6a
D J4DecFmt 1a Overlay( J4RcvDta: 457 )
**
C CallP RtvJobInf( J4RcvDta
C : %Size( J4RcvDta )
C : 'JOBI0400'
C : '*'
C : *Blank
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Return PxInpStr
C Else
**
C If J4DecFmt = 'J'
C Eval ZroOfs = %Len( PxInpStr ) - PxDecPos
C Eval DecOfs = ZroOfs + 1
C Else
C Eval ZroOfs = %Len( PxInpStr ) - PxDecPos + 1
C Eval DecOfs = ZroOfs
C EndIf
**
C Eval PxInpStr = %Xlate( ' '
C : '0'
C : PxInpStr
C : ZroOfs
C )
C
**
C If J4DecFmt = ' '
C Return %Replace( '.'
C : PxInpStr
C : DecOfs
C : 0
C )
**
C Else
C Return %Replace( ','
C : PxInpStr
C : DecOfs
C : 0
C )
C EndIf
C EndIf
**
P ApyDecFmt E
The calling program
** Program . . : CBX109T
** Description : Get file field value by key - Test
**
** Program directions
** ------------------
**
** This test program retrieves field values from the TCP/IP host table
** which is stored in a physical file named QATOCHOST in QUSRSYS.
**
** Go CFGTCP option 10 allow you to examine the current entries in this
** table. If you want, or if required, please change the key value from
** '127.0.0.1' to another existing entry in the table. Please also
** check that you have sufficient authority to the table prior to
** running this test program.
**
** Another option would be to replace the file name, field name and key
** value specified in the example below to values of your own choice.
**
** This test program presents the retrieved field values using the DSPLY
** facility. You could also simply start a debug session against this
** program and step through the code lines, to watch the process as it
** unfolds.
**
** When the debug session is positioned on a GetFldVal() procedure
** statement you can use F22 to step into the subprocedure and examine
** the statements executed there. The F10 step instruction also applies
** while in the subprocedure.
**
**
** Compile options required:
** CrtRpgMod CBX109T +
** DbgView( *LIST )
**
** CrtPgm CBX109T +
** Module( CBX109T ) +
** BndSrvPgm( CBX109S ) +
** ActGrp( QILE )
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Global definitions: -----------------------------------------------**
D FldVal s 1024a Varying
D DspVal s 42a
**
D SngRqs c 0
D InzRqs c 1
D RunRqs c 2
D TrmRqs c 3
**-- Get field value: --------------------------------------------------**
D GetFldVal Pr 1024a Varying
D PxRqsTyp 10i 0 Const
D PxFilNam 10a Const Options( *NoPass )
D PxFldNam 10a Const Options( *NoPass )
D PxKey 256a Const Varying Options( *NoPass )
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval FldVal = GetFldVal( SngRqs
C : 'QATOCHOST'
C : 'HOSTNME1'
C : '127.0.0.1'
C )
**
C Eval DspVal = FldVal
C 'HOSTNME1 =' Dsply DspVal
**
C Eval FldVal = GetFldVal( InzRqs
C : 'QATOCHOST'
C )
**
C Eval FldVal = GetFldVal( RunRqs
C : 'QATOCHOST'
C : 'HOSTNME1'
C : '127.0.0.1'
C )
**
C Eval DspVal = FldVal
C 'HOSTNME1 =' Dsply DspVal
**
C Eval FldVal = GetFldVal( RunRqs
C : 'QATOCHOST'
C : 'IPINTGER'
C : '127.0.0.1'
C )
**
C Eval DspVal = FldVal
C 'IPINTGER =' Dsply DspVal
**
C Eval FldVal = GetFldVal( RunRqs
C : 'QATOCHOST'
C : 'TXTDESC'
C : '127.0.0.1'
C )
**
C Eval DspVal = FldVal
C 'TXTDESC =' Dsply DspVal
**
C Eval FldVal = GetFldVal( TrmRqs )
**
C Return
**
Thanks to Carsten Flensburg
|
|
Back
Retrieve the Interactive Feature Code
*===============================================================
* GetProcFeat +
*===============================================================
PGetProcFeat B
DGetProcFeat PI 1n
*---------------------------------------------------------------
D SysProc 4A
D Proc 4A
D Int 4A
D wxdebug 1N const
*---------------------------------------------------------------
*---------------------------------------------------------------------
* Local work areas *
*---------------------------------------------------------------------
D*****************************************************************
D*Field definitions for RHRL0100 format.
D*****************************************************************
DQGYL0100 DS
D* Qgy RHRL0100
D QGYBR 1 4U 0
D* number of bytes returned
D QGYBA 5 8U 0
D* number of bytes available
D QGYNBRRR 9 12U 0
D* num of resources returned
D QGYREL 13 16U 0
D* length of resource entry
D Qvadsomhelst 17 2016a
DRESDTL DS
D QGYCAT 1 4U 0
D* category
D QGYFL 5 8U 0
D* family level
D QGYLT 9 12B 0
D* LAN line type
D QGYNAME 13 22
D* name
D QGYTYPE 23 26
D* type
D QGYMODL 27 29
D* model
D QGYSTAT 30 30
D* status
D QGYSYS 31 38
D* system connected to
D QGYADDR 39 50
D* LAN adapter address
D QGYDES 51 100
D* description
D QGYKIND 101 124
D* resource kind
D*****************************************************************
D*Field definitions for RHRI0410 format.
D*****************************************************************
DRcvVar DS
D QRHBRTN 1 4B 0
D* Bytes Returned
D QRHBAVL 5 8B 0
D* Bytes Available
D QRHSBUS 9 12B 0
D* System Bus number
D QRHSBOA 13 16B 0
D* System Board number
D QRHSCAR 17 20B 0
D* System Card number
D QRHSSRL 21 30a
D* System serial number
D QRHPART 31 42
D* Part number
D QRHFRAM 43 46a
D* Frame id
D QRHCARP 47 51a
D* Card position
D QRHSPRC 52 55a
D* Sys. processor feature code
D QRHPRC 56 59a
D* Processor feature code
D QRHPRCI 60 63a
D* Interactive feature code
D ListFormat S 8 INZ('RHRI0410')
D ListFormat2 S 8 INZ('RHRL0100')
D Resource S 10 INZ(' ')
D RcvSiz S 10i 0 INZ(%size(RCVVAR))
D RcvSiz2 S 10i 0 INZ(%size(QGYL0100))
D ResourceCat S 10i 0 INZ(4)
D strpos S 10i 0 INZ(1)
D DtlSiz S 10i 0 INZ(%size(RESDTL))
D wxlog S 256a
*===============================================================
* Error Information Data Structure +
*===============================================================
*Error Code
DQUSBN DS
* Qus EC
DQUSBNB 1 4B 0 inz(%size(QUSBN))
* Bytes Provided
DQUSBNC 5 8B 0
* Bytes Available
DQUSBND 9 15
* Exception Id
DQUSBNF 16 256
C eval wxlog = *blanks
C CALL 'QGYRHRL'
C PARM QGYL0100
C PARM RcvSiz2
C PARM ListFormat2
C PARM ResourceCat
C PARM QUSBN
C if QUSBNC > 0 error occured
C callp SndDbgMsg( GetTime +
C ' Error on QGYRHRI program ' +
C 'call: ' +
C QUSBND)
C return *on
C endif
C if QGYNBRRR > 0
C do QGYNBRRR
C eval %subst(RESDTL:1:DTLSIZ) =
C %subst(Qvadsomhelst:strpos:DTLSIZ)
C if %subst(QGYKIND:17:8) =
C x'0000000000080000'
C eval Resource = QGYNAME
C leave
C endif
C eval StrPos = StrPos + QGYREL
C enddo
C endif
C CALL 'QGYRHRI'
C PARM RcvVar
C PARM RcvSiz
C PARM ListFormat
C PARM Resource
C PARM QUSBN
C if QUSBNC > 0 error occured
C callp SndDbgMsg( GetTime +
C ' Error on QGYRHRI program ' +
C 'call: ' +
C QUSBND)
C return *on
C endif
C if wxdebug debug
C callp SndDbgMsg( GetTime +
C ' System Proc#: ' +
C %trim(QRHSPRC) + ' ' +
C ' Processor#: ' +
C %trim(QRHPRC) + ' ' +
C ' Interactive#: ' +
C %trim(QRHPRCI) + ' ' +
C ' Serial#: ' + QRHSSRL +
C ' system board: ' +
C %trim(%editc(QRHSBOA:'Z')) )
C endif
C eval SysProc = QRHSPRC
C eval Proc = QRHPRC
C eval Int = QRHPRCI
C return *off
PGetProcFeat E
Thanks to Stefan Tageson
|
|
Back
Retrieve user authority to object
**
** Program . . : CBX5032
** Description : Check object authority
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : April 15, 2004
**
**
** Program summary
** ---------------
**
** Parameters:
** INPUT PxObjNam Object name, the object for which to
** check the specified authorization level.
**
** INPUT PxObjLib Object library.
**
** INPUT PxObjTyp Object type.
**
** INPUT PxAut Authorization level to check for.
**
** Valid values:
** *ALL
** *CHANGE
** *USE
** *EXCLUDE
** *AUTLMGT
**
** INPUT PxUsrPrf Name of user profile having it's
** authority checked.
**
** Special values:
** *CURRENT The user currently running
** the job.
**
** *PUBLIC The public authority for
** the specified object is
** checked.
**
** OUTPUT PxRtnCod A boolean value indicating the result
** of the requested action.
**
** Valid return codes:
** 0 = Authority level not found
** 1 = Authority level found
**
** Security API:
** QSYRUSRA Retrieve user Returns a specific user's
** authority to object authority for the specified
** object.
**
**
** Programmer's notes:
** This program checks if a user has the specified authority to an
** object. All authorization sources are taken into account during
** the authorization check (group profile(s), adopted authority as
** well as authorization lists, public and *ALLOBJ authority).
**
** The actual source of authority is specified in the returned data
** structure subfield 'U1AutSrc' as a 2-letter code. Please check
** the Security API manual for the details. It can be found online
** here:
**
** http://publib.boulder.ibm.com/iseries/v5r2/ic2924/info/apis/ ...
** ... qsyrusra.htm
**
** Compile options:
**
** CrtRpgMod Module( CBX5032 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX5032 )
** Module( CBX5032 )
**
**
**-----------------------------------------------------------------------**
** Revised . : 00.00.0000
** by . . . :
** Reference :
** Changes . :
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Api Error: --------------------------------------------------------**
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**-- Receiver format USRA0100: -----------------------------------------**
D USRA0100 Ds
D U1BytRtn 10i 0
D U1BytAvl 10i 0
D U1ObjAut 10a
D U1AutLstMgt 1a
D U1ObjOpr 1a
D U1ObjMgm 1a
D U1ObjExs 1a
D U1DtaRead 1a
D U1DtaAdd 1a
D U1DtaUpd 1a
D U1DtaDlt 1a
D U1AutLst 10a
D U1AutSrc 2a
D U1AdpAut 1a
D U1AdpObjAut 10a
D U1AdpAutLstMg 1a
D U1AdpObjOpr 1a
D U1AdpObjMgm 1a
D U1AdpObjExs 1a
D U1AdpDtaRead 1a
D U1AdpDtaAdd 1a
D U1AdpDtaUpd 1a
D U1AdpDtaDlt 1a
D U1AdpDtaExe 1a
D 10a
D U1AdpObjAlt 1a
D U1AdpObjRef 1a
D 10a
D U1DtaExe 1a
D 10a
D U1ObjAlt 1a
D U1ObjRef 1a
D U1AspDevLib 10a
D U1AspDevObj 10a
**-- Retrieve user authority to object: --------------------------------**
D RtvUsrAut Pr ExtPgm( 'QSYRUSRA' )
D RuRcvVar Like( USRA0100 )
D RuRcvVarLen 10i 0 Const
D RuFmtNam 8a Const
D RuUsrPrf 10a Const
D RuObjNamQ 20a Const
D RuObjTyp 10a Const
D RuError 32767a Options( *VarSize )
D RuAspDev 10a Options( *NoPass )
**-- Parameters: -------------------------------------------------------**
D PxObjNam s 10a
D PxObjLib s 10a
D PxObjTyp s 10a
D PxUsrPrf s 10a
D PxAut s 10a
D PxRtnCod s n
**
C *Entry Plist
C Parm PxObjNam
C Parm PxObjLib
C Parm PxObjTyp
C Parm PxUsrPrf
C Parm PxAut
C Parm PxRtnCod
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval PxRtnCod = *Off
**
C CallP RtvUsrAut( USRA0100
C : %Size( USRA0100 )
C : 'USRA0100'
C : PxUsrPrf
C : PxObjNam + PxObjLib
C : PxObjTyp
C : ApiError
C )
**
C If AeBytAvl = *Zero
**
C Select
C When PxAut = '*ALL ' And
C U1ObjAut = '*ALL '
**
C Eval PxRtnCod = *On
**
C When PxAut = '*CHANGE ' And
C U1ObjOpr = 'Y' And
C U1DtaRead = 'Y' And
C U1DtaAdd = 'Y' And
C U1DtaUpd = 'Y' And
C U1DtaDlt = 'Y' And
C U1DtaExe = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*USE ' And
C U1ObjOpr = 'Y' And
C U1DtaRead = 'Y' And
C U1DtaExe = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*AUTLMGT ' And
C U1AutLstMgt = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*EXCLUDE ' And
C U1ObjAut = '*EXCLUDE '
**
C Eval PxRtnCod = *On
C EndSl
C EndIf
C
C Return
**
The calling program
**-- Program parameters: -----------------------------------------------**
D PxObjNam s 10a
D PxObjLib s 10a
D PxObjTyp s 10a
D PxUsrPrf s 10a
D PxAut s 10a
D PxRtnCod s n
**
**-- Check object authority:
**
C Call 'CBX5032'
C Parm 'QCMD' PxObjNam
C Parm '*LIBL' PxObjLib
C Parm '*PGM' PxObjTyp
C Parm '*PUBLIC' PxUsrPrf
C Parm '*USE' PxAut
C Parm PxRtnCod
**
C If PxRtnCod = '1'
C Else
C EndIf
**
Thanks to Carsten Flensburg
|
|
Back
List users authorized to object
**
** Program . . : CBX5031
** Description : Check private authority
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : April 15, 2004
**
**
** Program summary
** ---------------
**
** Parameters:
** INPUT PxObjNam Object name, the object for which to
** check the specified authorization level.
**
** INPUT PxObjLib Object library.
**
** INPUT PxObjTyp Object type.
**
** INPUT PxAut Authorization level to check for.
**
** Valid values:
** *ALL
** *CHANGE
** *USE
** *EXCLUDE
** *AUTLMGT
**
** INPUT PxUsrPrf Name of user profile having it's
** authority checked.
**
** Special values:
** *CURRENT The user currently running
** the job.
**
** *PUBLIC The public authority for
** the specified object is
** checked.
**
** OUTPUT PxRtnCod A boolean value indicating the result
** of the requested action.
**
** Valid return codes:
** 0 = Authority level not found
** 1 = Authority level found
**
** Security API:
** QSYLUSRA List users authorized Creates a list of users having a
** to object private authority to the object
** specified. The list is put into
** a user space.
**
** Object - User space APIs:
** QUSCRTUS Create user space Creates a user space in either
** user domain or system domain.
** Only user domain user spaces are
** accessible by the user space APIs.
**
** QUSDLTUS Delete user space Deletes the user space specified.
**
** QUSPTRUS Retrieve pointer to The address of the first byte
** user space of the storage allocated by the
** user space requested is returned.
**
**
** Programmer's notes:
** This program checks if a user holds a private authorization of
** the specified level to an object. No other authorization sources
** are taken into account during the authorization check.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX5031 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX5031 )
** Module( CBX5031 )
**
** **
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- System information: -----------------------------------------------**
D PgmSts SDs
D PsJobUsr 10a Overlay( PgmSts: 254 )
D PsCurUsr 10a Overlay( PgmSts: 358 )
**-- Global variables: -------------------------------------------------**
D Idx s 10i 0
**-- API error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
**-- Create User Space Parameter: --------------------------------------**
D CuUsrSpcQ Ds
D CuUsrSpcNam 10 Inz( 'AUTLST ' )
D CuUsrSpcLib 10 Inz( 'QTEMP ' )
**-- Entry format USRA0100: --------------------------------------------**
D USRA0100 Ds Based( pLstEnt )
D U1UsrPrf 10a
D U1AutVal 10a
D U1AutLstMgt 1a
D U1ObjOpr 1a
D U1ObjMgt 1a
D U1ObjExs 1a
D U1DtaRead 1a
D U1DtaAdd 1a
D U1DtaUpd 1a
D U1DtaDlt 1a
D U1DtaExe 1a
D 10a
D U1ObjAlt 1a
D U1ObjRef 1a
**-- API format USRA0100: Header information: --------------------------**
D HdrInf Ds Based( pHdrInf )
D HiObjNam 10a
D HiLibNam 10a
D HiObjTyp 10a
D HiOwnNam 10a
D HiAutL 10a
D HiPriGrp 10a
D HiFldAut 1a
D HiAspDevLib 10a
D HiAspDevObj 10a
**-- User Space Generic Header: ---------- -----------------------------**
D UsrSpc Ds Based( pUsrSpc )
D UsOfsHdr 10i 0 Overlay( UsrSpc: 117 )
D UsOfsLst 10i 0 Overlay( UsrSpc: 125 )
D UsNumLstEnt 10i 0 Overlay( UsrSpc: 133 )
D UsSizLstEnt 10i 0 Overlay( UsrSpc: 137 )
**-- Pointers: ---------------------------------------------------------**
D pUsrSpc s * Inz( *Null )
D pHdrInf s * Inz( *Null )
D pLstEnt s * Inz( *Null )
**-- List authorized users: --------------------------------------------**
D LstAutUsr Pr ExtPgm( 'QSYLUSRA' )
D LaSpcNamQ 20a Const
D LaFmtNam 8a Const
D LaObjNamQ 20a Const
D LaObjTyp 10a Const
D LaError 32767a Options( *VarSize )
D LaAspDev 10a Options( *NoPass )
**-- Create user space: -------------------------------------------------**
D CrtUsrSpc Pr ExtPgm( 'QUSCRTUS' )
D CsSpcNamQ 20a Const
D CsExtAtr 10a Const
D CsInzSiz 10i 0 Const
D CsInzVal 1a Const
D CsPubAut 10a Const
D CsText 50a Const
**
D CsReplace 10a Const Options( *NoPass )
D CsError 32767a Options( *NoPass: *VarSize )
**
D CsDomain 10a Const Options( *NoPass )
**
D CsTfrSizRqs 10i 0 Const Options( *NoPass )
D CsOptSpcAlg 1a Const Options( *NoPass )
**-- Retrieve pointer to user space: ------------------------------------**
D RtvPtrSpc Pr ExtPgm( 'QUSPTRUS' )
D RpSpcNamQ 20a Const
D RpPointer *
D RpError 32767a Options( *NoPass: *VarSize )
**-- Delete user space: -------------------------------------------------**
D DltUsrSpc Pr ExtPgm( 'QUSDLTUS' )
D DsSpcNamQ 20a Const
D DsError 32767a Options( *VarSize )
**-- Parameters: -------------------------------------------------------**
D PxObjNam s 10a
D PxObjLib s 10a
D PxObjTyp s 10a
D PxUsrPrf s 10a
D PxAut s 10a
D PxRtnCod s n
**
C *Entry Plist
C Parm PxObjNam
C Parm PxObjLib
C Parm PxObjTyp
C Parm PxUsrPrf
C Parm PxAut
C Parm PxRtnCod
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval PxRtnCod = *Off
**
C If PxUsrPrf = '*CURRENT'
C Eval PxUsrPrf = PsCurUsr
C EndIf
**
C CallP CrtUsrSpc( CuUsrSpcQ
C : *Blanks
C : 65535
C : x'00'
C : '*CHANGE'
C : *Blanks
C : '*YES'
C : ApiError
C )
**
C CallP LstAutUsr( CuUsrSpcQ
C : 'USRA0100'
C : PxObjNam + PxObjLib
C : PxObjTyp
C : ApiError
C )
**
C If AeBytAvl = *Zero
**
C CallP RtvPtrSpc( CuUsrSpcQ
C : pUsrSpc
C )
**
C ExSr ChkUsrAut
C EndIf
**
C CallP DltUsrSpc( CuUsrSpcQ
C : ApiError
C )
**
C Return
**
**-- Check user authority: ---------------------------------------------**
C ChkUsrAut BegSr
**
C Eval pHdrInf = pUsrSpc + UsOfsHdr
C Eval pLstEnt = pUsrSpc + UsOfsLst
**
C For Idx = 1 to UsNumLstEnt
**
C If U1UsrPrf = PxUsrPrf
C ExSr ChkAutVal
**
C Leave
C EndIf
**
C If Idx < UsNumLstEnt
C Eval pLstEnt = pLstEnt + UsSizLstEnt
C EndIf
C EndFor
**
C EndSr
**-- Check authority value: --------------------------------------------**
C ChkAutVal BegSr
**
C Select
C When PxAut = '*ALL ' And
C U1AutVal = '*ALL '
**
C Eval PxRtnCod = *On
**
C When PxAut = '*CHANGE ' And
C U1ObjOpr = 'Y' And
C U1DtaRead = 'Y' And
C U1DtaAdd = 'Y' And
C U1DtaUpd = 'Y' And
C U1DtaDlt = 'Y' And
C U1DtaExe = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*USE ' And
C U1ObjOpr = 'Y' And
C U1DtaRead = 'Y' And
C U1DtaExe = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*AUTLMGT ' And
C U1AutLstMgt = 'Y'
**
C Eval PxRtnCod = *On
**
C When PxAut = '*EXCLUDE ' And
C U1AutVal = '*EXCLUDE '
**
C Eval PxRtnCod = *On
C EndSl
**
C EndSr
The calling program
**-- Program parameters: -----------------------------------------------**
D PxObjNam s 10a
D PxObjLib s 10a
D PxObjTyp s 10a
D PxUsrPrf s 10a
D PxAut s 10a
D PxRtnCod s n
**
**-- Check private authority:
**
C Call 'CBX5031'
C Parm 'QPWFSERVER' PxObjNam
C Parm 'QSYS' PxObjLib
C Parm '*AUTL' PxObjTyp
C Parm 'QSYS' PxUsrPrf
C Parm '*ALL' PxAut
C Parm PxRtnCod
**
C If PxRtnCod = '1'
C Else
C EndIf
Thanks to Carsten Flensburg
|
|
Back
Retrieve job queue information
// ****************************************************************** //
// * Compile Options * //
// ****************************************************************** //
H Option(*SRCSTMT:*NODEBUGIO) Indent('|') ExprOpts(*ResDecPos)
/IF DEFINED(*CRTBNDRPG)
H DFTACTGRP(*NO)
H ActGrp(*NEW)
/ENDIF
H BndDir('QC2LE')
// ****************************************************************** //
// * Definition Specifations * //
// ****************************************************************** //
// ------------------------------------------------------------------ //
// - External Prototypes - //
// ------------------------------------------------------------------ //
D GETJOBQ PR EXTPGM('QSPRJOBQ')
D RECIEVER 144A
D RCVRLEN 10I 0 const
D FORMAT 8A const
D JOBQ 20A conST
D ERROR 116A
// ------------------------------------------------------------------ //
// - Data Structures/Arrays - //
// ------------------------------------------------------------------ //
/INCLUDE QSYSINC/QRPGLESRC,QSPRJOBQ
/INCLUDE QSYSINC/QRPGLESRC,QUSEC
D QUSED01 100A
// ****************************************************************** //
// * Main Calculations * //
// ****************************************************************** //
/Free
GETJOBQ(QSPQ010000:%SIZE(QSPQ010000):'JOBQ0100':
'QBATCH QGPL':QUSEC);
DSPLY QSPSN;
*INLR = *On;
/End-Free
Thanks to Chris Beck
|
|
Back
Register Activation Group Exit Procedure
Here's a message that I posted to the iSeries Network RPG forum back in
May. It was in reply to someone who wanted to run procedures when a service
program was activated or deactivated (much like a constructor/destructor
in OO languages.)
As far as I know, there's no way to run a procedure during the activation
phase.
Here's how I approach the problem: I have a subprocedure that gets called
first by every exported subprocedure. I use a global field to determine
if it's been called before, and if so, it does not run again.
I also tend to register a cleanup procedure with CEE4RAGE. Though,
ending the activation group should theoretically clean everything
up for me, I like to do it explicitly. I like to be in control! :)
The following code should help illustrate what I'm talking about:
H NOMAIN
D Initialized s 1N inz(*off)
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Initialization routine
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P InzSrvPgm B
D InzSrvPgm PI
D CEE4RAGE PR
D procedure * procptr const
D feedback 12A options(*omit)
/free
if (Initialized);
return;
endif;
// .. open files here ...
// .. other initializations ...
CEE4RAGE(%paddr(EndSrvPgm): *OMIT);
Initialized = *ON;
return;
/end-free
P e
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* EndSrvPgm(): This is called automatically when the activation
* group ends. (which is when the srvpgm is removed
* from memory.)
*
* Note that this must be exported so that CEE4RAGE can call it.
*
* InzSrvPgm() registers this procedure with the CEE4RAGE() API
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P EndSrvPgm B export
D EndSrvPgm PI
D AgMark 10U 0 options(*nopass)
D Reason 10U 0 options(*nopass)
D Result 10U 0 options(*nopass)
D UserRC 10U 0 options(*nopass)
/free
// ... terminate any helper processes
// ... shut down any persistent APIs
// ... close files.
// ... deallocate memory.
Initialized = *OFF;
return;
/end-free
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Every exported procedure (besides EndSrvPgm) starts by calling
* the InzSrvPgm() subprocedure
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P SomeProc B export
D SomeProc PI 10I 0
D SomeParm 123A const
/free
InzSrvPgm();
// ... perform function of subproc here ...
return data;
/end-free
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Every exported procedure (besides EndSrvPgm) starts by calling
* the InzSrvPgm() subprocedure
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P AnotherProc B export
D AnotherProc PI 10I 0
D AnotherParm 321A const
/free
InzSrvPgm();
// ... perform function of subproc here ...
return data;
/end-free
P E
Thanks to Scott Klement
|
|
Back
Get Service Name for Port
Q:
Is there any way to retrieve the TCP/IP service (local port name)
associated to a local port number ?
Just like int the command WRKSRVTBLE. Is there an API for this ?
A:
- Here's an RPG/IV example of the getservbyport() function:
H bnddir( 'QC2LE' )
**
D getservbyport pr * extproc( 'getservbyport' )
D port 10i 0 value
D protocol * value options( *string )
**
D servent ds based( p_servent )
D s_name *
D s_aliases *
D port 10i 0
D s_proto *
**
D idx s 10i 0
D name s 128a
D protocol s 128a
D p_aliases s * dim( 12 ) based( s_aliases )
D aliases s 128a dim( %elem( p_aliases ))
**
/free
p_servent = getservbyport( 443: *null );
if p_servent <> *null;
name = %str( s_name );
protocol = %str( s_proto );
for idx = 1 to %elem( p_aliases );
if p_aliases(idx) = *null;
leave;
endif;
aliases(idx) = %str( p_aliases(idx));
endfor;
endif;
p_servent = getservbyport( 443: 'udp' );
if p_servent <> *null;
name = %str( s_name );
protocol = %str( s_proto );
for idx = 1 to %elem( p_aliases );
if p_aliases(idx) = *null;
leave;
endif;
aliases(idx) = %str( p_aliases(idx));
endfor;
endif;
*inlr = *on;
return;
/end-free
The first call returns the first server registered to the specified port.
The second call returns the service name for the specified port's 'udp'
protocol entry.
If you need to call the getservbyport() function repeatedly, the
setservent() and endservent() functions allow you to control when the
service database file is opened and closed, leaving it open for the
getservbyport() calls. The getservent() function enables you to retrieve a
sequential list of the servers in the service database.
Thanks to Carsten Flensburg
|
|
Back
Get File System Information
H DFTACTGRP(*NO)
/copy statvfs_h
D chkflag PR 1N
D field 10U 0 value
D bit 10U 0 value
D getsize PR 15A varying
D size 10U 0 value
D fstype s 80A varying
D vfs ds likeds(ds_statvfs)
D msg s 52A
D peObj s 32A
c *entry plist
c parm peObj
c if statvfs(%trimr(peObj): vfs) = -1
c eval msg = 'statvfs() failed.'
c dsply msg
c eval *inlr = *on
c return
c endif
c eval msg = 'Object = ' + peObj
c msg dsply
c eval fstype = %str(%addr(vfs.f_basetype))
c eval msg = 'FS Type: ' + fstype
c msg dsply
c eval msg = 'Block size: ' +
c getsize(vfs.f_bsize)
c msg dsply
c if vfs.f_bsize <> 0
c eval msg = 'Total blocks: ' +
c %char(vfs.f_blocks)
c msg dsply
c eval msg = 'Blocks free: ' +
c %char(vfs.f_bfree)
c msg dsply
c endif
c eval msg = 'Object link maximum: ' +
c %char(vfs.f_objlinkmax)
c msg dsply
c eval msg = 'Directory link maximum: ' +
c %char(vfs.f_dirlinkmax)
c msg dsply
c eval msg = 'Pathname component max: ' +
c getsize(vfs.f_namemax)
c msg dsply
c eval msg = 'Path name maximum: ' +
c getsize(vfs.f_pathmax)
c msg dsply
c if chkflag(vfs.f_flag: ST_RDONLY)
c eval msg = 'Read Only = Yes'
c else
c eval msg = 'Read Only = No'
c endif
c msg dsply
c if chkflag(vfs.f_flag: ST_NOSUID)
c eval msg = 'Set Userid Allowed = No'
c else
c eval msg = 'Set Userid Allowed = Yes'
c endif
c msg dsply
c if chkflag(vfs.f_flag: ST_CASE_SENSITITIVE)
c eval msg = 'Case Sensitivity = Yes'
c else
c eval msg = 'Case Sensitivity = No'
c endif
c msg dsply
c if chkflag(vfs.f_flag: ST_CHOWN_RESTRICTED)
c eval msg = 'Chg Owner restricted = Yes'
c else
c eval msg = 'Chg Owner restricted = No'
c endif
c msg dsply
c if chkflag(vfs.f_flag: ST_THREAD_SAFE)
c eval msg = 'Threadsafe = Yes'
c else
c eval msg = 'Threadsafe = No'
c endif
c msg dsply
c if chkflag(vfs.f_flag: ST_DYNAMIC_MOUNT)
c eval msg = 'Dynamic mount = Yes'
c else
c eval msg = 'Dynamic mount = No'
c endif
c msg dsply
c if chkflag(vfs.f_flag: ST_NO_EXPORTS)
c eval msg = 'Can be exported = No'
c else
c eval msg = 'Can be exported = Yes'
c endif
c msg dsply
c if chkflag(vfs.f_flag: ST_SYNCHRONOUS)
c eval msg = 'Sync write support = Yes'
c else
c eval msg = 'Sync write support = No'
c endif
c dsply msg
c eval *inlr = *on
c return
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* chkflag(): Check whether a flag bit is set
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P chkflag B
D chkflag PI 1N
D field 10U 0 value
D bit 10U 0 value
c return (%bitand(field:bit) <> 0)
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* getsize(): Get human-readable size info
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P getsize B
D getsize PI 15A varying
D size 10U 0 value
c select
c when size = 0
c return 'Not defined'
c when size = *HIVAL
c return 'No maximum'
c other
c return %char(size)
c endsl
P E
Here's the source for member "STATVFS_H":
/if defined(STATVFS_H_DEFINED)
/eof
/endif
/define STATVFS_H_DEFINED
*---------------------------------------------------------------
* ds_statvfs - data structure to receive file system info
*
* f_bsize = file system block size (in bytes)
* f_frsize = fundamental block size in bytes.
* if this is zero, f_blocks, f_bfree and f_bavail
* are undefined.
* f_blocks = total number of blocks (in f_frsize)
* f_bfree = total free blocks in filesystem (in f_frsize)
* f_bavail = total blocks available to users (in f_frsize)
* f_files = total number of file serial numbers
* f_ffree = total number of unused file serial numbers
* f_favail = number of available file serial numbers to users
* f_fsid = filesystem ID. This will be 4294967295 if it's
* too large for a 10U 0 field. (see f_fsid64)
* f_flag = file system flags (see below)
* f_namemax = max filename length. May be 4294967295 to
* indicate that there is no maximum.
* f_pathmax = max pathname legnth. May be 4294967295 to
* indicate that there is no maximum.
* f_objlinkmax = maximum number of hard-links for objects
* other than directories
* f_dirlinkmax = maximum number of hard-links for directories
* f_fsid64 = filesystem id (in a 64-bit integer)
* f_basetype = null-terminated string containing the file
* system type name. For example, this might
* be "root" or "Network File System (NFS)"
*
* Since f_basetype is null-terminated, you should read it
* in ILE RPG with:
* myString = %str(%addr(ds_statvfs.f_basetype))
*---------------------------------------------------------------
D ds_statvfs DS qualified
D f_bsize 10U 0
D f_frsize 10U 0
D f_blocks 20U 0
D f_bfree 20U 0
D f_bavail 20U 0
D f_files 10U 0
D f_ffree 10U 0
D f_favail 10U 0
D f_fsid 10U 0
D f_flag 10U 0
D f_namemax 10U 0
D f_pathmax 10U 0
D f_objlinkmax 10I 0
D f_dirlinkmax 10I 0
D f_reserved1 4A
D f_fsid64 20U 0
D f_basetype 80A
*---------------------------------------------------------------
* flags specified in the f_flags element of the ds_statvfs
* data structure.
*---------------------------------------------------------------
D ST_RDONLY...
D C CONST(1)
D ST_NOSUID...
D C CONST(2)
D ST_CASE_SENSITITIVE...
D C CONST(4)
D ST_CHOWN_RESTRICTED...
D C CONST(8)
D ST_THREAD_SAFE...
D C CONST(16)
D ST_DYNAMIC_MOUNT...
D C CONST(32)
D ST_NO_MOUNT_OVER...
D C CONST(64)
D ST_NO_EXPORTS...
D C CONST(128)
D ST_SYNCHRONOUS...
D C CONST(256)
*---------------------------------------------------------------
* statvfs() -- Get file system status
*
* path = (input) pathname of a link ("file") in the IFS.
* buf = (output) data structure containing file system info
*
* Returns 0 if successful, -1 upon error.
* (error information is returned via the "errno" variable)
*---------------------------------------------------------------
D statvfs PR 10I 0 ExtProc('statvfs64')
D path * value options(*string)
D buf like(ds_statvfs)
Thanks to Carsten Flensburg
|
|
Back
|
QUSCRTUQ & QLICVTTP & QUILNGTX
| |
QUSCRTUQ: Create user queue
QLICVTTP : Convert object type
QUILNGTX : Display long text
** Program . . : CBX1150
** Description : Test user queues - client function
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : February 19, 2004
**
**
** Program summary
** ---------------
**
** This program offers some simple templates for a number of the
** MI builtins and C library function used to address user queues
** - here's a list of all available functions:
**
** C library functions:
** 'enq' Enqueue
** 'deq' Dequeue
** 'deqi' Dequeue with indicator
** 'matqmsg' Materialize queue messages
** 'matqat' Materialize queue attributes
**
** MI builtins:
** '_ENQ' Enqueue
** '_DEQ' Dequeue
** '_DEQWAIT' Dequeue with wait
** '_MATQMSG' Materialize queue messages
** '_MATQAT' Materialize queue attributes
**
**
** Programmer's notes:
** Functionally user queues are very much the same as data queues: They
** provide asynchronous communication between programs, and the stored
** messages can be retrieved by arrival sequence or key.
**
** The major advantage of user queues over data queues is speed; they are
** faster than data queues. On the other hand user queues are a bit more
** complicated to put into action; you need to resolve a system pointer
** to the user queue to be able to call the various user queue functions
** and for example get acqainted with such constructs as bit-fields that
** enables you to reference single bits at field level.
**
** This program offers a number of examples of some - but not all - of
** the user queue functions, for you to use as a starting point in the
** event that you should want to include user queues in your tool box.
** You can find more information in the MI Functional Reference and the
** ILE C/C++ for iSeries Run-Time Library Functions manuals.
**
** To run this sample program compile it as described below, start a
** debug session, call it, and then step throug the program in the
** debugger:
**
** StrDbg Pgm( CBX1150 ) - Press F10
**
** Call Pgm( CBX1150 ) - Press F10 repeatedly
**
**
** Compile options:
** First, create the CBX115S service program. (Instructions can be
** found in the CBX115S source member.)
**
** CrtRpgMod Module( CBX1150 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX1150 )
** Module( CBX1150 )
** ActGrp( QILE )
** BndSrvPgm( CBX115S )
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt ) BndDir( 'QC2LE' )
**-- API Error Data Structure: -----------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D 1a
D AeExcpId 7a
D AeExcpDta 256a
**-- Global variables: -------------------------------------------------**
D UsrQuePtrF s * ProcPtr
D UsrQuePtrK s * ProcPtr
D MsgDeq s 10i 0
**
D EnqMsg s 1024a
D DeqMsg s 1024a
**-- Global constants: -------------------------------------------------**
D DeqGt c x'02'
D DeqLt c x'04'
D DeqNe c x'06'
D DeqEq c x'08'
D DeqGe c x'0A'
D DeqLe c x'0C'
**
D TimeDeqGt c x'02'
D TimeDeqLt c x'04'
D TimeDeqNe c x'06'
D TimeDeqEq c x'08'
D TimeDeqGe c x'0A'
D TimeDeqLe c x'0C'
**
D WaitDeq c x'10'
D WaitDeqGt c x'12'
D WaitDeqLt c x'14'
D WaitDeqNe c x'16'
D WaitDeqEq c x'18'
D WaitDeqGe c x'1A'
D WaitDeqLe c x'1C'
**-- Enqueue message prefix: -------------------------------------------**
D EnqMsgPfx Ds
D EpMsgLen 10i 0
D EpEnqKey 3a
**-- Dequeue message prefix: -------------------------------------------**
D DeqMsgPfx Ds
D DpTimStp 8a
D DqWaitTim 8a
D DqMsgLen 10i 0 Inz
D DqOption 1a
** DqAccSt1: 1; Bit weight 8
** DqAccSt2: 1; - - 4
** DqMPL : 1; - - 2
** DqWait4e: 1; - - 1
** DqKeyRel: 4; - - 8-1
D DqKey 3a
D DqKeyRtn Like( DqKey )
**-- Queue attributes: -------------------------------------------------**
D QueAtr Ds
1 D QaBytPrv 10i 0 Inz( %Size( QueAtr ))
D QaBytAvl 10i 0
9 D QaObjId 32a
D QaObjTyp 1a Overlay( QaObjId: 1 )
D QaObjSub 1a Overlay( QaObjId: *Next )
D QaObjNam 30a Overlay( QaObjId: *Next )
41 D QaCrtOptBf 4a
45 D 4a
49 D QaSpcSiz 10i 0
53 D QaSpcInzVal 1a
54 D QaPfrClsBf 4a
58 D 7a
65 D QaCtx * ProcPtr
81 D QaAccGrp * ProcPtr
97 D QaQueAtrBf 1a
98 D QaCurMaxMsg 10i 0
102 D QaCurMsgEnq 10i 0
106 D QaExtVal 10i 0
110 D QaKeyLen 5i 0
112 D QaMaxSizMsg 10i 0
116 D 1a
117 D QaMaxNbrExt 10i 0
121 D QaCurNbrExt 10i 0
125 D QaInzNbrMsg 10i 0
**-- Enqueue message: --------------------------------------------------**
D enqMI Pr ExtProc( '_ENQ' )
D QuePtr * ProcPtr
D MsgPfx 256a Options( *VarSize )
D MsgTxt 32767a Options( *VarSize )
**-- Dequeue message with wait: ----------------------------------------**
D deqwait Pr ExtProc( '_DEQWAIT' )
D MsgPfx 256a Options( *VarSize )
D MsgTxt 32767a Options( *VarSize )
D QuePtr * ProcPtr
129 **-- Enqueue message: --------------------------------------------------**
D enq Pr ExtProc( 'enq' )
D QuePtr * ProcPtr Value
D MsgPfx 256a Const Options( *VarSize )
D MsgTxt 32767a Const Options( *VarSize )
**-- Dequeue message: --------------------------------------------------**
D deq Pr ExtProc( 'deq' )
D MsgPfx 256a Options( *VarSize )
D MsgTxt 32767a Options( *VarSize )
D QuePtr * ProcPtr Value
**-- Dequeue message with indicator: -----------------------------------**
D deqi Pr 10i 0 ExtProc( 'deqi' )
D MsgPfx 296a Options( *VarSize )
D MsgTxt 32767a Options( *VarSize )
D QuePtr * ProcPtr Value
**-- Materialize queue attributes: -------------------------------------**
D matqat Pr ExtProc( 'matqat' )
D RcvAtr 128a
D QuePtr * ProcPtr Value
**-- Wait seconds: -----------------------------------------------------**
D sleep Pr 10i 0 ExtProc( 'sleep' )
D seconds 10u 0 Value
**-- Wait microseconds: ------------------------------------------------**
D usleep Pr 10i 0 ExtProc( 'usleep' )
D useconds 10u 0 Value
**-- Create user queue: ------------------------------------------------**
D CrtUsrQ Pr ExtPgm( 'QUSCRTUQ' )
D CuUsrQqual 20a Const
D CuExtAtr 10a Const
D CuQueTyp 1a Const
D CuKeyLen 10i 0 Const
D CuMaxMsgSiz 10i 0 Const
D CuInzNbrMsg 10i 0 Const
D CuAddNbrMsg 10i 0 Const
D CuPubAut 10a Const
D CuTxtDsc 50a Const
**
D CuRplQue 10a Const Options( *NoPass )
D CuError 32767a Options( *NoPass: *VarSize )
**
D CuQueDmn 10a Const Options( *NoPass )
D CuAlwPtr 10a Const Options( *NoPass )
**
D CuNbqExt 10i 0 Const Options( *NoPass )
D CuRclStg 1a Const Options( *NoPass )
**-- Get current number of queue entries: ------------------------------**
D GetCurNbrE Pr 10i 0
D PxQuePtr * ProcPtr
**-- Get system pointer: -----------------------------------------------**
D GetSysPtr Pr * ProcPtr
D PxObjNam 10a Const
D PxObjLib 10a Const
D PxObjTyp 10a Const
**-- Get MI time value: ------------------------------------------------**
D GetTimVal Pr 8a
D PxSeconds 10u 0 Const
**
**-- Mainline: ---------------------------------------------------------**
**
C CallP CrtUsrQ( 'USRQ QTEMP'
C : 'TESTUSRQ'
C : 'F'
C : *Zero
C : 1024
C : 256
C : 128
C : '*ALL'
C : 'Test user queue'
C : '*YES'
C : ApiError
C : '*USER'
C : '*NO'
C )
**
C CallP CrtUsrQ( 'USRQKEY QTEMP'
C : 'TESTUSRQ'
C : 'K'
C : 3
C : 1024
C : 256
C : 128
C : '*ALL'
C : 'Test user queue - key'
C : '*YES'
C : ApiError
C : '*USER'
C : '*NO'
C )
**
C Eval UsrQuePtrF = GetSysPtr( 'USRQ'
C : 'QTEMP'
C : '*USRQ'
C )
**
C If UsrQuePtrF <> *Null
**
C Eval UsrQuePtrK = GetSysPtr( 'USRQKEY'
C : 'QTEMP'
C : '*USRQ'
C )
**
C If UsrQuePtrK <> *Null
**
C ExSr TstEnqNoKey
C ExSr TstDeqNoKey
**
C ExSr TstEnqKey
C ExSr TstDeqKey
**
C ExSr TstEnqMiKey
C ExSr TstDeqKey
**
C ExSr TstEnqMiKey
C ExSr TstDeqiKey
**
C ExSr TstEnqKey
C ExSr TstDeqwKey
**
C EndIf
C EndIf
**
C Eval *InLr = *On
C Return
**
**-- Test enq no key: --------------------------------------------------**
C TstEnqNoKey BegSr
**
C Eval EnqMsg = 'Test FIFO message 1'
C Eval EpMsgLen = %Len( %TrimR( EnqMsg ))
**
C CallP enq( UsrQuePtrF: EnqMsgPfx: EnqMsg )
**
C EndSr
**-- Test enq key: -----------------------------------------------------**
C TstEnqKey BegSr
**
C Eval EnqMsg = 'Test key message 1'
C Eval EpEnqKey = 'KEY'
C Eval EpMsgLen = %Len( %TrimR( EnqMsg ))
**
C CallP enq( UsrQuePtrK: EnqMsgPfx: EnqMsg )
**
C EndSr
**-- Test enqMI key: ---------------------------------------------------**
C TstEnqMiKey BegSr
**
C Eval EnqMsg = 'Test key message 2'
C Eval EpEnqKey = 'KEY'
C Eval EpMsgLen = %Len( %TrimR( EnqMsg ))
**
C CallP enqMI( UsrQuePtrK: EnqMsgPfx: EnqMsg )
**
C EndSr
**-- Test deq no key: --------------------------------------------------**
C TstDeqNoKey BegSr
**
C Eval DqKey = *Blanks
C Eval DqOption = WaitDeq
**
C DoW GetCurNbrE( UsrQuePtrF ) > *Zero
**
C CallP(e) deq( DeqMsgPfx: DeqMsg: UsrQuePtrF )
**
C If Not %Error
C ExSr PrcUsrQe
C EndIf
**
C EndDo
**
C EndSr
**-- Test deq key: -----------------------------------------------------**
C TstDeqKey BegSr
**
C Eval DqKey = 'KEY'
C Eval DqOption = TimeDeqEq
C Eval DqWaitTim = GetTimVal( 5 )
**
C Do 3
**
C CallP(e) deq( DeqMsgPfx: DeqMsg: UsrQuePtrK )
**
C If Not %Error
C ExSr PrcUsrQe
**
C Else
C CallP usleep( 500000 )
C EndIf
**
C EndDo
**
C EndSr
**-- Test deqi key: ----------------------------------------------------**
C TstDeqiKey BegSr
**
C Eval DqOption = TimeDeqEq
C Eval DqKey = 'KEY'
**
C DoW GetCurNbrE( UsrQuePtrK ) > *Zero
**
C Eval MsgDeq = deqi( DeqMsgPfx
C : DeqMsg
C : UsrQuePtrK
C )
**
C If MsgDeq = 1
C ExSr PrcUsrQe
C EndIf
**
C CallP sleep( 1 )
C EndDo
**
C EndSr
**-- Test deqwait key: -------------------------------------------------**
C TstDeqwKey BegSr
**
C Eval DqKey = 'KEY'
C Eval DqOption = TimeDeqEq
C Eval DqWaitTim = GetTimVal( 7 )
**
C DoW GetCurNbrE( UsrQuePtrK ) > *Zero
**
C CallP(e) deqwait( DeqMsgPfx: DeqMsg: UsrQuePtrK )
**
C If Not %Error
C ExSr PrcUsrQe
C EndIf
**
C EndDo
**
C EndSr
**-- Process user queue entry: -----------------------------------------**
C PrcUsrQe BegSr
**
C Eval DeqMsg = %Subst( DeqMsg: 1: DqMsgLen )
**
C EndSr
**-- Get current number of queue entries: ------------------------------**
P GetCurNbrE B
D Pi 10i 0
D PxQuePtr * ProcPtr
**
C If PxQuePtr = *Null
C Return -1
C Else
**
C CallP(e) matqat( QueAtr: PxQuePtr )
**
C If %Error
C Return -1
**
C Else
C Return QaCurMsgEnq
C EndIf
C EndIf
**
P GetCurNbrE E
** Program . . : CBX1151
** Description : Test user queues - server function
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : February 19, 2004
**
**
** Program summary
** ---------------
**
** MI builtins:
** _ENQ Enqueue message Puts a message to the user queue
** specified. An optional key used
** at message retrieval time can be
** specified.
**
** The actual user queue is defined
** by a system pointer.
**
** _DEQWAIT Dequeue message Gets a message from the specified
** with wait user queue. The retrieval order
** is defined at queue creation time
** and includes first-in-first-out,
** last-in-first-out and by-key.
**
** The wait time is specified in the
** dequeue message prefix parameter.
** If a time-out occurs the builtin
** returns an exception to the
** calling program.
**
** The actual user queue is defined
** by a system pointer.
**
** C library function:
** cvthc Convert hex to Converts a character string to
** character its hexadecimal representation
** in the form of 4-bit sequences
** also known as nibbles.
**
**
** Sequence of events:
** 1. The put and get user queue names as well as the library they are
** located in are received as input paramters and a system pointer
** to each is resolved.
**
** 2. Being a server function the program then waits indefinetely for
** client requests to be received from the get user queue. To ensure
** that the right client receives the reply, a unique key is included
** in the request message structure. Also included is a request type
** defining the type of action to be performed by the server.
**
** 3. Once a request is received it is processed based on the request
** type. Two request types are supported.
**
** *CVTHEX will convert the received message string to its
** hexadecimal representation and put the converted string
** to the reply user queue and the retreived key from the
** request message structure is supplied as retrieval key.
**
** *STOP will end the server job immediately.
**
** 4. When a reply has been returned, the server will continue waiting
** indefinetely for the next request to arrive.
**
** 5. If the server job has been requested to stop processing, the
** wait loop is exited and the job is ended normally.
**
**
** Compile options:
** First, create the CBX115S service program. (Instructions can be
** found in the CBX115S source member.)
**
** CrtRpgMod Module( CBX1151 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX1151 )
** Module( CBX1151 )
** ActGrp( QILE )
** BndSrvPgm( CBX115S )
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt ) BndDir( 'QC2LE' )
**-- Global variables: -------------------------------------------------**
D RqsQuePtr s * ProcPtr
D RpyQuePtr s * ProcPtr
D RqsHdrSiz s 10i 0
**
D EnqMsg s 1024a
**
D DeqMsg Ds
D DmRpyKey 16a
D DmRqsTyp 8a
D DmRqsMsg 1000a
**-- Global constants: -------------------------------------------------**
D WaitDeq c x'10'
**-- Enqueue message prefix: -------------------------------------------**
D EnqMsgPfx Ds
D EqMsgLen 10i 0
D EqEnqKey 16a
**-- Dequeue message prefix: -------------------------------------------**
D DeqMsgPfx Ds
D DqTimStp 8a
D DqWaitTim 8a
D DqMsgLen 10i 0 Inz
D DqOption 1a
** DqAccSt1: 1; Bit weight 8
** DqAccSt2: 1; - - 4
** DqMPL : 1; - - 2
** DqWait4e: 1; - - 1
** DqKeyRel: 4; - - 8-1
D DqKey 16a
**-- Enqueue message: --------------------------------------------------**
D enq Pr ExtProc( '_ENQ' )
D QuePtr * ProcPtr
D MsgPfx 256a Options( *VarSize )
D MsgTxt 32767a Options( *VarSize )
**-- Dequeue message with wait: ----------------------------------------**
D deqwait Pr ExtProc( '_DEQWAIT' )
D MsgPfx 256a Options( *VarSize )
D MsgTxt 32767a Options( *VarSize )
D QuePtr * ProcPtr
**-- Convert hex to character: -----------------------------------------**
D cvthc Pr * ExtProc( 'cvthc' )
D * Value
D * Value
D 10I 0 Value
**-- Get system pointer: -----------------------------------------------**
D GetSysPtr Pr * ProcPtr
D PxObjNam 10a Const
D PxObjLib 10a Const
D PxObjTyp 10a Const
**-- Parameters: -------------------------------------------------------**
D PxRqsQueNam s 10a
D PxRpyQueNam s 10a
D PxQueLib s 10a
**
C *Entry Plist
C Parm PxRqsQueNam
C Parm PxRpyQueNam
C Parm PxQueLib
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval RqsQuePtr = GetSysPtr( PxRqsQueNam
C : PxQueLib
C : '*USRQ'
C )
**
C If RqsQuePtr <> *Null
**
C Eval RpyQuePtr = GetSysPtr( PxRpyQueNam
C : PxQueLib
C : '*USRQ'
C )
**
C If RpyQuePtr <> *Null
**
C DoU *InLr = *On
**
C ExSr DeqRqsMsg
**
C If *InLr = *Off
C ExSr PrcRqsMsg
C ExSr EnqRpyMsg
C EndIf
**
C EndDo
**
C EndIf
C EndIf
**
C Return
**
**-- Dequeue request message: ------------------------------------------**
C DeqRqsMsg BegSr
**
C Eval DqKey = *Blanks
C Eval DqOption = WaitDeq
**
C CallP(e) deqwait( DeqMsgPfx: DeqMsg: RqsQuePtr )
**
C If Not %Error
C Eval DeqMsg = %Subst( DeqMsg: 1: DqMsgLen )
C Eval EnqMsg = *Blanks
**
C If DmRqsTyp = '*STOP '
C Eval *InLr = *On
C EndIf
C EndIf
**
C EndSr
**-- Enqueue reply message: --------------------------------------------**
C EnqRpyMsg BegSr
**
C Eval EqEnqKey = DmRpyKey
C Eval EqMsgLen = %Len( %TrimR( EnqMsg ))
**
C CallP enq( RpyQuePtr: EnqMsgPfx: EnqMsg )
**
C EndSr
**-- Process request message: ------------------------------------------**
C PrcRqsMsg BegSr
**
C If DmRqsTyp = '*CVTHEX'
**
C CallP cvthc( %Addr( EnqMsg )
C : %Addr( DmRqsMsg )
C : 2 * ( DqMsgLen - RqsHdrSiz )
C )
**
C EndIf
**
C EndSr
**-- Initial processing: -----------------------------------------------**
C *InzSr BegSr
**
C Eval RqsHdrSiz = %Size( DmRpyKey ) +
C %Size( DmRqsTyp )
**
C EndSr
** Program . . : CBX1152
** Description : Test user queues - client function
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : February 19, 2004
**
**
** Program summary
** ---------------
**
** MI builtins:
** _ENQ Enqueue message Puts a message to the user queue
** specified. An optional key used
** at message retrieval time can be
** specified.
**
** The actual user queue is defined
** by a system pointer.
**
** _DEQWAIT Dequeue message Gets a message from the specified
** with wait user queue. The retrieval order
** is defined at queue creation time
** and includes first-in-first-out,
** last-in-first-out and by-key.
**
** The wait time is specified in the
** dequeue message prefix parameter.
** If a time-out occurs the builtin
** returns an exception to the
** calling program.
**
** The actual user queue is defined
** by a system pointer.
**
** _GENUUID Generate universal Returns a 16 byte token that is
** unique identifier guaranteed to be unique across
** all time and space - or as its
** name says, universally unique.
**
** User interface manager APIs:
** QUILNGTX Display long text Displays the text string passed
** to the API in a pop-up window.
** Optionally a panel title can be
** retrieved from a message file.
**
** Maximum string length is 15360k.
**
** Message handling API:
** QMHSNDPM Send program message Sends a message to a program stack
** entry (current, previous, etc.) or
** an external message queue.
**
** Both messages defined in a message
** file and immediate messages can be
** used. For specific message types
** only one or the other is allowed.
**
** QMHRCVPM Receive program Returns information describing
** message the selected message in a call
** message queue or, as in this
** case, an external message queue.
**
**
** Sequence of events:
** 1. The put and get user queue names as well as the library they are
** located in are received as input paramters and a system pointer
** to each is resolved.
**
** 2. An inquiry message is sent to the external message queue, waiting
** for an input string to process. Upon receiving an actual reply,
** a unique key is generated to be included with the request message
** to ensure correct retrieval of the corresponding reply, and the
** request message is put to the request user queue.
**
** 3. Next the dequeue parameters are set, a time-out value of 5 seconds
** and the retrieval key that the reply was associated with in step 2.
** If a time-out occurs an informational message is displayed in a
** window, otherwise the result of the hexadecimal conversion of the
** input string is displayed.
**
** 4. If an empty reply is received in step 2 a 'terminate processing'
** message is sent to the server job and this program returns control
** to its caller, to delete the user queues involved and end the test
** application.
**
**
** Programmer's notes:
** User reports have surfaced, indicating that the GENUUID function
** - under certain circumstances - might have a problem generating a
** truly unique identifier on multi-processor iSeries machines.
**
** But apparently this has not yet lead to the opening of an APAR so
** there is currently no conclusive information available on this
** matter.
**
** The message dialogue developed for the purpose of this user queue
** test application is by no means adequate for a genuine production
** environment.
**
** In real life it is crucial to invest the time necessary to develop
** a robust and flexible data protocol up front, covering some of the
** following aspects:
**
** - Request and reply message indentification
** - Message version identification
** - Error code and message reporting
** - Message definition design (proprietary or standard)
** - Expanding list support (to avoid message length constraints)
** - National language support
** - Normalization level of message record formats
**
** And when dealing with some of the above questions it is in many
** cases worth considering to what extent XML would offer a useful
** solution.
**
**
** Compile options:
** First, create the CBX115S service program. (Instructions can be
** found in the CBX115S source member.)
**
** CrtRpgMod Module( CBX1152 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX1152 )
** Module( CBX1152 )
** ActGrp( QILE )
** BndSrvPgm( CBX115S )
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt ) BndDir( 'QC2LE' )
**-- API error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0
D AeExcpId 7a
D 1a
D AeExcpDta 128a
**-- Global variables: -------------------------------------------------**
D RqsQuePtr s * ProcPtr
D RpyQuePtr s * ProcPtr
D MsgKey s 4a
D MsgDta s 1024a Varying
**
D DeqMsg s 1024a
**
D EnqMsg Ds
D EmRpyKey 16a
D EmRqsTyp 8a
D EmRqsMsg 1000a
**-- Global constants: -------------------------------------------------**
D TimeDeqEq c x'08'
**-- Enqueue message prefix: -------------------------------------------**
D EnqMsgPfx Ds
D EqMsgLen 10i 0
D EqEnqKey 16a
**-- Dequeue message prefix: -------------------------------------------**
D DeqMsgPfx Ds
D DqTimStp 8a
D DqWaitTim 8a
D DqMsgLen 10i 0 Inz
D DqOption 1a
** DqAccSt1: 1; Bit weight 8
** DqAccSt2: 1; - - 4
** DqMPL : 1; - - 2
** DqWait4e: 1; - - 1
** DqKeyRel: 4; - - 8-1
D DqKey 16a
**-- UUID template: ----------------------------------------------------**
D UUID_template Ds
D UtBytPrv 10u 0 Inz( %Size( UUID_template ))
D UtBytAvl 10u 0
D 8a Inz( *Allx'00' )
D UUID 16a
**-- Message information structure: ------------------------------------**
D RCVM0100 Ds
D R1BytPrv 10i 0
D R1BytAvl 10i 0
D R1MsgSev 10i 0
D R1MsgId 7a
D R1MsgTyp 2a
D R1MsgKey 4a
D 7a
D R1CcsIdCnvSts 10i 0
D R1CcsIdDta 10i 0
D R1MsgLen 10i 0
D R1MsgLenAvl 10i 0
D R1MsgRpy 1024a
**-- Enqueue: ----------------------------------------------------------**
D enq Pr ExtProc( '_ENQ' )
D QuePtr * ProcPtr
D MsgPfx 256a Options( *VarSize )
D MsgTxt 32767a Options( *VarSize )
**-- Dequeue with wait: ------------------------------------------------**
D deqwait Pr ExtProc( '_DEQWAIT' )
D MsgPfx 256a Options( *VarSize )
D MsgTxt 32767a Options( *VarSize )
D QuePtr * ProcPtr
**-- Generate universal unique identifier: -------------------------- --**
D GenUuid Pr ExtProc( '_GENUUID' )
D UUID_template * Value
**-- Send program message: ---------------------------------------------**
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D SpMsgId 7a Const
D SpMsgFq 20a Const
D SpMsgDta 512a Const Options( *VarSize )
D SpMsgDtaLen 10i 0 Const
D SpMsgTyp 10a Const
D SpCalStkE 10a Const Options( *VarSize )
D SpCalStkCtr 10i 0 Const
D SpMsgKey 4a
D SpError 512a Options( *VarSize )
**
D SpCalStkElen 10i 0 Const Options( *NoPass )
D SpCalStkEq 20a Const Options( *NoPass )
D SpDspWait 10i 0 Const Options( *NoPass )
**
D SpCalStkEtyp 20a Const Options( *NoPass )
D SpCcsId 10i 0 Const Options( *NoPass )
**-- Receive program message: ------------------------------------------**
D RcvPgmMsg Pr ExtPgm( 'QMHRCVPM' )
D RpRcvVar 32767a Options( *VarSize )
D RpRcvVarLen 10i 0 Const
D RpFmtNam 10a Const
D RpCalStkE 256a Const Options( *VarSize )
D RpCalStkCtr 10i 0 Const
D RpMsgTyp 10a Const
D RpMsgKey 4a Const
D RpWait 10i 0 Const
D RpMsgAct 10a Const
D RpError 32767a Options( *VarSize )
**
D RpCalStkElen 10i 0 Const Options( *NoPass )
D RpCalStkEq 20a Const Options( *NoPass )
**
D RpCalStkEtyp 20a Const Options( *NoPass )
D RpCcsId 10i 0 Const Options( *NoPass )
**-- Display long text: ------------------------------------------------**
D DspLngTxt Pr ExtPgm( 'QUILNGTX' )
D DtLngTxt 1024a Const Options( *VarSize )
D DtLngTxtLen 10i 0 Const
D DtMsgId 7a Const
D DtMsgF 20a Const
D DtError 10i 0 Const
**-- Get system pointer: -----------------------------------------------**
D GetSysPtr Pr * ProcPtr
D PxObjNam 10a Const
D PxObjLib 10a Const
D PxObjTyp 10a Const
**-- Get MI time value: ------------------------------------------------**
D GetTimVal Pr 8a
D PxSec 10u 0 Const
**-- Parameters: -------------------------------------------------------**
D PxRqsQueNam s 10a
D PxRpyQueNam s 10a
D PxQueLib s 10a
**
C *Entry Plist
C Parm PxRqsQueNam
C Parm PxRpyQueNam
C Parm PxQueLib
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval RqsQuePtr = GetSysPtr( PxRqsQueNam
C : PxQueLib
C : '*USRQ'
C )
**
C If RqsQuePtr <> *Null
**
C Eval RpyQuePtr = GetSysPtr( PxRpyQueNam
C : PxQueLib
C : '*USRQ'
C )
**
C If RpyQuePtr <> *Null
**
C DoU *InLr = *On
**
C ExSr GetRqsMsg
C ExSr EnqRqsMsg
**
C If *InLr = *Off
C ExSr DeqRpyMsg
C EndIf
**
C EndDo
**
C EndIf
C EndIf
**
C Return
**
**-- Enqueue request message: ------------------------------------------**
C EnqRqsMsg BegSr
**
C Callp GenUuid( %Addr( UUID_template ))
**
C Eval EqEnqKey = *Blanks
C Eval EmRpyKey = UUID
C Eval EqMsgLen = %Len( %TrimR( EnqMsg ))
**
C CallP enq( RqsQuePtr: EnqMsgPfx: EnqMsg )
**
C EndSr
**-- Dequeue reply message: --------------------------------------------**
C DeqRpyMsg BegSr
**
C Eval DqKey = UUID
C Eval DqOption = TimeDeqEq
C Eval DqWaitTim = GetTimVal( 5 )
**
C CallP(e) deqwait( DeqMsgPfx: DeqMsg: RpyQuePtr )
**
C If %Error
C Exsr HdlRpyTmo
**
C Else
C Exsr DspRpyMsg
C EndIf
**
C EndSr
**-- Handle reply timeout: ---------------------------------------------**
C HdlRpyTmo BegSr
**
C Eval MsgKey = *Blanks
**
C CallP RcvPgmMsg( RCVM0100
C : %Size( RCVM0100 )
C : 'RCVM0100'
C : '*'
C : *Zero
C : '*LAST'
C : MsgKey
C : -1
C : '*REMOVE'
C : ApiError
C )
**
C Eval MsgDta = 'The get user queue ' +
C 'message timed out. ' +
C 'Please check that the ' +
C 'server job is active.'
**
C CallP(e) DspLngTxt( MsgDta
C : %Len( MsgDta )
C : *Blanks
C : *Blanks
C : *Zero
C )
**
C EndSr
**-- Display reply message: --------------------------------------------**
C DspRpyMsg BegSr
**
C Eval MsgDta = %TrimR( EmRqsMsg ) + ' -> ' +
C %SubSt( DeqMsg: 1: DqMsgLen )
**
C CallP(e) DspLngTxt( MsgDta
C : %Len( MsgDta )
C : *Blanks
C : *Blanks
C : *Zero
C )
**
C EndSr
**-- Get request message: ----------------------------------------------**
C GetRqsMsg BegSr
**
C Eval MsgDta = 'Please enter string ' +
C 'to be converted to ' +
C 'hex. To stop test just ' +
C 'press enter.'
**
C CallP SndPgmMsg( *Blanks
C : *Blanks
C : MsgDta
C : %Len( MsgDta )
C : '*INQ'
C : '*EXT'
C : *Zero
C : MsgKey
C : ApiError
C )
**
C CallP RcvPgmMsg( RCVM0100
C : %Size( RCVM0100 )
C : 'RCVM0100'
C : '*'
C : *Zero
C : '*RPY'
C : MsgKey
C : -1
C : '*OLD'
C : ApiError
C )
**
C Eval R1MsgRpy = %Subst( R1MsgRpy: 1: R1MsgLen )
**
C If R1MsgRpy = '*N'
C Eval EmRqsTyp = '*STOP'
C Eval *InLr = *On
**
C Else
C Eval EmRqsTyp = '*CVTHEX'
C Eval EmRqsMsg = R1MsgRpy
C EndIf
**
C EndSr
** Program . . : CBX115S
** Description : Test user queues - service functions
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : February 19, 2004
**
**
** Program summary
** ---------------
**
** Object-related API:
** QLICVTTP Convert object type Convert an iSeries object type to
** or from hexadecimal format.
**
** C library function:
** rslvsp Resolve system Creates a system pointer to the
** pointer object specified by the input
** parameters. Only a system state
** program is allowed to generate
** an authorized system pointer.
**
** mitime Create an _MI_Time Creates an _MI_Time value from
** value the individual time durations
** specified.
**
** Service program procedures:
** GetSysPtr Get system pointer Based on object name, library and
** object type a system pointer to
** the object is generated and
** returned to the caller.
**
** GetTimVal Get MI time value Generates an MI time value from
** the specified number of seconds.
**
** Programmer's notes:
** RPG/IV has no explicit support of system pointers - but defining an
** uninitialized procedure pointer will make the RPG compiler create
** an open pointer, capable of storing any type of iSeries pointer.
**
** Though not very likely - due to the many production programs already
** exploiting this feature - it is possible that a future introduction
** of true system pointer support to RPG/IV might disable this "hidden"
** system pointer support.
**
** If used in production programs, you should therefore document the
** use of this feature very carefully to ensure that you can take the
** appropriate evasive actions if necessary.
**
**
** Compile options required:
** CrtRpgMod CBX115S
**
** CrtSrvPgm CBX115S +
** Module( CBX115S ) +
** Export( *ALL ) +
** ActGrp( *CALLER )
**
**
**-- Header specifications: --------------------------------------------**
H NoMain BndDir( 'QC2LE' )
**-- API Error Data Structure: -----------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D 1a
D AeExcpId 7a
D AeExcpDta 256a
**-- Convert object type to hex: ---------------------------------------**
D CvtObjTyp Pr ExtPgm( 'QLICVTTP' )
D CtCnvOpt 10a Const
D CtObjSym 10a Const
D CtObjHex 2a
D CtError 32767a Options( *VarSize )
**-- Get system pointer: -----------------------------------------------**
D GetSysPtr Pr * ProcPtr
D PxObjNam 10a Const
D PxObjLib 10a Const
D PxObjTyp 10a Const
**-- Get MI time value: ------------------------------------------------**
D GetTimVal Pr 8a
D PxSec 10u 0 Const
**-- Check object existence: -------------------------------------------**
D ObjExist Pr n
D PxObjNam 10a Const
D PxObjLib 10a Const
D PxObjTyp 10a Const
**-- Resolve system pointer: -------------------------------------------**
D rslvsp Pr * ProcPtr ExtProc( 'rslvsp' )
D PxObjTyp 2a Value
D PxObjNam * Value Options( *String )
D PxObjLib * Value Options( *String )
D PxAutReq 2a Value
**-- mitime - create an _MI_Time value from components: ----------------**
D mitime Pr ExtProc( 'mitime' )
D PxDelay 8a
D PxHours 10u 0 Value
D PxMin 10u 0 Value
D PxSec 10u 0 Value
D PxMs 10u 0 Value
**-- Get system pointer: -----------------------------------------------**
P GetSysPtr B Export
D Pi * ProcPtr
D PxObjNam 10a Const
D PxObjLib 10a Const
D PxObjTyp 10a Const
**-- Local variables:
D SysPtr s * ProcPtr
D ObjTypHex s 2a
**
C If ObjExist( PxObjNam: PxObjLib: PxObjTyp )
**
C Callp CvtObjTyp( '*SYMTOHEX'
C : PxObjTyp
C : ObjTypHex
C : ApiError
C )
**
C If AeBytAvl = *Zero
**
C Eval SysPtr = rslvsp( ObjTypHex
C : PxObjNam
C : PxObjLib
C : x'0000'
C )
**
C EndIf
C EndIf
**
C Return SysPtr
**
P GetSysPtr E
**-- Get MI time value: ------------------------------------------------**
P GetTimVal B Export
D Pi 8a
D PxSec 10u 0 Const
**-- time parameter:
D PxDelay s 8a
**
C CallP mitime( PxDelay
C : 0
C : 0
C : PxSec
C : 0
C )
**
C Return PxDelay
**
P GetTimVal E
**-- Check object existence: -------------------------------------------**
P ObjExist B Export
D Pi n
D PxObjNam 10a Const
D PxObjLib 10a Const
D PxObjTyp 10a Const
**-- Retrieve object description:
D RoData Ds
D RoBytRtn 10i 0
D RoBytAvl 10i 0
D RoDtaLgt s 10i 0 Inz( %Size( RoData ))
D RoFmtNam s 8a Inz( 'OBJD0100' )
D RoObjQ s 20a
D RoObjTyp s 10a
**
C Eval RoObjQ = PxObjNam + PxObjLib
**
C Call 'QUSROBJD'
C Parm RoData
C Parm RoDtaLgt
C Parm RoFmtNam
C Parm RoObjQ
C Parm PxObjTyp RoObjTyp
C Parm ApiError
**
C Return ( AeBytAvl = *Zero )
**
P ObjExist E
/* Program . . : CBX115 */
/* Description : User queue example */
/* Author . . : Carsten Flensburg */
/* Published . : Club Tech iSeries Programming Tips Newsletter */
/* Date . . . : February 19, 2004 */
/* */
/* Program function: Initialize, run and clean up user queue */
/* example. */
/* */
/* Programmer's notes: */
/* Submit of the server job should occur through a job queue */
/* ensuring immediate activation of the server job, otherwise */
/* the user queue driven dialogue between the server and client */
/* jobs will not be possible. */
/* */
/* To run the user queue test application simply compile the */
/* involved objects as described in each source header and */
/* eventually call this program. */
/* */
/* Compile options: */
/* First, create the CRTUSRQ command from the January 29, 2004 */
/* issue of Club Tech iSeries Programming Tips Newsletter. */
/* CrtClPgm Pgm( CBX115 ) */
/* SrcFile( QCLSRC ) */
/* SrcMbr( *PGM ) */
/* */
Pgm
/*-- Global variables: ---------------------------------------------*/
Dcl &JobNbr *Char 10
Dcl &UsrQueNamF *Char 10 'USQF'
Dcl &UsrQueNamK *Char 10 'USQK'
Dcl &UsrQueLib *Char 10
/*-- Global error monitoring: --------------------------------------*/
MonMsg CPF0000 *N GoTo Error
/*-- Mainline -------------------------------------------------------*/
RtvJobA Nbr( &JobNbr ) CurLib( &UsrQueLib )
ChgVar &UsrQueNamF ( &UsrQueNamF *Tcat &JobNbr )
ChgVar &UsrQueNamK ( &UsrQueNamK *Tcat &JobNbr )
If ( &UsrQueLib = '*NONE' ) ChgVar &UsrQueLib 'QGPL'
DltUsrQ UsrQ( &UsrQueLib/&UsrQueNamF )
MonMsg CPF2105 *N RcvMsg MsgType( *EXCP ) Rmv( *YES )
DltUsrQ UsrQ( &UsrQueLib/&UsrQueNamK )
MonMsg CPF2105 *N RcvMsg MsgType( *EXCP ) Rmv( *YES )
CrtUsrQ UsrQ( &UsrQueLib/&UsrQueNamF ) +
ExtAtr( USRQFIFO ) +
MaxLen( 1024 ) +
Size( 256 ) +
IncrSize( 128 ) +
Text( 'User queue FIFO test' )
CrtUsrQ UsrQ( &UsrQueLib/&UsrQueNamK ) +
ExtAtr( USRQKEYED ) +
Seq( *KEYED ) +
KeyLen( 16 ) +
MaxLen( 1024 ) +
Size( 256 ) +
IncrSize( 128 ) +
Text( 'User queue keyed test' )
/*-- Submit server function: --*/
SbmJob Cmd( Call Pgm( CBX1151 ) +
Parm( &UsrQueNamF +
&UsrQueNamK +
&UsrQueLib +
)) +
Job( USRQSVR ) +
JobD( *USRPRF ) +
JobQ( *JOBD )
/*-- Run client function: --*/
Call CBX1152 Parm( &UsrQueNamF +
&UsrQueNamK +
&UsrQueLib +
)
SndPgmMsg MsgId( CPF9897 ) +
MsgF( QCPFMSG ) +
MsgDta( 'Terminating server job.' ) +
ToPgmQ( *EXT ) +
MsgType( *STATUS )
DlyJob 1
DltUsrQ UsrQ( &UsrQueLib/&UsrQueNamF )
DltUsrQ UsrQ( &UsrQueLib/&UsrQueNamK )
SndPgmMsg Msg( 'User queue test completed normally.' ) +
MsgType( *COMP )
Return:
Return
/*-- Error processor ------------------------------------------------*/
Error:
Call QMHMOVPM ( ' ' +
'*DIAG' +
x'00000001' +
'*PGMBDY ' +
x'00000001' +
x'0000000800000000' +
)
Call QMHRSNEM ( ' ' +
x'0000000800000000' +
)
EndPgm:
EndPgm
Thanks to Carsten Flensburg and
Club Tech iSeries Programming Tips Newsletter
|
|
Back
|
QP0LROR & QlgLstat & QSPRILSP
| |
QP0LROR: Retrieve object references
QlgLstat : Get file or link information
QSPRILSP : Retrieve identity of last spooled file created
** Program . . : CBX116
** Description : Display IFS object locks
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : March 25, 2004
**
**
** Program summary
** ---------------
**
** Unix type APIs:
** QP0LROR Retrieve object For specific IFS objects access
** references or lock information is retrieved.
**
** This information includes the
** type of lock or access as well
** as a list of the jobs holding the
** lock(s).
**
** An IFS object can, however, be
** flagged as "in use" without a
** specific job being identified
** as currently holding a lock.
**
** Likewise, the browsing of an IFS
** stream file does not necessarily
** generate a lock or set the object
** in use indicator.
**
** QlgLstat Get file or link Gets status information about the
** information specified directory entry and puts
** it in the structure pointed to by
** the pBuf parameter.
**
** The path name parameter includes
** NLS attributes (National Language
** Support) enabling the API to take
** these into account when resolving
** the actual IFS object.
**
** Spooled file API:
** QSPRILSP Retrieve identity of Returns the subset of spooled file
** last spooled file attributes that uniquely identifies
** created the last spooled file created in
** the current job.
**
** Work management APIs:
** QUSRJOBI Retrieve job Retrieves a variety of specific
** information information about a job.
**
** The information is grouped in the
** various formats available.
**
** Message handling API:
** QMHSNDPM Send program message Sends a message to a program stack
** entry (current, previous, etc.) or
** an external message queue.
**
** Both messages defined in a message
** file and immediate messages can be
** used. For specific message types
** only one or the other is allowed.
**
** C library function:
** system Run system command Executes a system command. In the
** event of an resulting error the
** error message ID is exported in
** the _EXCP_MSGID variable.
**
** Sequence of events:
** 1. The existence of the specified IFS object is verified using
** the lstat unix function and if an error is returned during
** this process, an escape message is sent back to the caller.
**
** 2. Storage is allocated for the Retrieve object reference API return
** variable and the API is called. If there's more object reference
** information available than allocated, sufficient storage is
** reallocated and the API is called again.
**
** 3. The retrieved information is formatted and written to the printer
** file. The printer file is closed and the allocated storage is
** released.
**
** 4. If the command is running in batch or a printed list was requested,
** a completion message is sent to inform the caller that list is now
** available - otherwise the generated spooled file is displayed, and
** subsequently deleted.
**
**
** Programmer's notes:
** Both the QP0LROR (Retrieve object references) and QSPRILSP (Retrieve
** identity of last spooled file created) were introduced with V5R2 and
** this API example will therefore not be available to earlier releases.
**
** QP0LROR documentation and comprehensive usage notes can be found here:
** http://as400bks.rochester.ibm.com/iseries/v5r2/ic2924/info/apis/qp0lror.htm
**
** The QP0LROR return format RORO0100 is not used in this utility, but
** a sample of how to use it and retrieve its information is included
** in the non-referenced subroutine RtvObjRef1 and PrcObjRef1.
**
**
** Compile options:
**
** CrtRpgMod Module( CBX116 ) DbgView( *LIST )
**
** CrtPgm Pgm( CBX116 )
** Module( CBX116 )
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt ) BndDir( 'QC2LE' )
**-- Printer file: -----------------------------------------------------**
FQSYSPRT O F 132 Printer InfDs( PrtLinInf ) OflInd( *InOf )
F UsrOpn
**-- Printer file information: -----------------------------------------**
D PrtLinInf Ds
D PlOvfLin 5i 0 Overlay( PrtLinInf: 188 )
D PlCurLin 5i 0 Overlay( PrtLinInf: 367 )
D PlCurPag 5i 0 Overlay( PrtLinInf: 369 )
**-- System information: -----------------------------------------------**
D SDs
D PsPgmNam *Proc
**-- Global declarations: ----------------------------------------------**
D Time s 6s 0
D Idx s 10u 0
D BytAlc s 10u 0
D NbrRcds s 10u 0
D MsgKey s 4a
D ErrTxt s 256a Varying
**
D IfsObj s 112a
D ObjUse s 4a
D ChkUsr s 10a
**
D CurCcsId c 0
D CurCtrId c x'0000'
D CurLngId c x'000000'
D ChrDlm1 c 0
**-- Api error data structure: -----------------------------------------**
D ApiError Ds
D AeBytPrv 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0 Inz
D AeMsgId 7a
D 1a
D AeMsgDta 128a
**-- system function error id: -----------------------------------------**
D SysError s 7a Import( '_EXCP_MSGID' )
**-- Api path: ---------------------------------------------------------**
D ApiPath Ds
D ApCcsId 10i 0 Inz( CurCcsId )
D ApCtrId 2a Inz( CurCtrId )
D ApLngId 3a Inz( CurLngId )
D 3a Inz( *Allx'00' )
D ApPthTypI 10i 0 Inz( ChrDlm1 )
D ApPthNamLen 10i 0
D ApPthNamDlm 2a Inz( '/ ' )
D 10a Inz( *Allx'00' )
D ApPthNam 1024a
**-- Object reference information: --------------------------------------**
D RORO0100 Ds Based( pObjRef )
D R1BytRtn 10u 0
D R1BytAvl 10u 0
D R1OfsSmpRef 10u 0
D R1LenSmpRef 10u 0
D R1RefCnt 10u 0
D R1InUseI 10u 0
**
D RORO0200 Ds Based( pObjRef )
D R2BytRtn 10u 0
D R2BytAvl 10u 0
D R2RefCnt 10u 0
D R2InUseI 10u 0
D R2OfsSmpRef 10u 0
D R2LenSmpRef 10u 0
D R2OfsExtRef 10u 0
D R2LenExtRef 10u 0
D R2OfsJobLst 10u 0
D R2NbrJobRtn 10u 0
D R2NbrJobAvl 10u 0
**-- Job using object structure: ---------------------------------------**
D JobUsgObj Ds Based( pJobUsgObj )
D JuDplSmpRef 10u 0
D JuLenSmpRef 10u 0
D JuDplExtRef 10u 0
D JuLenExtRef 10u 0
D JuDplNxtJobE 10u 0
D JuJobNam 10a
D JuJobUsr 10a
D JuJobNbr 6a
**-- Simple object reference types structure: --------------------------**
D SmpObjRef Ds Based( pSmpObjRef )
D SoReadOnly 10u 0
D SoWrtOnly 10u 0
D SoReadWrt 10u 0
D SoExecute 10u 0
D SoShrRdOnly 10u 0
D SoShrWrtOnly 10u 0
D SoShrRdWrt 10u 0
D SoShrNoRdWrt 10u 0
D SoAtrLck 10u 0
D SoSavLck 10u 0
D SoSavLckInt 10u 0
D SoLnkChgLck 10u 0
D SoChkOut 10u 0
D SoChkOutUsrNm 10a
D 2a
**-- Extended object reference types structure: ------------------------**
D ExtObjRef Ds Based( pExtObjRef )
D XoRdOnShrRdOn 10u 0
D XoRdOnShrWtOn 10u 0
D XoRdOnShrRdWt 10u 0
D XoRdOnShrNoRW 10u 0
D XoWtOnShrRdOn 10u 0
D XoWtOnShrWtOn 10u 0
D XoWtOnShrRdWt 10u 0
D XoWtOnShrNoRW 10u 0
D XoRWonShrRdOn 10u 0
D XoRWonShrWtOn 10u 0
D XoRWonShrRdWt 10u 0
D XoRWonShrNoRW 10u 0
D XoExOnShrRdOn 10u 0
D XoExOnShrWtOn 10u 0
D XoExOnShrRdWt 10u 0
D XoExOnShrNoRW 10u 0
D XoXRonShrRdOn 10u 0
D XoXRonShrWtOn 10u 0
D XoXRonShrRdWt 10u 0
D XoXRonShrNoRW 10u 0
D XoAtrLck 10u 0
D XoSavLck 10u 0
D XoSavLckInt 10u 0
D XoLnkChgLck 10u 0
D XoCurDir 10u 0
D XoRootDir 10u 0
D XoFilSvrRef 10u 0
D XoFilSvrWrkDi 10u 0
D XoChkOut 10u 0
D XoChkOutUsrNm 10a
D 2a
**-- Spooled file information: -----------------------------------------**
D SPRL0100 Ds
D SiBytRtn 10i 0
D SiBytAvl 10i 0
D SiSplfNam 10a
D SiJobNam 10a
D SiUsrNam 10a
D SiJobNbr 6a
D SiSplfNbr 10i 0
D SiJobSysNam 8a
D SiSplfCrtDat 7a
D 1a
D SiSplfCrtTim 6a
**-- File stat-structure: ----------------------------------------------**
D Buf Ds Align
D st_mode 10u 0
D st_ino 10u 0
D st_nlink 5u 0
D 2a
D st_uid 10u 0
D st_gid 10u 0
D st_size 10i 0
D st_atime 10i 0
D st_mtime 10i 0
D st_ctime 10i 0
D st_dev 10u 0
D st_blksize 10u 0
D st_allocsize 10u 0
D st_objtype 11a
D 1a
D st_codepage 5u 0
D st_reserv1 62a
D st_ino_gen_id 10u 0
**
D pBuf s * Inz( %Addr( Buf ))
**-- Get file or link information: -------------------------------------**
D lstat Pr 10i 0 ExtProc( 'QlgLstat' )
D PthStr 4096a Const Options( *VarSize )
D Buf * Value
**-- Retrieve object references: ---------------------------------------**
D RtvObjRef Pr ExtPgm( 'QP0LROR' )
D RoRcvVar 65535a Options( *VarSize )
D RoRcvVarLen 10u 0 Const
D RoFmtNam 8a Const
D RoPthStr 4096a Const Options( *VarSize )
D RoError 32767a Options( *VarSize: *NoPass)
**-- Retrieve job information: -----------------------------------------**
D RtvJobInf Pr ExtPgm( 'QUSRJOBI' )
D RiRcvVar 32767a Options( *VarSize )
D RiRcvVarLen 10i 0 Const
D RiFmtNam 8a Const
D RiJobNamQ 26a Const
D RiJobIntId 16a Const
D RiError 32767a Options( *NoPass: *VarSize )
**-- Send program message: ---------------------------------------------**
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D SpMsgId 7a Const
D SpMsgFq 20a Const
D SpMsgDta 128a Const
D SpMsgDtaLen 10i 0 Const
D SpMsgTyp 10a Const
D SpCalStkE 10a Const Options( *VarSize )
D SpCalStkCtr 10i 0 Const
D SpMsgKey 4a
D SpError 10i 0 Const
**-- Retrieve last spooled file identity: ------------------------------**
D RtvLstSplfId Pr ExtPgm( 'QSPRILSP' )
D RsRcvVar 32767a Options( *VarSize )
D RsRcvVarLen 10i 0 Const
D RsFmtNam 8a Const
D RsError 32767a Options( *VarSize )
**-- Run system command: -----------------------------------------------**
D system Pr 10i 0 ExtProc( 'system' )
D command * Value Options( *String )
**-- Get job type: -----------------------------------------------------**
D GetJobTyp Pr 1a
**-- Send escape message: ----------------------------------------------**
D SndEscMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Send completion message: ------------------------------------------**
D SndCmpMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- Error identification: ---------------------------------------------**
D errno Pr 10i 0
D strerror Pr 128a Varying
**-- Parameters: -------------------------------------------------------**
D PxPthNam s 300a Varying
D PxOutOpt s 3a
**
C *Entry Plist
C Parm PxPthNam
C Parm PxOutOpt
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval ApPthNam = PxPthNam
C Eval ApPthNamLen = %Len( PxPthNam )
**
C If lstat( ApiPath
C : pBuf
C ) = -1
**
C CallP SndEscMsg( %Char( Errno ) + ': ' + Strerror )
C Else
**
C Open QSYSPRT
**
C Eval BytAlc = 65535
C Eval pObjRef = %Alloc( BytAlc )
**
C DoU R2BytAvl <= BytAlc
**
C If R2BytAvl > BytAlc
C Eval BytAlc = R2BytAvl
C Eval pObjRef = %ReAlloc( pObjRef: BytAlc )
C EndIf
**
C CallP(e) RtvObjRef( RORO0200
C : BytAlc
C : 'RORO0200'
C : ApiPath
C : ApiError
C )
**
C If %Error
C CallP SndEscMsg( 'Release must be V5R2 or higher.')
C EndIf
C EndDo
**
C If AeBytAvl = *Zero
C ExSr PrcObjRef2
C EndIf
**
C DeAlloc pObjRef
**
C Close QSYSPRT
**
C If PxOutOpt = 'DSP' And
C GetJobTyp() = 'I'
C ExSr DspLst
**
C Else
C ExSr WrtLst
C EndIf
C EndIf
**
C Eval *InLr = *On
C Return
**
**-- Display list: -----------------------------------------------------**
C DspLst BegSr
**
C CallP RtvLstSplfId( SPRL0100
C : %Size( SPRL0100 )
C : 'SPRL0100'
C : ApiError
C )
C
**
C CallP system( 'DSPSPLF ' +
C 'FILE(' + %Trim( SiSplfNam ) + ') ' +
C 'JOB(' + %Trim( SiJobNbr ) + '/' +
C %Trim( SiUsrNam ) + '/' +
C %Trim( SiJobNam ) + ') ' +
C 'SPLNBR(' + %Char( SiSplfNbr ) + ')'
C )
**
C CallP system( 'DLTSPLF ' +
C 'FILE(' + %Trim( SiSplfNam ) + ') ' +
C 'JOB(' + %Trim( SiJobNbr ) + '/' +
C %Trim( SiUsrNam ) + '/' +
C %Trim( SiJobNam ) + ') ' +
C 'SPLNBR(' + %Char( SiSplfNbr ) + ')'
C )
**
C EndSr
**-- Write list: -------------------------------------------------------**
C WrtLst BegSr
**
C CallP SndCmpMsg( 'List has been printed.' )
**
C EndSr
**-- Retrieve object references - format RORO0100: ---------------------**
C RtvObjRef1 BegSr
**
**-- Not referenced - included only as a sample!
**
C Eval BytAlc = 65535
C Eval pObjRef = %Alloc( BytAlc )
**
C DoU R1BytAvl <= BytAlc
**
C If R1BytAvl > BytAlc
C Eval BytAlc = R1BytAvl
C Eval pObjRef = %ReAlloc( pObjRef: BytAlc )
C EndIf
**
C CallP RtvObjRef( RORO0100
C : BytAlc
C : 'RORO0100'
C : ApiPath
C : ApiError
C )
**
C EndDo
**
C If AeBytAvl = *Zero
C ExSr PrcObjRef1
C EndIf
**
C EndSr
**-- Process object references - format RORO0100: ----------------------**
C PrcObjRef1 BegSr
**
C If R1OfsSmpRef > *Zero And
C R1LenSmpRef = %Size( SmpObjRef )
**
C Eval pSmpObjRef = %Addr( RORO0100 ) +
C R1OfsSmpRef
**
C EndIf
**
C EndSr
**-- Process object references - format RORO0200: ----------------------**
C PrcObjRef2 BegSr
**
C Time Time
C Except Header
**
C If R2OfsSmpRef > *Zero And
C R2LenSmpRef = %Size( SmpObjRef )
**
C Eval pSmpObjRef = %Addr( RORO0200 ) +
C R2OfsSmpRef
**
C ExSr WrtLstHdr
C EndIf
**
C If R2OfsExtRef > *Zero And
C R2LenExtRef = %Size( ExtObjRef )
**
C Eval pExtObjRef = %Addr( RORO0200 ) +
C R2OfsExtRef
**
C EndIf
**
C If R2OfsJobLst > *Zero
**
C ExSr PrcJobLst
C EndIf
**
C If NbrRcds = *Zero
C Except NoRcds
C EndIf
**
C EndSr
**-- Process job list: -------------------------------------------------**
C PrcJobLst BegSr
**
C Eval pJobUsgObj = %Addr( RORO0200 ) +
C R2OfsJobLst
**
C For Idx = 1 to R2NbrJobRtn
**
C If JuDplSmpRef > *Zero
C Eval pSmpObjRef = pJobUsgObj + JuDplSmpRef
**...
C EndIf
**
C If JuDplExtRef > *Zero
C Eval pExtObjRef = pJobUsgObj + JuDplExtRef
**...
C EndIf
**
C ExSr WrtLckDtl
**
C If Idx < R2NbrJobRtn
C Eval pJobUsgObj += JuDplNxtJobE
C EndIf
C EndFor
**
C EndSr
**-- Write IFS lock detail line: ---------------------------------------**
C WrtLckDtl BegSr
**
C If PlCurLin > PlOvfLin - 3
C Except Header
C Except DtlHdr
C EndIf
**
C Eval NbrRcds = NbrRcds + 1
C Except LckDtl
**
C EndSr
**-- Write list header: ------------------------------------------------**
C WrtLstHdr BegSr
**
C If ApPthNamLen > %Size( IfsObj )
C EvalR IfsObj = ApPthNam
C Eval %Subst( IfsObj: 1: 3 ) = '...'
C Else
C Eval IfsObj = ApPthNam
C EndIf
**
C If R2InUseI = 1
C Eval ObjUse = '*YES'
C Else
C Eval ObjUse = '*NO '
C EndIf
**
C If SoChkOutUsrNm > *Blanks
C Eval ChkUsr = SoChkOutUsrNm
C Else
C Eval ChkUsr = '*NONE'
C EndIf
**
C Except LstHdr
C Except DtlHdr
**
C EndSr
**-- Printer file definition: ------------------------------------------**
OQSYSPRT EF Header 2 2
O UDATE Y 8
O Time 18 ' : : '
O 70 'Display IFS object locks'
O 107 'Program:'
O PsPgmNam 118
O 126 'Page:'
O PAGE + 1
OQSYSPRT EF LstHdr 1
O 18 'IFS object . . . :'
O IfsObj 132
OQSYSPRT EF LstHdr 1
O 18 'Object in use . :'
O ObjUse 24
OQSYSPRT EF LstHdr 1
O 18 'Check out user . :'
O ChkUsr 30
OQSYSPRT EF DtlHdr 1
O 98 '------------- shared ------
O --------'
OQSYSPRT EF DtlHdr 1
O 8 'Job name'
O 20 'Job user'
O 31 'Job nbr'
O 40 'Rd only'
O 49 'Wr only'
O 56 'Rd/wr'
O 62 'Exec'
O 71 'Rd only'
O 80 'Wr only'
O 88 'Rd/wr'
O 98 'No rd/wr'
O 108 'Atr lock'
O 119 'Save lock'
**-- Write right->left (prevent overlay):
OQSYSPRT EF LckDtl 1
O SoSavLck 3 115
O SoAtrLck 3 105
O SoShrNoRdWrt 3 95
O SoShrRdWrt 3 86
O SoShrWrtOnly 3 78
O SoShrRdOnly 3 69
O SoExecute 3 61
O SoReadWrt 3 54
O SoWrtOnly 3 47
O SoReadOnly 3 38
O JuJobNbr 30
O JuJobUsr 22
O JuJobNam 10
**
OQSYSPRT EF NoRcds 1
O 26 '(No IFS locks found)'
**-- Get job type: -----------------------------------------------------**
P GetJobTyp B
D Pi 1a
**
D JOBI0400 Ds
D J4BytRtn 10i 0
D J4BytAvl 10i 0
D J4JobNam 10a
D J4UsrNam 10a
D J4JobNbr 6a
D J4JobIntId 16a
D J4JobSts 10a
D J4JobTyp 1a
D J4JobSubTyp 1a
**
C CallP RtvJobInf( JOBI0400
C : %Size( JOBI0400 )
C : 'JOBI0400'
C : '*'
C : *Blank
C : ApiError
C )
**
C If AeBytAvl > *Zero
C Return *Blank
**
C Else
C Return J4JobTyp
C EndIf
**
P GetJobTyp E
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
**
C CallP(e) SndPgmMsg( 'CPF9897'
C : 'QCPFMSG *LIBL'
C : PxMsgDta
C : %Len( PxMsgDta )
C : '*ESCAPE'
C : '*PGMBDY'
C : 1
C : MsgKey
C : *Zero
C )
**
C If %Error
C Return -1
**
C Else
C Return 0
C EndIf
**
P SndEscMsg E
**-- Send completion message: ------------------------------------------**
P SndCmpMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
**
C CallP(e) SndPgmMsg( 'CPF9897'
C : 'QCPFMSG *LIBL'
C : PxMsgDta
C : %Len( PxMsgDta )
C : '*COMP'
C : '*PGMBDY'
C : 1
C : MsgKey
C : *Zero
C )
**
C If %Error
C Return -1
**
C Else
C Return 0
C EndIf
**
P SndCmpMsg E
**-- Get runtime error number: -----------------------------------------**
P Errno B
D Pi 10i 0
**
D sys_errno Pr * ExtProc( '__errno' )
**
D Error s 10i 0 Based( pError ) NoOpt
**
C Eval pError = sys_errno
C Return Error
**
P Errno E
**-- Get runtime error text: -------------------------------------------**
P Strerror B
D Pi 128a Varying
**
D sys_strerror Pr * ExtProc( 'strerror' )
D 10i 0 Value
**
C Return %Str( sys_strerror( Errno ))
**
P Strerror E
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( DSPIFSLCK ) */
/* Pgm( CBX116 ) */
/* SrcMbr( CBX116X ) */
/* HlpPnlGrp( CBX116H ) */
/* HlpId( *CMD ) */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Display IFS Object Locks' )
Parm IFSOBJ *Pname 300 +
Min( 1 ) +
Expr( *YES ) +
Vary( *YES *INT2 ) +
Case( *MIXED ) +
Prompt( 'IFS object' )
Parm OUTPUT *Char 3 +
Rstd( *YES ) +
Dft( * ) +
SpcVal(( * DSP ) ( *PRINT PRT )) +
Prompt( 'Output' )
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtPnlGrp PnlGrp( CBX116H )
.* SrcFile( QPNLSRC )
.* SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='DSPIFSLCK'.Display IFS Object Locks - Help
:P.
Displayes access and lock information for a specific IFS object.
:P.
This information includes the type of lock or access as well as a list
of the jobs holding the lock(s).
:P.
The length of time it will take this command to complete depends on the
number of jobs active on the system, and the number of jobs currently
using objects through Integrated File System interfaces.
:P.
:NT.
An IFS object can be flagged as "in use" without a specific job being
identified as currently holding a lock.
:P.
Likewise, the browsing of an IFS stream file does not necessarily
generate a lock or set the object in use indicator.
:ENT.
:NT.
This command requires release V5R2 or higher to run.
:ENT.
:EHELP.
:HELP NAME='DSPIFSLCK/IFSOBJ'.IFS object (IFSOBJ) - Help
:XH3.IFS object (IFSOBJ)
:P.
Specify the path name to the IFS object whose lock and access
information is to be displayed.
:P.
This is a required parameter.
:P.
:EHELP.
:HELP NAME='DSPIFSLCK/OUTPUT'.Output (OUTPUT) - Help
:XH3.Output (OUTPUT)
:P.
Specifies where the output from the command is sent.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*:EPK.
:PD.
The output is displayed (if requested by an interactive job) or printed
with the job's spooled output (if requested by a batch job).
:PT.:PK.*PRINT:EPK.
:PD.
The output is printed with the job's spooled output.
:EPARML.
:EHELP.
:EPNLGRP.
Thanks to Carsten Flensburg and
Club Tech iSeries Programming Tips Newsletter
QSPRILSP with CLLE:
PGM
DCL VAR(&RCVVAR) TYPE(*CHAR) LEN(70)
DCL VAR(&RCVVARLEN) TYPE(*CHAR) LEN(4)
DCL VAR(&ERRCODE) TYPE(*CHAR) LEN(8)
/* FIELDS FROM FORMAT SPRL0100 */
DCL VAR(&BYTESRTN) TYPE(*DEC) LEN(10 0)
DCL VAR(&BYTESAVL) TYPE(*DEC) LEN(10 0)
DCL VAR(&SPLFNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&USERNAME) TYPE(*CHAR) LEN(10)
DCL VAR(&JOBNBR) TYPE(*CHAR) LEN(6)
DCL VAR(&SPLFNBR) TYPE(*DEC) LEN(6 0)
DCL VAR(&SYSTEMNAME) TYPE(*CHAR) LEN(8)
DCL VAR(&CREATEDATE) TYPE(*CHAR) LEN(7)
DCL VAR(&CREATETIME) TYPE(*CHAR) LEN(6)
CHGVAR VAR(%BIN(&ERRCODE 1 4)) VALUE(0)
/* &RCVVARLEN NEEDS TO BE SET TO THE SIZE OF &RCVVAR. +
IF YOU CHANGE THE SIZE OF &RCVVAR, CHANGE IT ON THE +
LINE BELOW AS WELL! (CL HAS NO %SIZE BIF!!) */
CHGVAR VAR(%BIN(&RCVVARLEN 1 4)) VALUE(70)
CALL PGM(QSPRILSP) PARM( &RCVVAR +
&RCVVARLEN +
'SPRL0100' +
&ERRCODE )
/* SINCE CL HAS NO SUCH THING AS A DATA STRUCTURE, I'VE +
PUT ALL OF THE FIELDS INTO ONE BIG &RCVVAR FIELD, +
AND WILL SPLIT IT INTO SUBFIELDS BELOW: */
CHGVAR VAR(&BYTESRTN) VALUE(%BIN(&RCVVAR 1 4))
CHGVAR VAR(&BYTESAVL) VALUE(%BIN(&RCVVAR 5 4))
CHGVAR VAR(&SPLFNAME) VALUE(%SST(&RCVVAR 9 10))
CHGVAR VAR(&JOBNAME) VALUE(%SST(&RCVVAR 19 10))
CHGVAR VAR(&USERNAME) VALUE(%SST(&RCVVAR 29 10))
CHGVAR VAR(&JOBNBR) VALUE(%SST(&RCVVAR 39 6))
CHGVAR VAR(&SPLFNBR) VALUE(%BIN(&RCVVAR 45 4))
CHGVAR VAR(&SYSTEMNAME) VALUE(%SST(&RCVVAR 49 8))
CHGVAR VAR(&CREATEDATE) VALUE(%SST(&RCVVAR 57 7))
CHGVAR VAR(&CREATETIME) VALUE(%SST(&RCVVAR 65 6))
/* THE FIELDS ABOVE NOW CONTAIN INFO ABOUT THE LAST +
SPOOLED FILE CREATED IN THE JOB. */
ENDPGM
Thanks to Scott Klement and
Club Tech iSeries Programming Tips Newsletter
|
|
Back
Page #4
Page #6
