|
#6 |
API - Table of Contents |
#8 |
|
|
|
Call Service Program Procedure
Program: VARPROC1
H DFTACTGRP(*NO) ACTGRP(*NEW)
*
* This program demonstrates using the QZRUCLSP API to do "soft
* coded" calls to routines in the MSGSRV service program.
* Scott Klement, Nov 6, 2003
*
*
* Compile me with:
* CRTBNDRPG VARPROC1 SRCFILE(xxx/xxx)
* (Note that you do NOT have to bind the MSGSRV *SRVPGM!)
*
* Call me with:
* CALL VARPROC1 PARM('COMPMSG' 'THIS IS MY COOL MESSAGE' 23)
* CALL VARPROC1 PARM('DIAGMSG' 'THIS IS MY COOL MESSAGE' 23)
* CALL VARPROC1 PARM('ESCAPEMSG' 'THIS IS MY COOL MESSAGE' 23)
* CALL VARPROC1 PARM('STATUSMSG' 'THIS IS MY COOL MESSAGE' 23)
*
* Note that the output from DIAGMSG will go to the job log.
*
*
* API error code structure
*
D dsEC DS
D dsEC_BytesP 10I 0 inz(%size(dsEC))
D dsEC_BytesA 10I 0 inz(0)
D dsEC_MsgID 7A
D dsEC_Resvd 1A
D dsEC_MsgDta 240A
*
* Call Service Program Procedure API (QZRUCLSP)
*
d QZRUCLSP pr extpgm('QZRUCLSP')
d QualSrvPgm 20A const
d ExportName 4096A options(*varsize) const
d RtnValFmt 10I 0 const
d ParmsFmt 10I 0 dim(256) options(*varsize)
d NumOfParms 10I 0 const
d Errorcode 1024a options(*varsize)
d ReturnValue 10I 0 options(*nopass)
d Parameter1 256A options(*nopass)
d Parameter2 10I 0 options(*nopass)
*
* Parameter/Return types to use with QZRUCLSP API
*
d RETTYPE_NONE C 0
d RETTYPE_INT C 1
d RETTYPE_PTR C 2
d RETTYPE_INTERR C 3
d PARMTYPE_INT C 1
d PARMTYPE_PTR C 2
d SrvPgm s 10A inz('MSGSRV')
d SrvPgmLib s 10A inz('*LIBL')
d Procedure s 32A
d ParmType s 10I 0 dim(2)
d RtnVal s 10I 0
D Message s 256A
D Length s 15P 5
D IntLen s 10I 0
D Msg s 52A
c *entry plist
c parm Procedure
c parm Message
c parm Length
c eval IntLen = Length
c eval ParmType(1) = PARMTYPE_PTR
c eval ParmType(2) = PARMTYPE_INT
c callp QZRUCLSP( SrvPgm+SrvPgmLib:
c %trimr(Procedure)+x'00':
c RETTYPE_INT:
c ParmType: 2:
c dsEC:
c RtnVal:
c Message:
c IntLen)
c select
c when dsEC_BytesA > 0
c eval Msg = 'Call failed with ' + dsEC_MsgID
c dsply Msg
c when RtnVal <> 0
c eval Msg = 'Procedure returned error: ' +
c %trim(%editc(RtnVal:'L'))
c dsply Msg
c endsl
c eval *inlr = *on
Program: VARPROC2
*
* This program demonstrates using procedure pointers with a SELECT
* group to "soft-code" procedure names.
* Scott Klement, Nov 6, 2003
*
* Compile me with:
* CRTRPGMOD VARPROC2 SRCFILE(xxx/xxx)
* CRTPGM VARPROC2 BNDSRVPGM(MSGSRV) ACTGRP(*NEW)
* (Note that you DO have to bind the MSGSRV *SRVPGM!)
*
* Call me with:
* CALL VARPROC2 PARM('COMPMSG' 'THIS IS MY COOL MESSAGE' 23)
* CALL VARPROC2 PARM('DIAGMSG' 'THIS IS MY COOL MESSAGE' 23)
* CALL VARPROC2 PARM('ESCAPEMSG' 'THIS IS MY COOL MESSAGE' 23)
* CALL VARPROC2 PARM('STATUSMSG' 'THIS IS MY COOL MESSAGE' 23)
*
* Note that the output from DIAGMSG will go to the job log.
*
D MsgProcPtr s * procptr
D AnyMsgProc PR 10I 0 ExtProc(MsgProcPtr)
D Message 256A options(*varsize)
D Length 10I 0 value
d Procedure s 32A
d RtnVal s 10I 0
D Message s 256A
D Length s 15P 5
D Msg s 52A
c *entry plist
c parm Procedure
c parm Message
c parm Length
c select
c when Procedure = 'ESCAPEMSG'
c eval MsgProcPtr = %paddr('ESCAPEMSG')
c when Procedure = 'COMPMSG'
c eval MsgProcPtr = %paddr('COMPMSG')
c when Procedure = 'STATUSMSG'
c eval MsgProcPtr = %paddr('STATUSMSG')
c when Procedure = 'DIAGMSG'
c eval MsgProcPtr = %paddr('DIAGMSG')
c endsl
c eval RtnVal = AnyMsgProc(Message: Length)
c if RtnVal <> 0
c eval Msg = 'Procedure returned error: ' +
c %trim(%editc(RtnVal:'L'))
c dsply Msg
c endif
c eval *inlr = *on
Program: MSGSRV
H NOMAIN
*
* This service program sends messages 4 different ways, it's used
* by the VARPROC1 and VARPROC2 programs to demonstrate soft-coded
* procedure calls.
* Scott Klement, Nov 6, 2003
*
* To compile:
* CRTRPGMOD MODULE(mylib/MSGSRV) SRCFILE(mylib/mysrcpf)
* CRTSRVPGM SRVPGM(mylib/MSGSRV) MODULE(mylib/MSGSRV) EXPORT(*ALL)
*
*
* API error code structure
*
D dsEC DS
D dsEC_BytesP 10I 0 inz(%size(dsEC))
D dsEC_BytesA 10I 0 inz(0)
D dsEC_MsgID 7A
D dsEC_Resvd 1A
D dsEC_MsgDta 240A
*
* Send Program Message API
*
D QMHSNDPM PR ExtPgm('QMHSNDPM')
D MessageID 7A Const
D QualMsgF 20A Const
D MsgData 256A Const
D MsgDtaLen 10I 0 Const
D MsgType 10A Const
D CallStkEnt 10A Const
D CallStkCnt 10I 0 Const
D MessageKey 4A
D ErrorCode 1024A options(*varsize)
D CompMsg PR 10I 0
D Message 256A options(*varsize)
D Length 10I 0 value
D EscapeMsg PR 10I 0
D Message 256A options(*varsize)
D Length 10I 0 value
D StatusMsg PR 10I 0
D Message 256A options(*varsize)
D Length 10I 0 value
D DiagMsg PR 10I 0
D Message 256A options(*varsize)
D Length 10I 0 value
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* CompMsg(): Send a completion message.
*
* Message = message to send
* Length = length of message to send
*
* returns 0 if successful, or -1 if an error occurs
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P CompMsg B export
D CompMsg PI 10I 0
D Message 256A options(*varsize)
D Length 10I 0 value
D MsgKey s 4A
c reset dsEC
c callp QMHSNDPM('CPF9897': 'QCPFMSG *LIBL':
c Message: Length: '*COMP':
c '*CTLBDY': 2: MsgKey: dsEC)
c if dsEC_BytesA > 0
c return -1
c else
c return 0
c endif
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* EscapeMsg(): Send a completion message.
*
* Message = message to send
* Length = length of message to send
*
* returns -1 if an error occurs
* (If successful, program stops, so no return value is possible)
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P EscapeMsg B export
D EscapeMsg PI 10I 0
D Message 256A options(*varsize)
D Length 10I 0 value
D MsgKey s 4A
c reset dsEC
c callp QMHSNDPM('CPF9897': 'QCPFMSG *LIBL':
c Message: Length: '*ESCAPE':
c '*CTLBDY': 2: MsgKey: dsEC)
c return -1
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* StatusMsg(): Send a status message, and delay for 1 second
*
* Message = message to send
* Length = length of message to send
*
* returns 0 if successful, or -1 if an error occurs
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P StatusMsg B export
D StatusMsg PI 10I 0
D Message 256A options(*varsize)
D Length 10I 0 value
D MsgKey s 4A
D QCMDEXC PR ExtPgm('QCMDEXC')
D command 200A const
D length 15P 5 const
c reset dsEC
c callp QMHSNDPM('CPF9897': 'QCPFMSG *LIBL':
c Message: Length: '*STATUS':
c '*EXT': 0: MsgKey: dsEC)
c if dsEC_BytesA > 0
c return -1
c else
c callp QCMDEXC('DLYJOB DLY(1)': 13)
c return 0
c endif
P E
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* DiagMsg(): Send a diagnostic message (to the job log)
*
* Message = message to send
* Length = length of message to send
*
* returns 0 if successful, or -1 if an error occurs
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
P DiagMsg B export
D DiagMsg PI 10I 0
D Message 256A options(*varsize)
D Length 10I 0 value
D MsgKey s 4A
c reset dsEC
c callp QMHSNDPM('CPF9897': 'QCPFMSG *LIBL':
c Message: Length: '*DIAG':
c '*': 1: MsgKey: dsEC)
c if dsEC_BytesA > 0
c return -1
c else
c return 0
c endif
P E
Thanks to Scott Klement
|
|
Back
Retrieve Job Schedule Entries
********************************************************************
* PROGRAM : JOBSCDER
* DESCRIPTION : Retrieve Job Schedule Entries, sort by Time
* AUTHOR : Joe Marx
*
* NOTES : Written for Sox Remedation
*
* APIs Used: QWCLSCDE - Retrieve Job Schedule Entries
* QLGSORT - Sort List
* QUSCRTUS - Create User Space
* QUSDLTUS - Delete User Space
* QUSPTRUS - Retrieve From User Space w/ Pointer
* QWCRNETA - Retrieve Network Attributes
* QMHSNDPM - Send Message
*
*
* MAINTENANCE PROGRAMMER, PROJECT #, AND DESCRIPTION.
* ----------- ---------------------------------------
* 10/26/2004 Joe Marx - Created
********************************************************************
FQSYSPRT O F 132 PRINTER OFLIND(*INOF)
* DATE FORMATS --------------------------------------------
D FORMATMDY S D DATFMT(*MDY)
D FORMATUSA S D DATFMT(*USA)
D FORMATYMD S D DATFMT(*YMD)
D FORMATISO S D DATFMT(*ISO)
D PGM_INFO SDS
D PGM_NAME *PROC
D PGM_STATUS *STATUS
D PGM_USER 254 263
* DELETE USER SPACE
D DELETESPACE PR EXTPGM('QUSDLTUS')
D 20
D 116
* CREATE USER SPACE
D USERSPACE PR EXTPGM('QUSCRTUS')
D 20
D 10
D 10I 0
D 1
D 10
D 50
D 10
D 116
D 10
* GET A RESOLVED POINTER TO THE USER SPACE
D GETPOINTER PR EXTPGM('QUSPTRUS')
D 20 CONST
D *
D 116
*** API for List of Job Schedule Entries
D JobSch PR EXTPGM('QWCLSCDE')
D 20 CONST
D 8 CONST
D 10 CONST
D 16 CONST
D 116
*** QCMD
DCOMMAND PR EXTPGM('QCMDEXC')
D CMDSTRING 3000 CONST OPTIONS(*VARSIZE)
D CMDLENGTH 15P 5 CONST
D CMDOPT 3 CONST OPTIONS(*NOPASS)
D SendMsg PR extpgm('QMHSNDPM')
D MsgID 7 const
D MsgFile 20 const
D MsgDta 80 const
D MsgDtaLen 10i 0 const
D MsgType 10 const
D MsgQ 10 const
D MsgQNbr 10i 0 const
D MsgKey 4
D ErrorDS 16
*** API Error Handling
D DS
D APIERROR 116
D BYTPRV 9B 0 OVERLAY(APIERROR) INZ(16)
D BYTAVA 9B 0 OVERLAY(APIERROR:5)
D MSGID 7 OVERLAY(APIERROR:9)
D ERR### 1 OVERLAY(APIERROR:16)
D MSGDTAE 100 OVERLAY(APIERROR:17)
* GENERIC LIST HEADER
D SPCPTR S *
D QUSH0100 DS BASED(SPCPTR)
D QUSUA 64 USER AREA
D QUSSGH 10I 0 HEADER SIZE
D QUSSRL 4 RELEASE LEVEL
D QUSFN 8 FORMAT NAME
D QUSAU 10 API USED
D QUSDTC 13 DATE/TIME CREATED
D QUSIS 1 INFO STATUS
D QUSSUS 10I 0 SIZE USER SPACE
D QUSOIP 10I 0 OFSET INPUT PARM
D QUSSIP 10I 0 INPUT PARM SIZE
D QUSOHS 10I 0 OFFSET HDR SECTION
D QUSSHS 10I 0 HEADER SECTION SIZE
D QUSOLD 10I 0 OFFSET LIST DATA
D QUSSLD 10I 0 SIZE LIST DATA
D QUSNBRLE 10I 0 NUMBER LIST ENTRIES
D QUSSEE 10I 0 SIZE EACH ENTRY
D QUSSIDLE 10I 0 CCSID LIST ENT
D QUSCID 2 COUNTRY ID
D QUSLID 3 LANGUAGE ID
D QUSSLI 1 SUBSET LIST INDICO
D QUSERVED00 42 RESERVED
D JS_PTR S *
D JS S 1 BASED(JS_PTR) DIM(32767)
D JS_Detail DS 1156 Based(JS_PTR)
D JS_Char1 1 Overlay(JS_Detail:1)
D JS_Job 10 Overlay(JS_Detail:*Next)
D JS_Entry 10 Overlay(JS_Detail:*Next)
D JS_SchDate 10 Overlay(JS_Detail:*Next)
D JS_SchDays 70 Overlay(JS_Detail:*Next)
D JS_SchTime 6 Overlay(JS_Detail:*Next)
D JS_Freq 10 Overlay(JS_Detail:*Next)
D JS_DayofMon 50 Overlay(JS_Detail:*Next)
D JS_Recovery 10 Overlay(JS_Detail:*Next)
D JS_NextDate 10 Overlay(JS_Detail:*Next)
D JS_Status 10 Overlay(JS_Detail:*Next)
D JS_JobqNam 10 Overlay(JS_Detail:*Next)
D JS_JobqLib 10 Overlay(JS_Detail:*Next)
D JS_UsrPrf 10 Overlay(JS_Detail:*Next)
D JS_LastDate 10 Overlay(JS_Detail:*Next)
D JS_LastTime 6 Overlay(JS_Detail:*Next)
D JS_Text 50 Overlay(JS_Detail:*Next)
D JS_Fill1 23 Overlay(JS_Detail:*Next)
D JS_JobqStatus 10 Overlay(JS_Detail:*Next)
D JS_DatesOmit 200 Overlay(JS_Detail:*Next)
D JS_JobdNam 10 Overlay(JS_Detail:*Next)
D JS_JobdLib 10 Overlay(JS_Detail:*Next)
D JS_UsrPrf2 10 Overlay(JS_Detail:*Next)
D JS_MsgQNam 10 Overlay(JS_Detail:*Next)
D JS_MsgQlib 10 Overlay(JS_Detail:*Next)
D JS_SaveEnt 10 Overlay(JS_Detail:*Next)
D JS_LastSubN 10 Overlay(JS_Detail:*Next)
D JS_LastSubU 10 Overlay(JS_Detail:*Next)
D JS_LastSubJ 6 Overlay(JS_Detail:*Next)
D JS_LastAttD 10 Overlay(JS_Detail:*Next)
D JS_LastAttT 6 Overlay(JS_Detail:*Next)
D JS_LastAttS 10 Overlay(JS_Detail:*Next)
D JS_Fill2 2 Overlay(JS_Detail:*Next)
D JS_Len 4 0 Overlay(JS_Detail:*Next)
D JS_Command 512 Overlay(JS_Detail:*Next)
* Sort Block
DSORTBLOCK DS
D BLOCKLEN 1 4B 0 INZ(0)
D REQTYPE 5 8B 0 INZ(8)
D RSVP1 9 12B 0 INZ(0)
D OPTIONS 13 16B 0 INZ(0)
D RECLEN 17 20B 0 INZ(0)
D RECCOUNT 21 24B 0 INZ(0)
D OFF2KEY 25 28B 0 INZ(80)
D NBROFKEYS 29 32B 0 INZ(0)
D OFF2NLSI 33 36B 0 INZ(0)
D OFF2IFL 37 40B 0 INZ(0)
D NBRINF 41 44B 0 INZ(0)
D OFF2OFL 45 48B 0 INZ(0)
D NBROUTF 49 52B 0 INZ(0)
D KEYENTLEN 53 56B 0 INZ(16)
D NLSSLEN 57 60B 0 INZ(290)
D IFELEN 61 64B 0 INZ(0)
D OFELEN 65 68B 0 INZ(0)
D OFF2NBM 69 72B 0 INZ(0)
D OFF2VLRA 73 76B 0 INZ(0)
D RSVP2 77 80B 0 INZ(0)
D KEYINF 16A DIM(MaxKey)
* Sort Block IO
DSORTIOBLOC DS
D IOTYPE 1 4B 0 INZ(0)
D RSVP3 5 8B 0 INZ(0)
D IORECLEN 9 12B 0 INZ(0)
D IORECCNT 13 16B 0 INZ(0)
* Sort INFO Data Structure
DKEYINFDS DS
D KEYSTART 1 4B 0
D KEYSIZE 5 8B 0
D KEYDTATYP 9 12B 0
D KEYASCDESC 13 16B 0
*----------------------------------------------------------------
* QWCRNETA Retrieve network attribute - get system name
* See SYSTEM PROGRAMMER'S INTERFACE REFERENCE for API detail.
*----------------------------------------------------------------
D vsd s 5u 0 START OF DATA
D vso s 5u 0 START OFFSET
* Load number of attributes to retrieve and attribute name
D vapiky ds
D vnkfld 10i 0 inz(1)
D vkarry 11 inz('SYSNAME')
* Number of keys returned and offset to attribute data
D vrcvr1 ds 200 inz
D vnkyrt 10i 0
D voffna 10i 0
D vrcvln s 10i 0 inz(200)
* Network Attribute Information Table returned
D vnait ds inz
D vrtatt 1 10
D vrttyp 11 11
D vrtsta 12 12
D vrtlen 10i 0
* User Defined Variables
D JS_Format S 20 INZ('SCDL0200')
D JS_Name S 8 INZ('*ALL')
D JS_Handle S 10 INZ(' ')
D SPC_LIB S 10 INZ('QTEMP ')
D EXT_ATTR S 10 INZ
D SPACE_SIZE S 10I 0 INZ(500000)
D SPACE_INIT S 1 INZ(X'00')
D SPACE_AUT S 10 INZ('*ALL')
D SPACE_TEXT S 50 INZ('MEDI001R TEXT')
D SPACE_RPL S 10 INZ('*YES')
D SPACEDOMAN S 10 INZ('*USER')
D SPACENAME S 20 INZ('MEDI001R QTEMP ')
D TIMES S 7 0
D COUNT S 7 0
D LLEN S 7 0
D Ljob S 10
D COUNT2 S 7 0
D #Status S 3A
D #Date S 10A
D #Command S 31A
D #Time S 6 0
D #Frequency S 10A
D MAXKEY C 4
D EXITER S 1A
D NOTUSED S 16A
D RETURNSIZE S 9B 0
D SIZELIST S 9B 0
D SYSNAME S 8
D #str S 4 0
D #end S 4 0
D #Len S 4 0
D CMDSTRING S 3000 VARYING
D CMDLENGTH S 15 5
D MsgDta s 80
D MsgKey s 4
** Initial Startup
C EXSR INIT
** Main Processing
C EXSR Main
** Special Processing
C EXSR Special
* Send Message that Job has completed.
C*** CALLP COMMAND( CMDSTRING : %LEN(CMDSTRING))
C eval MsgDta = 'AS/400 Batch Job Schedule -
C has printed'
C callp SendMsg ('CPF9898':
C 'QCPFMSG QSYS':
C MsgDta:
C %len(MsgDta):
C '*ESCAPE':
C '*':
C 2:
C MsgKey:
C ApiError)
** End Program
C EVAL *INLR = *ON
*==============================================================
* Subroutine - Main
* This subroutine processing....
*==============================================================
C Main begsr
** Print Header at least 1 time....
C EXCEPT HEAD1
** RETRIEVE DATABASE FILE DESCRIPTION USING USER SPACE
** CREATE USER SPACE
C CALLP USERSPACE(SPACENAME :
C EXT_ATTR : SPACE_SIZE :
C SPACE_INIT : SPACE_AUT :
C SPACE_TEXT : SPACE_RPL :
C APIERROR : SPACEDOMAN )
** RETRIEVE WRKJOBSCDE API - QWCLSCDE
C CALLP JOBSCH(SPACENAME :
C JS_Format : JS_Name :
C JS_Handle : APIERROR )
* GET A RESOLVED POINTER TO THE USER SPACE
* RECEIVES HEADER INFO FROM USER SPACE
C CALLP GETPOINTER(SPACENAME : SPCPTR :
C APIERROR)
C
* SET JS_PTR TO THE FIRST BYTE OF THE USER SPACE
C EVAL JS_PTR = SPCPTR
* Initial Sort API
c EXSR $InzSort
* Initial Sort List
c EXSR $SortList
* DELETE ALL USER SPACES BEFORE EXITING PROGRAM
C CALLP DELETESPACE(SPACENAME : APIERROR )
* Print Totals
C EXSR @@HEAD
C EXCEPT TOT1
C EndSr
*==============================================================
* Subroutine - Special
* This subroutine processing....
*==============================================================
C Special begsr
** Print Header at least 1 time....
C EXCEPT HEAD2
** RETRIEVE DATABASE FILE DESCRIPTION USING USER SPACE
** CREATE USER SPACE
C CALLP USERSPACE(SPACENAME :
C EXT_ATTR : SPACE_SIZE :
C SPACE_INIT : SPACE_AUT :
C SPACE_TEXT : SPACE_RPL :
C APIERROR : SPACEDOMAN )
** RETRIEVE WRKJOBSCDE API - QWCLSCDE
C CALLP JOBSCH(SPACENAME :
C JS_Format : JS_Name :
C JS_Handle : APIERROR )
* GET A RESOLVED POINTER TO THE USER SPACE
* RECEIVES HEADER INFO FROM USER SPACE
C CALLP GETPOINTER(SPACENAME : SPCPTR :
C APIERROR)
C
* SET JS_PTR TO THE FIRST BYTE OF THE USER SPACE
C EVAL JS_PTR = SPCPTR
* Initial Sort API
c EXSR $InzSort
* Initial Sort List
c EXSR $SortList2
* DELETE ALL USER SPACES BEFORE EXITING PROGRAM
C CALLP DELETESPACE(SPACENAME : APIERROR )
* Print Totals
C EXSR @@HEAD2
C EXCEPT TOT2
C EndSr
*==============================================================
* Subroutine - Init
* This subroutine Initializes the Program
*==============================================================
C Init begsr
C call 'QWCRNETA' RETRIEVE SPACE
C parm vrcvr1
C parm 200 vrcvln
C parm vnkfld NUMBER OF KEYS
C parm vkarry KEY ARRAY
C parm ApiError
C voffna add 1 vso START OFFSET
C voffna add 1 vso START OFFSET
C eval vnait = %subst(vrcvr1:vso:16) LOAD NAIT DST
C vso add 16 vsd START OF DATA
C vrtlen subst vrcvr1:vsd SYSNAME EXTRACT SYSNAM
c Endsr
*==============================================================
* Subroutine - @@HEAD
* Check for Overflow - Reprints Heading
*==============================================================
C @@HEAD begsr
c if *inOF = *on
C EXCEPT HEAD1
c Eval *inOF = *off
c EndIf
C Endsr
*==============================================================
* Subroutine - @@HEAD2
* Check for Overflow - Reprints Heading for Special
*==============================================================
C @@HEAD2 begsr
c if *inOF = *on
C EXCEPT HEAD1
c Eval *inOF = *off
c EndIf
C Endsr
*==============================================================
* Subroutine - InzSort
* This subroutine Initializes the Sort API
*==============================================================
c $InzSort begsr
* Initialize the key fields to sort on.
* Load JS_Freq field as key field, 06 byte, Char, ascending sequence.
c eval KeyStart = 107
c eval KeySize = 10
c eval KeyDtaTyp = 2
c eval KeyAscDesc = 1
c eval KeyInf(1) = KeyInfDs
* Load JS_schTime field as key field, 06 byte, Char, ascending sequence.
c eval KeyStart = 101
c eval KeySize = 06
c eval KeyDtaTyp = 2
c eval KeyAscDesc = 1
c eval KeyInf(2) = KeyInfDs
* Load JS_Job field as key field, 10 byte, char , ascending sequence.
c eval KeyStart = 1
c eval KeySize = 10
c eval KeyDtaTyp = 6
c eval KeyAscDesc = 1
c eval KeyInf(3) = KeyInfDs
* Load other sort parameters.
c eval BlockLen = 80 + 16 * MaxKey
c eval NbrOfKeys = 3 Variable
c eval RecLen = %size(JS_Detail)
* Initialize Sort I/O API fields.
c eval IORecLen = RecLen
c eval IORecCnt = 1
* All done initializing.
c ENDSR
*==============================================================
* Subroutine - SortList
* This subroutine sorts the List
*==============================================================
c $SortList begsr
* First step - Initialize the sort routine.
c call 'QLGSORT'
c parm SortBlock
c parm NotUsed
c parm NotUsed
c parm SizeList
c parm ReturnSize
c parm ApiError
* Next step - write records to I/O routine.
c eval IOType = 1
* INCREMENT JS_PTR TO THE FIRST LIST ENTRY
C EVAL JS_PTR = %ADDR(JS(QUSOLD + 1))
C FOR TIMES=1 BY 1 TO QUSNBRLE
c call 'QLGSRTIO'
c parm SortIOBloc
c parm JS_Detail
c parm NotUsed
c parm SizeList
c parm NotUsed
c parm ApiError
C EVAL JS_PTR = %ADDR(JS(QUSSEE + 1))
C Endfor
* Next step - Signal end of input, clear JS_DETAIL for reload.
c eval IOType = 2
c call 'QLGSRTIO'
c parm SortIOBloc
c parm JS_Detail
c parm NotUsed
c parm SizeList
c parm NotUsed
c parm ApiError
* Final step - write the records back to the subfile.
c eval IOType = 3
C EVAL JS_PTR = %ADDR(JS(QUSOLD + 1))
C FOR TIMES=1 BY 1 TO QUSNBRLE
c call 'QLGSRTIO'
c parm SortIOBloc
c parm NotUsed
c parm JS_Detail
c parm IORecLen
c parm NotUsed
c parm ApiError
* Set up Date of Run....
C Eval #DATE = JS_SCHDATE
C Select
C WHEN JS_SCHDATE = '*NONE'
C and JS_SchDays <> '*ALL'
C Eval #DATE = 'USER DEF'
C WHEN JS_SCHDATE = '*NONE'
C and JS_SchDays = '*ALL'
C Eval #DATE = '*All'
C EndSL
* Set up #Status...
C Eval #Status = %subst(JS_Status:1:3)
* Set up #Time.....
C Move JS_SCHTIME #Time
* Set up #command.....
C Eval #COMMAND = %subst(JS_COMMAND:1:31)
C If %subst(JS_COMMAND:1:9) = 'CALL PGM('
C Eval #str = %scan('/': JS_Command )
C Eval #end = %scan(')': JS_Command )
* check if library with program(meaning / comes after program)
C If #str > #end
C or #str = 0
C Eval #COMMAND = %subst(JS_COMMAND: 10
C :(#End-1) - 9)
C Else
C Eval #COMMAND = %subst(JS_COMMAND: #str+1
C :(#End-1)-#Str)
C Endif
C Endif
C Eval #LEN = %len(%trim(JS_COMMAND))
C If #LEN > LLEN
C Eval LLEN = #LEN
C Eval LJOB = JS_Job
C Endif
C EVAL COUNT = COUNT + 1
C EXSR @@HEAD
C EXCEPT DET1
C EVAL JS_PTR = %ADDR(JS(QUSSEE + 1))
C ENDFOR
c endsr
*==============================================================
* Subroutine - SortList2
* This subroutine sorts the List
*==============================================================
c $SortList2 begsr
* First step - Initialize the sort routine.
c call 'QLGSORT'
c parm SortBlock
c parm NotUsed
c parm NotUsed
c parm SizeList
c parm ReturnSize
c parm ApiError
* Next step - write records to I/O routine.
c eval IOType = 1
* INCREMENT JS_PTR TO THE FIRST LIST ENTRY
C EVAL JS_PTR = %ADDR(JS(QUSOLD + 1))
C FOR TIMES=1 BY 1 TO QUSNBRLE
c call 'QLGSRTIO'
c parm SortIOBloc
c parm JS_Detail
c parm NotUsed
c parm SizeList
c parm NotUsed
c parm ApiError
C EVAL JS_PTR = %ADDR(JS(QUSSEE + 1))
C Endfor
* Next step - Signal end of input, clear JS_DETAIL for reload.
c eval IOType = 2
c call 'QLGSRTIO'
c parm SortIOBloc
c parm JS_Detail
c parm NotUsed
c parm SizeList
c parm NotUsed
c parm ApiError
* Final step - write the records back to the subfile.
c eval IOType = 3
C EVAL JS_PTR = %ADDR(JS(QUSOLD + 1))
C FOR TIMES=1 BY 1 TO QUSNBRLE
c call 'QLGSRTIO'
c parm SortIOBloc
c parm NotUsed
c parm JS_Detail
c parm IORecLen
c parm NotUsed
c parm ApiError
* Set up Date of Run....
C Eval #DATE = JS_SCHDATE
C Select
C WHEN JS_SCHDATE = '*NONE'
C and JS_SchDays <> '*ALL'
C Eval #DATE = 'USER DEF'
C WHEN JS_SCHDATE = '*NONE'
C and JS_SchDays = '*ALL'
C Eval #DATE = '*All'
C EndSL
* Set up #Status...
C Eval #Status = %subst(JS_Status:1:3)
* Set up #Time.....
C Move JS_SCHTIME #Time
* Set up #command.....
C Eval #COMMAND = %subst(JS_COMMAND:1:31)
C If %subst(JS_COMMAND:1:9) = 'CALL PGM('
C Eval #str = %scan('/': JS_Command )
C Eval #end = %scan(')': JS_Command )
C Eval #COMMAND = %subst(JS_COMMAND:#str+1
C :(#End-1)-#Str)
C Endif
* Set up #Frequency....
C Eval #Frequency = '*SUNDAY'
c If %scan('*SUN' : JS_SchDays) > 0
C EVAL COUNT2 = COUNT2 + 1
C EXSR @@HEAD2
C EXCEPT DET2
c Endif
C EVAL JS_PTR = %ADDR(JS(QUSSEE + 1))
C ENDFOR
c endsr
OQSYSPRT E HEAD1 01
O + 50 'Job Schedule List'
O E HEAD1 1
O + 1 'Date of Report....:'
O *Date y + 1
O 120 'PAGE......:'
O PAGE Z 132
O E HEAD1 1
O + 1 'Program Name......:'
O PGM_NAME + 1
O 120 'UserId....:'
O PGM_USER 132
O E HEAD1 2
O + 1 'System Name.......:'
O SYSNAME + 1
O E HEAD1 1
O +0 'Opt Job'
O +4 'Status'
O +2 'Date'
O +7 'Time'
O +5 'Frequency'
O +2 'Description'
O +40 'Program/Command'
O E HEAD1 1
O +0 '--------------------'
O +0 '--------------------'
O +0 '--------------------'
O +0 '--------------------'
O +0 '--------------------'
O +0 '--------------------'
O +0 '------------'
O E DET1 1
O JS_Job +0
O #Status +1
O #Date +5
O #Time +1 ' : : '
O JS_Freq +1
O JS_Text +1
O #Command +1
O E TOT1 3
O +0 'COUNT:'
O COUNT 4 +2
O*** E TOT1 1
O*** +0 'Longest Length of Command:'
O*** LLEN 4 +2
O*** LJOB +2
OQSYSPRT E HEAD2 01
O + 46 'Special Job Schedule List'
O E HEAD2 1
O + 1 'Date of Report....:'
O *Date y + 1
O 120 'PAGE......:'
O PAGE Z 132
O E HEAD2 1
O + 1 'Program Name......:'
O PGM_NAME + 1
O 120 'UserId....:'
O PGM_USER 132
O E HEAD2 2
O + 1 'System Name.......:'
O SYSNAME + 1
O E HEAD2 1
O +0 'Opt Job'
O +4 'Status'
O +2 'Date'
O +7 'Time'
O +5 'Frequency'
O +2 'Description'
O +40 'Program/Command'
O E HEAD2 1
O +0 '--------------------'
O +0 '--------------------'
O +0 '--------------------'
O +0 '--------------------'
O +0 '--------------------'
O +0 '--------------------'
O +0 '------------'
O E DET2 1
O JS_Job +0
O #Status +1
O #Date +5
O #Time +1 ' : : '
O #Frequency +1
O JS_Text +1
O #Command +1
O E TOT2 3
O +0 'COUNT:'
O COUNT2 4 +2
Thanks to Joe Marx
|
|
Back
Retrieve Database File Description
**
** Program . . : CBX123
** Description : Print file field description
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : September 9, 2004
**
**
** Program summary
** ---------------
**
** Database and file API:
** QDBRTVFD Retrieve database Allows you to get the complete and
** file description specific information about a file.
**
** The information is returned to a
** receiver variable in either a file
** definition template or a format
** definition mapping.
**
** 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:
** tstbts Test bits Tests the bit value of the bit
** located with the bit offset
** parameter, bit 0 being the
** leftmost and 64k the maximum.
**
**
** Program description:
** This program will retrieve and print information about a database
** file's fields. The information is printed in a list and includes
** field attributes, key fields and, in case of a logical file being
** requested, any record select/omit specifications.
**
**
** Sequence of events:
** 1. Storage is allocated to the API receiver variable.
**
** 2. The QDBRTVFD API is called to collect information about file
** key fields and select/omit specifications. If more data is
** available than the storage currently allocated to the API
** receiver variable can hold, enough storage is reallocated,
** and the API call is repeated.
**
** 3. The key fields and select/omit specifications are retrieved
** and stored in two arrays for later processing.
**
** 4. The QDBRTVFD API is called again, this time to collect the
** requried information about record format and field attributes.
** Again storage is reallocated and the API call repeated until
** all available information is retrieved.
**
** 5. The file field list is printed and subsequently the key field
** information section is also printed. In case the requested
** file is a logical file, a select/omit specification section is
** printed.
**
** 6. The allocated storage is released and a completion message is
** sent to the caller.
**
** 7. If during the processing described above an API error occurs,
** the returned error message data is retrieved from the API
** error data structure, and an escape message is sent to the
** caller, informing about the specific error. Prior to sending
** the escape message, which terminates the program immediately,
** the allocated storage is deallocated.
**
**
** Programmer's notes:
** Overflow could occur during the formatting of the check values
** and select/omit criteria specification, if the number or size of
** these values result in a string larger than 70 respectively 98
** bytes.
**
** The format of the produced list can be adapted to any desired
** length and overflow values by adjusting the FormLen() and
** FormOfl() keywords in the QSYSPRT F-specification below.
**
** The 'dummy' structure specifications that are commented out, are
** included in order to document the bit-fields that are embedded in
** the return structures:
**
** D Qdbfhflg 2a
** D* Reserved_1 :2
** D* Qdbfhfpl :1
**
** In the above example the field Qdbfhflg is defined as a 2 byte
** character field but it contains a number of bit-settings storing
** different flags and attributes. The :n notation defines the
** number of bits that each bit-field occupies, from left to right.
**
** Thus the bit-field Reserved_1 occupies the two leftmost bits in
** the Qdbfhflg field and Qdbfhfpl the third bit. To extract the
** actual bit settings, the tstbts C library function is used.
**
**
** Compilation specification:
** CrtRpgMod Module( CBX123 )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX123 )
** Module( CBX123 )
** ActGrp( QILE )
**
**
**-- Header specifications: --------------------------------------------**
H BndDir( 'QC2LE' ) Option( *SrcStmt )
**-- Printer file:
FQSYSPRT O F 132 Printer InfDs( PrtInf ) OflInd( *InOf )
F FormLen( 70 ) FormOfl( 68 )
**-- Printer file information:
D PrtInf Ds Qualified
D WrtCnt 10i 0 Overlay( PrtInf: 243 )
D OvfLin 5i 0 Overlay( PrtInf: 188 )
D CurLin 5i 0 Overlay( PrtInf: 367 )
D CurPag 5i 0 Overlay( PrtInf: 369 )
**-- System information:
D SDs
D PsPgmNam *Proc
**-- API error data structure:
D ERRC0100 Ds Qualified
D BytPro 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0 Inz
D MsgId 7a
D 1a
D MsgDta 128a
**-- API parameters:
D FilRtnQ Ds Qualified
D FilNam 10a
D LibNam 10a
D ApiRcvSiz s 10u 0
**-- Global variables:
D RcdIdx s 10i 0
D FldIdx s 10i 0
D ChkIdx s 10i 0
D KeyIdx s 10i 0
D SltIdx s 10i 0
D ValIdx s 10i 0
D KeyTyp s 10a Varying
D AccPth s 10a Varying
**-- Output fields:
D OutHdr Ds Inz
D Time 6s 0
D FilNam 10a
D LibNam 10a
D FilTyp 10a
D RcdFmt 10a
D RcdLen 5i 0
D FldCnt 5i 0
**
D OutDtl Ds Inz
D FldNam 10a
D FldTyp 10a
D BufPos 5i 0
D FldLen 5i 0
D KeySeq 4a
D FldDig 3a
D FldDec 3a
D FldTxt 50a
D FldHdg 62a
D TxtLin2 70a
D SpcTxt 98a
**-- Key field & select/omit statement arrays:
D KeyFld s 10a Dim( 120 )
D SltStm s 128a Dim( 512 ) Varying
**-- Check keyword conversion:
D ChkDfn Ds
D ChkHex 21a Inz( x'636466677172737475767778797A-
D A0A1A2A3A5A6A7' )
D ChkKwd 231a Inz( 'CHKMSGID -
D CHECK(ME) -
D CHECK(FE) -
D CHECK(MF) -
D RANGE -
D VALUES -
D COMP GT -
D COMP GE -
D COMP EQ -
D COMP NE -
D COMP LE -
D COMP LT -
D COMP NL -
D COMP NG -
D CHECK(M10) -
D CHECK(M11) -
D CHECK(VN) -
D CHECK(AB) -
D CHECK(VNE) -
D CHECK(M10F)-
D CHECK(M11F)' )
D ChkHexA 1a Dim( 21 ) Overlay( ChkDfn: 1 )
D ChkKwdA 11a Dim( 21 ) Overlay( ChkDfn: 22 )
**-- Select/omit keyword conversion:
D SltDfn Ds
D SltCod 20a Inz( 'ALEQGEGTLELTNENGNLVA' )
D SltKwd 80a Inz( 'ALL -
D COMP EQ -
D COMP GE -
D COMP GT -
D COMP LE -
D COMP LT -
D COMP NE -
D COMP NG -
D COMP NL -
D VALUES ' )
D SltCodA 2a Dim( 10 ) Overlay( SltDfn: 1 )
D SltKwdA 8a Dim( 10 ) Overlay( SltDfn: 21 )
**-- Field type conversion:
D TypDfn Ds
D TypHex 38a Inz( x'0000000100020003000480040005-
D 800500068006000B000C000D400440054006-
D 80448046FFFF' )
D TypTxt 190a Inz( 'Binary -
D Float -
D Zoned -
D Packed -
D Char -
D Var char -
D Graph -
D Var graph -
D DBCS -
D Var DBCS -
D Date -
D Time -
D Timestamp -
D BLOB/CLOB -
D DBCLOB -
D CLOB-open -
D Datalink C-
D Datalink O-
D NULL ' )
D TypHexA 2a Dim( 19 ) Overlay( TypDfn: 1 )
D TypTxtA 10a Dim( 19 ) Overlay( TypDfn: 39 )
**-- FILD0100 formats:
D Qdb_Qdbfh Ds Based( pQdb_Qdbfh ) Qualified
D Qdbfyret 10i 0
D Qdbfyavl 10i 0
D Qdbfhflg 2a
D* Reserved_1 :2
D* Qdbfhfpl :1
D* Reserved_2 :1
D* Qdbfhfsu :1
D* Reserved_3 :1
D* Qdbfhfky :1
D* Reserved_4 :1
D* Qdbfhflc :1
D* Qdbfkfso :1
D* Reserved_5 :4
D* Qdbfigcd :1
D* Qdbfigcl :1
D Reserved_7 4a
D Qdbflbnum 5i 0
D Qdbfkdat 14a
D Qdbfknum 5i 0 Overlay( Qdbfkdat: 1 )
D Qdbfkmxl 5i 0 Overlay( Qdbfkdat: *Next )
D Qdbfkflg 1a Overlay( Qdbfkdat: *Next )
D* Reserved_8 :1
D* Qdbfkfcs :1
D* Reserved_9 :4
D* Qdbfkfrc :1
D* Qdbfkflt :1
D Qdbfkfdm 1a Overlay( Qdbfkdat: *Next )
D Reserved_10 8a Overlay( Qdbfkdat: *Next )
D Qdbfhaut 10a
D Qdbfhupl 1a
D Qdbfhmxm 5i 0
D Qdbfwtfi 5i 0
D Qdbfhfrt 5i 0
D Qdbfhmnum 5i 0
D Reserved_11 9a
D Qdbfbrwt 5i 0
D Qaaf 1a
D* Reserved_12 :7
D* Qdbfpgmd :1
D Qdbffmtnum 5i 0
D Qdbfhfl2 2a
D* Qdbfjnap :1
D* Reserved_13 :1
D* Qdbfrdcp :1
D* Qdbfwtcp :1
D* Qdbfupcp :1
D* Qdbfdlcp :1
D* Reserved_14 :9
D* Qdbfkfnd :1
D Qdbfvrm 5i 0
D Qaaf2 2a
D* Qdbfhmcs :1
D* Reserved_15 :1
D* Qdbfknll :1
D* Qdbf_nfld :1
D* Qdbfvfld :1
D* Qdbftfld :1
D* Qdbfgrph :1
D* Qdbfpkey :1
D* Qdbfunqc :1
D* Reserved_118 :2
D* Qdbfapsz :1
D* Qdbfdisf :1
D* Reserved_68 :1
D* Reserved_69 :1
D* Reserved_70 :1
D Qdbfhcrt 13a
D Qdbfhtx 52a
D Reserved_18 2a Overlay( Qdbfhtx: 1 )
D Qdbfhtxt 50a Overlay( Qdbfhtx: *Next )
D Reserved_19 13a
D Qdbfsrc 30a
D Qdbfsrcf 10a Overlay( Qdbfsrc: 1 )
D Qdbfsrcm 10a Overlay( Qdbfsrc: *Next )
D Qdbfsrcl 10a Overlay( Qdbfsrc: *Next )
D Qdbfkrcv 1a
D Reserved_20 23a
D Qdbftcid 5i 0
D Qdbfasp 2a
D Qdbfnbit 1a
D* Qdbfhudt :1
D* Qdbfhlob :1
D* Qdbfhdtl :1
D* Qdbfhudf :1
D* Qdbfhlon :1
D* Qdbfhlop :1
D* Qdbfhdll :1
D* Reserved_21 :1
D Qdbfmxfnum 5i 0
D Reserved_22 76a
D Qdbfodic 10i 0
D Reserved_23 14a
D Qdbffigl 5i 0
D Qdbfmxrl 5i 0
D Reserved_24 8a
D Qdbfgkct 5i 0
D Qdbfos 10i 0
D Reserved_25 8a
D Qdbfocs 10i 0
D Reserved_26 4a
D Qdbfpact 2a
D Qdbfhrls 6a
D Reserved_27 20a
D Qdbpfof 10i 0
D Qdblfof 10i 0
D Qdbfssfp 6a
D Qdbfnlsb 1a Overlay( Qdbfssfp: 1 )
D* Qdbfsscs :3
D* Reserved_103 :5
D Qdbflang 3a Overlay( Qdbfssfp: *Next )
D Qdbfcnty 2a Overlay( Qdbfssfp: *Next )
D Qdbfjorn 10i 0
D Qdbfevid 10i 0
D Reserved_28 14a
**
D Qdb_Qdbfb Ds Qualified Based( pQdb_Qdbfb )
D Reserved_48 48a
D Qdbfbf 10a
D Qdbfbfl 10a
D Qdbft 10a
D Reserved_49 37a
D Qdbfbgky 5i 0
D Reserved_50 2a
D Qdbfblky 5i 0
D Reserved_51 2a
D Qdbffogl 5i 0
D Reserved_52 3a
D Qdbfsoon 5i 0
D Qdbfsoof 10i 0
D Qdbfksof 10i 0
D Qdbfkyct 5i 0
D Qdbfgenf 5i 0
D Qdbfodis 10i 0
D Reserved_53 14a
**
D Qdb_Qdbfk Ds Qualified Based( pQdb_Qdbfk )
D Qdbfkfld 10a
D Reserved_59 3a
D Qdbfksq 1a
D* Qdbfksad :1
D* Qdbfksn :2
D* Reserved_60 :1
D* Qdbfksac :1
D* Qdbfkszf :1
D* Qdbfksdf :1
D* Qdbfkft :1
D Reserved_61 18a
**
D Qdb_Qdbfss Ds Qualified Based( pQdb_Qdbfss )
D Reserved_54 2a
D Qdbfssso 1a
D Qdbfssop 2a
D Qdbfssfn 10a
D Qdbfsspnum 5i 0
D Qsosaf 1a
D* Reserved_55 :7
D* Qdbfssfi :1
D Qdbfssfj 5i 0
D Reserved_56 8a
D Qdbfsoso 10i 0
**
D Qdb_Qdbfsp Ds Qualified Based( pQdb_Qdbfsp )
D Qdbfspno 10i 0
D Qdbfspln 5i 0
D Qdbfspin 1a
D Qasopaf 1a
D* Qdbfsigc :1
D* Qdbfshex :1
D* Qdbfsnul :1
D* Reserved_57 :5
D Qdbfsppj 5i 0
D Reserved_58 10a
D Qdbfspvl 128a
**
**-- FILD0200 formats:
D Qdb_Qddfmt Ds Qualified Based( pQdb_Qddfmt )
D Qddbyrtn 10i 0
D Qddbyava 10i 0
D Reserved_62 24a
D Qddfmtf 1a
D Qddfxlto 10i 0
D Qddfrcao 10i 0
D Qddfdico 10i 0
D Qddfrcid 5i 0
D Qddfsrcd 5i 0
D Qddfrtcd 5i 0
D Qddfrlcd 5i 0
D Reserved_64 7a
D Qddftflgs 1a
D Qddflgs 1a
D Reserved_67 4a
D Qddfrlen 10i 0
D Qddfname 10a
D Qddfseq 13a
D Qddftext 50a
D Qddffldnum 5i 0
D Qddf_...
D Identity_Off 10i 0
**
D Qdb_Qddffld Ds Qualified Based( pQdb_Qddffld )
D Qddfdefl 10i 0
D Qddffldi 30a
D Qddfflde 30a
D Qddfftyp 2a
D Qddffiob 1a
D Qddffobo 10i 0
D Qddffibo 10i 0
D Qddffldb 5i 0
D Qddffldd 5i 0
D Qddffldp 5i 0
D Qddffkbs 1a
D Qddffldst 1a
D Qddfjref 5i 0
D Qddffldst2 1a
D Qddflgs2 1a
D Qddfvarx 5i 0
D Reserved_72 2a
D Qddflalc 5i 0
D Qddfdttf 1a
D Qddfdtts 1a
D Qddfcsid 5i 0
D Qddftsid 5i 0
D Qddfhsid 5i 0
D Qddflsid 5i 0
D Qddfldur 1a
D Reserved_73 1a
D Qddfwsid 5i 0
D Reserved_061 1a
D Reserved_062 1a
D Reserved_063 5i 0
D Qddflagco 1a
D Reserved_74 68a
D Qddfcplx 10i 0
D Qddfbmaxl 10i 0
D Qddfbpadl 5i 0
D Qddfdicd 10i 0
D Qddfdftd 10i 0
D Qddfderd 10i 0
D Reserved_75 6a
D Qddftxtd 10i 0
D Reserved_102 2a
D Qddfrefd 10i 0
D Qddfedtl 5i 0
D Qddfedtd 10i 0
D Reserved_76 5i 0
D Qddfchd 10i 0
D Qddfvckl 5i 0
D Qddfvckd 10i 0
D Qddfxals 10i 0
D Qddffpnd 10i 0
D Reserved_77 8a
D Qddfvpx 1a
**
D Qdb_Qddfvchk Ds Qualified Based( pQdb_Qddfvchk )
D Qddfvcnume 5i 0
D Reserved_82 14a
D Qddfvcen 1a
**
D Qdb_Qddfvcst Ds Qualified Based( pQdb_Qddfvcst )
D Qddfvccd 1a
D Qddfvcnump 5i 0
D Qddfvcel 5i 0
D Reserved_83 11a
D Qddfvcpm 1a
**
D Qdb_Qddfvcpr Ds Qualified Based( pQdb_Qddfvcpr )
D Qddfvcpl 5i 0
D Reserved_84 14a
D Qddfvcpv 256a
**
D Qdb_Qddfftxt Ds Qualified Based( pQdb_Qddfftxt )
D Qddfftst 50a
**
D Qdb_Qddfcolh Ds Qualified Based( pQdb_Qddfcolh )
D Qddfch1 20a
D Qddfch2 20a
D Qddfch3 20a
**-- Retrieve database file description:
D RtvDbfDsc Pr ExtPgm( 'QDBRTVFD' )
D RdRcvVar 32767a Options( *VarSize )
D RdRcvVarLen 10i 0 Const
D RdFilRtnQ 20a
D RdFmtNam 8a Const
D RdFilNamQ 20a Const
D RdRcdFmtNam 10a Const
D RdOvrPrc 1a Const
D RdSystem 10a Const
D RdFmtTyp 10a Const
D RdError 32767a Options( *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 1024a Options( *VarSize )
**-- Test bit in string:
D tstbts Pr 10i 0 ExtProc( 'tstbts' )
D String * Value
D BitOfs 10u 0 Value
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**-- Send message by type:
D SndMsgTyp Pr 10i 0
D PxMsgDta 512a Const Varying
D PxMsgTyp 10a Const
**-- Entry parameters:
D CBX123 Pr
D PxDbfNamQ 20a
D PxRcdFmt 10a
**
D CBX123 Pi
D PxDbfNamQ 20a
D PxRcdFmt 10a
/Free
ApiRcvSiz = 65535;
pQdb_Qdbfh = %Alloc( ApiRcvSiz );
Qdb_Qdbfd.Qdbfyavl = 0;
DoU Qdb_Qdbfh.Qdbfyavl <= ApiRcvSiz;
If Qdb_Qdbfh.Qdbfyavl > ApiRcvSiz;
ApiRcvSiz = Qdb_Qdbfh.Qdbfyavl;
pQdb_Qdbfh = %ReAlloc( pQdb_Qdbfh: ApiRcvSiz );
EndIf;
RtvDbfDsc( Qdb_Qdbfh
: ApiRcvSiz
: FilRtnQ
: 'FILD0100'
: PxDbfNamQ
: PxRcdFmt
: '0'
: '*LCL'
: '*EXT'
: ERRC0100
);
EndDo;
If ERRC0100.BytAvl = *Zero;
pQdb_Qdbfb = pQdb_Qdbfh + Qdb_Qdbfh.Qdbfos;
If tstbts( %Addr( Qdb_Qdbfh.Qdbfhflg ): 2 ) = 1;
FilTyp = 'LF';
Else;
FilTyp = 'PF';
EndIf;
FilNam = FilRtnQ.FilNam;
LibNam = FilRtnQ.LibNam;
For RcdIdx = 1 To Qdb_Qdbfh.Qdbflbnum;
If PxRcdFmt = Qdb_Qdbfb.Qdbft Or
PxRcdFmt = '*FIRST';
RcdFmt = Qdb_Qdbfb.Qdbft;
If Qdb_Qdbfh.Qdbfpact = 'AR';
AccPth = '*ARRIVAL';
Else;
AccPth = '*KEYED';
EndIf;
If tstbts( %Addr( Qdb_Qdbfh.Qdbfhflg ): 6 ) = 1;
ExSr GetKeyFlds;
EndIf;
If tstbts( %Addr( Qdb_Qdbfh.Qdbfhflg ): 9 ) = 1;
ExSr GetSltOmit;
EndIf;
Leave;
EndIf;
If RcdIdx < Qdb_Qdbfh.Qdbflbnum;
pQdb_Qdbfb = pQdb_Qdbfb + %Size( Qdb_Qdbfb );
EndIf;
EndFor;
EndIf;
If ERRC0100.BytAvl = *Zero;
ApiRcvSiz = 65535;
pQdb_Qddfmt = %Alloc( ApiRcvSiz );
DoU Qdb_Qddfmt.Qddbyava <= ApiRcvSiz;
If Qdb_Qddfmt.Qddbyava > ApiRcvSiz;
ApiRcvSiz = Qdb_Qddfmt.Qddbyava;
pQdb_Qddfmt = %ReAlloc( pQdb_Qddfmt: ApiRcvSiz );
EndIf;
RtvDbfDsc( Qdb_Qddfmt
: ApiRcvSiz
: FilRtnQ
: 'FILD0200'
: PxDbfNamQ
: PxRcdFmt
: '0'
: '*LCL'
: '*EXT'
: ERRC0100
);
EndDo;
If ERRC0100.BytAvl = *Zero;
pQdb_Qddffld = %Addr( Qdb_Qddfmt ) + 256;
RcdLen = Qdb_Qddfmt.Qddfrlen;
FldCnt = Qdb_Qddfmt.Qddffldnum;
For FldIdx = 1 To Qdb_Qddfmt.Qddffldnum;
If Qdb_Qddffld.Qddftxtd > *Zero;
pQdb_Qddfftxt = pQdb_Qddffld + Qdb_Qddffld.Qddftxtd;
Else;
pQdb_Qddfftxt = *Null;
EndIf;
If Qdb_Qddffld.Qddfchd > *Zero;
pQdb_Qddfcolh = pQdb_Qddffld + Qdb_Qddffld.Qddfchd;
Else;
pQdb_Qddfcolh = *Null;
EndIf;
ExSr PrtDtlLin;
If Qdb_Qddffld.Qddfvckd > *Zero;
ExSr PrtChkVal;
EndIf;
If FldIdx < Qdb_Qddfmt.Qddffldnum;
pQdb_Qddffld = pQdb_Qddffld + Qdb_Qddffld.Qddfdefl;
EndIf;
EndFor;
ExSr PrtKeyFld;
ExSr PrtSltStm;
EndIf;
DeAlloc pQdb_Qddfmt;
EndIf;
DeAlloc pQdb_Qdbfh;
If ERRC0100.BytAvl > *Zero;
SndEscMsg( ERRC0100.MsgId
: 'QCPFMSG'
: %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - 16 )
);
EndIf;
SndMsgTyp( 'Field description list has been printed.': '*COMP' );
*InLr = *On;
Return;
BegSr PrtChkVal;
pQdb_Qddfvchk = pQdb_Qddffld + Qdb_Qddffld.Qddfvckd;
pQdb_Qddfvcst = %Addr( Qdb_Qddfvchk.Qddfvcen );
For ChkIdx = 1 To Qdb_Qddfvchk.Qddfvcnume;
pQdb_Qddfvcpr = %Addr( Qdb_Qddfvcst.Qddfvcpm );
TxtLin2 = ChkKwdA( %Lookup( Qdb_Qddfvcst.Qddfvccd: ChkHexA ));
For ValIdx = 1 To Qdb_Qddfvcst.Qddfvcnump;
TxtLin2 = %TrimR( TxtLin2 ) + ' ' +
%Subst( Qdb_Qddfvcpr.Qddfvcpv
: 1
: Qdb_Qddfvcpr.Qddfvcpl
);
If ValIdx < Qdb_Qddfvcst.Qddfvcnump;
pQdb_Qddfvcpr = pQdb_Qddfvcpr + 16 + Qdb_Qddfvcpr.Qddfvcpl;
EndIf;
EndFor;
ExSr PrtHdrLin;
Except DtlLin2;
If ChkIdx < Qdb_Qddfvchk.Qddfvcnume;
pQdb_Qddfvcpr = %Addr( Qdb_Qddfvcst.Qddfvcpm );
pQdb_Qddfvcst = pQdb_Qddfvcst + Qdb_Qddfvcst.Qddfvcel;
EndIf;
EndFor;
EndSr;
BegSr PrtKeyFld;
ExSr PrtHdrLin;
SpcTxt = AccPth + ' ' + KeyTyp;
Except HdrKey;
Except SpcLin;
For KeyIdx = 1 To %Elem( KeyFld );
If KeyFld(KeyIdx) = *Blank;
Leave;
EndIf;
ExSr PrtHdrLin;
SpcTxt = %Char( KeyIdx ) + ' ' + KeyFld(KeyIdx);
Except SpcLin;
EndFor;
EndSr;
BegSr PrtSltStm;
If FilTyp = 'LF';
ExSr PrtHdrLin;
Except HdrSlt;
If SltStm(1) = *Blank;
SpcTxt = '*NONE';
Except SpcLin;
Else;
For SltIdx = 1 To %Elem( SltStm );
If SltStm(SltIdx) = *Blank;
Leave;
EndIf;
ExSr PrtHdrLin;
SpcTxt = SltStm(SltIdx);
Except SpcLin;
EndFor;
EndIf;
EndIf;
EndSr;
BegSr GetKeyFlds;
If Qdb_Qdbfh.Qdbfpact = 'KU';
KeyTyp = '*UNIQUE';
EndIf;
pQdb_Qdbfk = pQdb_Qdbfh + Qdb_Qdbfb.Qdbfksof;
For KeyIdx = 1 To Qdb_Qdbfb.Qdbfbgky;
KeyFld(KeyIdx) = Qdb_Qdbfk.Qdbfkfld;
If KeyIdx < Qdb_Qdbfb.Qdbfbgky;
pQdb_Qdbfk = pQdb_Qdbfk + %Size( Qdb_Qdbfk );
EndIf;
EndFor;
EndSr;
BegSr GetSltOmit;
pQdb_Qdbfss = pQdb_Qdbfh + Qdb_Qdbfb.Qdbfsoof;
For SltIdx = 1 To Qdb_Qdbfb.Qdbfsoon;
If Qdb_Qdbfss.Qdbfssop <> 'AL';
SltStm(SltIdx) = Qdb_Qdbfss.Qdbfssso + ' ' +
Qdb_Qdbfss.Qdbfssfn + ' ' +
SltKwdA( %Lookup( Qdb_Qdbfss.Qdbfssop
: SltCodA
));
pQdb_Qdbfsp = pQdb_Qdbfh + Qdb_Qdbfss.Qdbfsoso;
For ValIdx = 1 To Qdb_Qdbfss.Qdbfsspnum;
SltStm(SltIdx) = SltStm(SltIdx) + ' ' +
%Subst( Qdb_Qdbfsp.Qdbfspvl
: 1
: Qdb_Qdbfsp.Qdbfspln - 20
);
If ValIdx < Qdb_Qdbfss.Qdbfsspnum;
pQdb_Qdbfsp = pQdb_Qdbfh + Qdb_Qdbfsp.Qdbfspno;
EndIf;
EndFor;
EndIf;
If SltIdx < Qdb_Qdbfb.Qdbfsoon;
pQdb_Qdbfss = pQdb_Qdbfss + %Size( Qdb_Qdbfss );
EndIf;
EndFor;
EndSr;
BegSr PrtDtlLin;
ExSr PrtHdrLin;
Clear OutDtl;
FldNam = Qdb_Qddffld.Qddfflde;
FldTyp = TypTxtA( %Lookup( Qdb_Qddffld.Qddfftyp
: TypHexA
));
KeyIdx = %Lookup( FldNam: KeyFld );
If KeyIdx > *Zero;
KeySeq = %Char( KeyIdx );
If KeyTyp = '*UNIQUE';
%Subst( KeySeq: %Size( KeySeq ): 1 ) = 'U';
EndIf;
EndIf;
BufPos = Qdb_Qddffld.Qddffobo + 1;
FldLen = Qdb_Qddffld.Qddffldb;
If Qdb_Qddffld.Qddffldd > *Zero;
EvalR FldDig = %Char( Qdb_Qddffld.Qddffldd );
EvalR FldDec = %Char( Qdb_Qddffld.Qddffldp );
EndIf;
If pQdb_Qddfftxt <> *Null;
FldTxt = Qdb_Qddfftxt.Qddfftst;
EndIf;
If pQdb_Qddfcolh <> *Null;
FldHdg = Qdb_Qddfcolh.Qddfch1 + ' ' +
Qdb_Qddfcolh.Qddfch2 + ' ' +
Qdb_Qddfcolh.Qddfch3;
EndIf;
Except DtlLin;
If FldTxt <> FldHdg And FldTxt > *Blanks;
TxtLin2 = FldTxt;
Except DtlLin2;
EndIf;
EndSr;
BegSr PrtHdrLin;
If PrtInf.CurLin > PrtInf.OvfLin - 6 Or
PrtInf.WrtCnt = *Zero;
Except Header;
EndIf;
EndSr;
Begsr *InzSr;
Time = Time;
PrtInf.WrtCnt = *Zero;
PrtInf.CurLin = *Zero;
EndSr;
/End-Free
**-- Print file definition:
OQSYSPRT EF Header 2 3
O UDATE Y 8
O Time 18 ' : : '
O 74 'Print file field descrip-
O tion'
O 107 'Program:'
O PsPgmNam 118
O 126 'Page:'
O PAGE + 1
OQSYSPRT EF Header 1
O 16 'File . . . . . :'
O FilNam 28
O 56 'Record format . . . :'
O RcdFmt 68
O 96 'Record length . . . :'
O RcdLen 3 103
OQSYSPRT EF Header 2
O 16 ' Library . . :'
O LibNam 28
O 56 'File type . . . . . :'
O FilTyp 68
O 96 'Record field count :'
O FldCnt 3 103
OQSYSPRT EF Header 1
O 10 'Field name'
O 22 'Field type'
O 30 'Buffer'
O 38 'Length'
O 46 'Digits'
O 52 'Dec.'
O 57 'Key'
O 93 'Column heading/text/check -
O values'
**
OQSYSPRT EF DtlLin 1
O FldNam 10
O FldTyp 22
O BufPos 3 29
O FldLen 3 36
O FldDig 44
O FldDec 50
O KeySeq 58
O FldHdg 123
**
OQSYSPRT EF DtlLin2 1
O TxtLin2 131
**
OQSYSPRT EF HdrKey 1
O 31 'Access path . . . . . . . -
O . . :'
**
OQSYSPRT EF HdrSlt 1
O 31 'Select/omit statements . -
O . . :'
**
OQSYSPRT EF SpcLin 1
O SpcTxt 131
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgF 10a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( PxMsgId
: PxMsgF + '*LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*ESCAPE'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndEscMsg E
**-- Send message by type: ---------------------------------------------**
P SndMsgTyp B
D Pi 10i 0
D PxMsgDta 512a Const Varying
D PxMsgTyp 10a Const
**
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9897'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: PxMsgTyp
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndMsgTyp E
Command
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( PRTFFD ) */
/* Pgm( CBX123 ) */
/* SrcMbr( CBX123X ) */
/* HlpPnlGrp( CBX123H ) */
/* HlpId( *CMD ) */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Print File Field Description' )
Parm FILE Q0001 +
Min( 1 ) +
File( *UNSPFD ) +
Choice( *NONE ) +
Prompt( 'File' )
Parm RCDFMT *Name +
Dft( *FIRST ) +
SpcVal(( *FIRST )) +
Expr( *YES ) +
Prompt( 'Record format' )
Q0001: Qual *Name 10 +
Min( 1 ) +
Expr( *YES )
Qual *Name 10 +
Dft( *LIBL ) +
SpcVal(( *LIBL ) +
( *CURLIB )) +
Expr( *YES ) +
Prompt( 'Library' )
Panel group
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtPnlGrp PnlGrp( CBX123H )
.* SrcFile( QPNLSRC )
.* SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='PRTFFD'.Print file field description - Help
:P.
The Print File Field Description (PRTFFD) command prints database file
field-level information for the specified file. This information
includes data type, length, buffer position and check values as well as
key field specification and, for logical files, any select/omit criteria
specification.
:P.
:EHELP.
:HELP NAME='PRTFFD/FILE'.File (FILE) - Help
:XH3.File (FILE)
:P.
Specifies the name and library of the database file for which to print
the field information.
:P.
This is a required parameter.
:P.
:XH3.Library
:P.
Specify the name of the library where the database file is located.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*LIBL:EPK.
:PD.
All libraries in the job's library list are searched until the first
match is found.
:PT.:PK.*CURLIB:EPK.
:PD.
The current library for the job is searched. If no library is
specified as the current library for the job, the QGPL library is used.
:PT.:PV.library-name:EPV.
:PD.
Specify the name of the library to qualify the file name.
:EPARML.
:EHELP.
:HELP NAME='PRTFFD/RCDFMT'.Record format (RCDFMT) - Help
:XH3.Record format (RCDFMT)
:P.
If a logical file having more than one record format was specified as
the file name, this parameter is used to identify the record format
that you want used when retrieving the field information.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*FIRST:EPK.
:PD.
The first record format found will be used to identify the file record
format.
:PT.:PV.record-format-name:EPV.
:PD.
Specify the name of the record format to use.
:EPARML.
:EHELP.
:EPNLGRP.
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
|
|
Back
Create User Index
/*-------------------------------------------------------------------*/
/* */
/* Command . . : CRTUSRIDX */
/* Description : Create user index command */
/* Author . . : Carsten Flensburg */
/* Published . : Club Tech iSeries Programming Tips Newsletter */
/* Date . . . : September 23, 2004 */
/* */
/* */
/* Command processing API: */
/* QUSCRTUI Create user index Creates a user index object */
/* in either the user domain */
/* or the system domain. */
/* */
/* */
/* Programmer's notes: */
/* On pre-V5R2 systems the IDXSIZOPT parameter is not supported. */
/* */
/* An upcoming issue of APIs by Example will demonstrate the use */
/* of some of the user index APIs in RPG/IV. */
/* */
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( CRTUSRIDX ) */
/* Pgm( QUSCRTUI ) */
/* SrcMbr( CBX124X ) */
/* HlpPnlGrp( CBX124H ) */
/* HlpId( *CMD ) */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Create User Index' )
Parm USRIDX Q0001 +
Min( 1 ) +
Choice( *NONE ) +
Prompt( 'User index' 1 )
Parm EXTATR *Name 10 +
Dft( *NONE ) +
SpcVal(( *NONE ' ' )) +
Expr( *YES ) +
Prompt( 'Extended attribute' 2 )
Parm ENTLENATR *Char 1 +
Rstd( *YES ) +
Dft( *FIXED ) +
SpcVal(( *FIXED 'F' ) ( *VARYING 'V' )) +
Expr( *YES ) +
Prompt( 'Entry length attribute' 3 )
Parm ENTLEN *Int4 +
Range( 1 2000 ) +
SpcVal(( *SHORT 0 ) ( *MAX -1 )) +
Expr( *YES ) +
Prompt( 'Entry length' 4 )
Parm SEQ *Char 1 +
Rstd( *YES ) +
Dft( *NONE ) +
SpcVal(( *NONE '0' ) ( *KEYED '1' )) +
Expr( *YES ) +
Prompt( 'Sequence' 5 )
Parm KEYLEN *Int4 +
Range( 1 2000 ) +
Expr( *YES ) +
PmtCtl( P0001 ) +
Prompt( 'Key length' 6 )
Parm FORCE *Char 1 +
Rstd( *YES ) +
Dft( *NO ) +
SpcVal(( *NO '0' ) ( *YES '1' )) +
Expr( *YES ) +
Prompt( 'Force to auxiliary storage' 7 )
Parm IDXOPZ *Char 1 +
Rstd( *YES ) +
Dft( *RANDOM ) +
SpcVal(( *RANDOM '0' ) ( *SEQ '1' )) +
Expr( *YES ) +
Prompt( 'Index optimization' 8 )
Parm AUT *Name 10 +
Dft( *LIBCRTAUT ) +
SpcVal(( *LIBCRTAUT ) +
( *CHANGE ) +
( *ALL ) +
( *USE ) +
(*EXCLUDE )) +
Expr( *YES ) +
PmtCtl( *PMTRQS ) +
Prompt( 'Authority' 9 )
Parm TEXT *Char 50 +
Dft( *BLANK ) +
SpcVal(( *BLANK '' )) +
Expr( *YES ) +
Prompt( 'Text ''description''' 10 )
Parm REPLACE *Char 10 +
Rstd( *YES ) +
Dft( *YES ) +
SpcVal(( *YES ) ( *NO )) +
Expr( *YES ) +
PmtCtl( *PMTRQS ) +
Prompt( 'Replace' 11 )
Parm ERROR *Int4 +
Constant( 0 )
Parm DOMAIN *Char 10 +
Rstd( *YES ) +
Dft( *DEFAULT ) +
SpcVal(( *DEFAULT ) ( *SYSTEM ) ( *USER )) +
Expr( *YES ) +
PmtCtl( *PMTRQS ) +
Prompt( 'Domain' 12 )
Parm USGTRK *Char 1 +
Rstd( *YES ) +
Dft( *NO ) +
SpcVal(( *NO '0' ) ( *YES '1' )) +
Expr( *YES ) +
PmtCtl( *PMTRQS ) +
Prompt( 'Usage tracking' 13 )
Parm IDXSIZOPT *Char 1 +
Rstd( *YES ) +
Dft( *MAX4GB ) +
SpcVal(( *MAX4GB '0' ) ( *MAX1TB '1' )) +
Expr( *YES ) +
PmtCtl( *PMTRQS ) +
Prompt( 'Index size option' 14 )
Q0001: Qual *Name 10 +
Min( 1 ) +
Expr( *YES )
Qual *NAME 10 +
Dft( *CURLIB ) +
SpcVal(( *CURLIB )) +
Expr( *YES ) +
Prompt( 'Library' )
P0001: PmtCtl Ctl( SEQ ) +
Cond(( *EQ '1' ))
Dep Ctl( &SEQ *NE '1' ) +
Parm(( KEYLEN )) +
NbrTrue( *EQ 0 ) +
MsgId( CPD9501 )
Dep Ctl( &SEQ *EQ '1' ) +
Parm(( KEYLEN )) +
MsgId( CPD9502 )
Panel group
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtPnlGrp PnlGrp( CBX124H )
.* SrcFile( QPNLSRC )
.* SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='CRTUSRIDX'.Create User Index - Help
:P.
The Create User Index (CRTUSRIDX) command creates a user index and
stores it in either the user domain or the system domain.
:P.
A system-domain user index cannot be saved to a release prior to
Version 2 Release 3 Modification 0. A user-domain user index can be
directly manipulated with MI instructions and can also be accessed
using system APIs at all security levels.
:P.
:NT.
If the user index is larger than 4 gigabytes, it cannot be saved to a
release prior to Version 5 Release 2 Modification 0.
:ENT.
:P.
:NT.
For performance reasons, the *USRIDX object is created before checking
to see if it exists in the library specified for the qualified user
index name. If you have an application using this API repeatedly, even
if you are using *NO for the replace parameter, permanent system
addresses will be used.
:ENT.
:P.
:XH3.&MSG(CPX0005,QCPFMSG). CRTUSRIDX
:IMHELP NAME='CRTUSRIDX/ERROR/MESSAGES'.
:EHELP.
:HELP NAME='CRTUSRIDX/ERROR/MESSAGES'.&MSG(CPX0005,QCPFMSG).CRTUSRIDX - Help
:P.
:HP3.*ESCAPE &MSG(CPX0006,QCPFMSG).:EHP3.
:DL COMPACT.
:DT.CPF2143:DD.&MSG(CPF2143,QCPFMSG).
:DT.CPF2144:DD.&MSG(CPF2144,QCPFMSG).
:DT.CPF2283:DD.&MSG(CPF2283,QCPFMSG).
:DT.CPF24B4:DD.&MSG(CPF24B4,QCPFMSG).
:DT.CPF3CF1:DD.&MSG(CPF3CF1,QCPFMSG).
:DT.CPF3CF2:DD.&MSG(CPF3CF2,QCPFMSG).
:DT.CPF3C0A:DD.&MSG(CPF3C0A,QCPFMSG).
:DT.CPF3C0B:DD.&MSG(CPF3C0B,QCPFMSG).
:DT.CPF3C0C:DD.&MSG(CPF3C0C,QCPFMSG).
:DT.CPF3C0D:DD.&MSG(CPF3C0D,QCPFMSG).
:DT.CPF3C0E:DD.&MSG(CPF3C0E,QCPFMSG).
:DT.CPF3C03:DD.&MSG(CPF3C03,QCPFMSG).
:DT.CPD3C01:DD.&MSG(CPD3C01,QCPFMSG).
:DT.CPD3C02:DD.&MSG(CPD3C02,QCPFMSG).
:DT.CPD3C03:DD.&MSG(CPD3C03,QCPFMSG).
:DT.CPD3C05:DD.&MSG(CPD3C05,QCPFMSG).
:DT.CPD3C0A:DD.&MSG(CPD3C0A,QCPFMSG).
:DT.CPD3C0B:DD.&MSG(CPD3C0B,QCPFMSG).
:DT.CPD3C0C:DD.&MSG(CPD3C0C,QCPFMSG).
:DT.CPD3C0D:DD.&MSG(CPD3C0D,QCPFMSG).
:DT.CPD3C0E:DD.&MSG(CPD3C0E,QCPFMSG).
:DT.CPF3C2A:DD.&MSG(CPF3C2A,QCPFMSG).
:DT.CPF3C2B:DD.&MSG(CPF3C2B,QCPFMSG).
:DT.CPF3C2D:DD.&MSG(CPF3C2D,QCPFMSG).
:DT.CPF3C29:DD.&MSG(CPF3C29,QCPFMSG).
:DT.CPF3C34:DD.&MSG(CPF3C34,QCPFMSG).
:DT.CPF3C36:DD.&MSG(CPF3C36,QCPFMSG).
:DT.CPF3C45:DD.&MSG(CPF3C45,QCPFMSG).
:DT.CPF3C49:DD.&MSG(CPF3C49,QCPFMSG).
:DT.CPF3C90:DD.&MSG(CPF3C90,QCPFMSG).
:DT.CPF3C93:DD.&MSG(CPF3C93,QCPFMSG).
:DT.CPF3C95:DD.&MSG(CPF3C95,QCPFMSG).
:DT.CPF8100:DD.All CPF81xx messages could be returned. xx is from 01 to FF.
:DT.CPF9810:DD.&MSG(CPF9810,QCPFMSG).
:DT.CPF9820:DD.&MSG(CPF9820,QCPFMSG).
:DT.CPF9830:DD.&MSG(CPF9830,QCPFMSG).
:DT.CPF9838:DD.&MSG(CPF9838,QCPFMSG).
:DT.CPF9870:DD.&MSG(CPF9870,QCPFMSG).
:DT.CPF9872:DD.&MSG(CPF9872,QCPFMSG).
:EDL.
:EHELP.
:HELP NAME='CRTUSRIDX/USRIDX'.User index (USRIDX) - Help
:XH3.User index (USRIDX)
:P.
Specifies the name and library of the user index being created.
:P.
This is a required parameter.
:P.
:XH3.Library
:P.
Defines the location of the user index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*CURLIB:EPK.
:PD.
The current library for the job is used to locate the user index. If
no current library entry exists in the library list, QGPL is used.
:PT.:PV.library-name:EPV.
:PD.
Specify the library where the user queue is located.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/EXTATR'.Extended attribute (EXTATR) - Help
:XH3.Extended attribute (EXTATR)
:P.
The extended attribute of the user index. For example, an object type
of *FILE has an extended attribute of PF (physical file), LF (logical
file), DSPF (display file), SAVF (save file), and so on.
:P.
The extended attribute must be a valid *NAME. You can enter this
parameter in uppercase, lowercase, or mixed case. The command
automatically converts it to uppercase.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NONE:EPK.
:PD.
No extended attribute is assigned to the user queue.
:PT.:PV.extended-attribute-name:EPV.
:PD.
Specify a name to be used as the extended attribute for the user queue
object.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/ENTLENATR'.Entry length attribute (ENTLENATR) - Help
:XH3.Entry length attribute (ENTLENATR)
:P.
Specifies Whether there are fixed-length or variable-length entries in
the user index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*FIXED:EPK.
:PD.
The user index entries have a fixed length.
:PT.:PK.*VARYING:EPK.
:PD.
The user index entries have a variable length.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/ENTLEN'.Entry length (ENTLEN) - Help
:XH3.Entry length (ENTLEN)
:P.
The length of entries in the index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK.*SHORT:EPK.
:PD.
Enables a maximum entry length of 120 bytes and a key length from 1
through 120.
:PT.:PK.*MAX:EPK.
:PD.
Enables a maximum entry length of 2000 and a key length from 1 through
2000.
:PT.:PV.entry-length:EPV.
:PD.
The valid values for fixed-length entries are from 1 through 2000.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/SEQ'.Sequence (SEQ) - Help
:XH3.Sequence (SEQ)
:P.
Whether the inserts to the index are by key.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NONE:EPK.
:PD.
Index entries are not inserted by key.
:PT.:PK.*KEYED:EPK.
:PD.
Index entries are inserted by key.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/KEYLEN'.Key length (KEYLEN) - Help
:XH3.Key length (KEYLEN)
:P.
The length in bytes of the index entry key from 1 to 2000 if you specify
the user index type as keyed. If you specify that the user index is
not a keyed user index, the value must be 0.
:EHELP.
:HELP NAME='CRTUSRIDX/FORCE'.Force to auxiliary storage (FORCE) - Help
:XH3.Force to auxiliary storage (FORCE)
:P.
Whether the updates to the index are written synchronously to auxiliary
storage on each update to the index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NO:EPK.
:PD.
Updates to index entries are not immediately forced to auxiliary
storage.
:PT.:PK.*YES:EPK.
:PD.
Updates to index entries are immediately forced to auxiliary
storage.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/IDXOPZ'.Index optimization (IDXOPZ) - Help
:XH3.Index optimization (IDXOPZ)
:P.
Specifies the type of access in which to optimize the index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*RANDOM:EPK.
:PD.
Optimize for random references.
:PT.:PK.*SEQ:EPK.
:PD.
Optimize for sequential references.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/AUT'.Authority (AUT) - Help
:XH3.Authority (AUT)
:P.
The authority you give to the users who do not have specific private or
group authority to the user index. Once the user index has been
created, its public authority stays the same when it is moved to
another library or restored from backup media.
:NT.
If the replace parameter is used and a user index exists to be replaced,
this parameter is ignored. All authorities are transferred from the
replaced user index to the new one.
:ENT.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*LIBCRTAUT:EPK.
:PD.
The public authority for the user index is taken from the CRTAUT value
for the target library when the object is created. If the CRTAUT value
for the library changes later, that change does not affect user indexes
already created. If the CRTAUT value contains an authorization list
name and that authorization list secures an object, do not delete the
list. If you do, the next time you run this command with the *LIBCRTAUT
parameter, it will fail.
:PT.:PK.*CHANGE:EPK.
:PD.
The user has read, add, update, and delete authority to the user index
and can read the object description.
:PT.:PK.*ALL:EPK.
:PD.
The user can perform all authorized operations on the user index.
:PT.:PK.*USE:EPK.
:PD.
The user can read the object description and the user index' contents
but cannot change them.
:PT.:PK.*EXCLUDE:EPK.
:PD.
The user cannot access the user index in any way.
:PT.:PV.authorization-list-name:EPV.
:PD.
The user index is secured by the specified authorization list, and its
public authority is set to *AUTL. The specified authorization list must
exist on the system when this command is issued. If it does not exist,
the create process fails, and an error message is returned to the
caller.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/TEXT'.Text 'description' (TEXT) - Help
:XH3.Text 'description' (TEXT)
:P.
Specifies text that briefly describes the user index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*BLANK:EPK.
:PD.
No text is specified.
:PT.:PV.text-'description':EPV.
:PD.
Specify no more than 50 characters, enclosed in apostrophes.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/REPLACE'.Replace (REPLACE) - Help
:XH3.Replace (REPLACE)
:P.
Specifies whether to replace an existing user index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NO:EPK.
:PD.
Do not replace an existing user index of the same name and library.
:PT.:PK.*YES:EPK.
:PD.
Replace an existing user index of the same name and library.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/DOMAIN'.Domain (DOMAIN) - Help
:XH3.Domain (DOMAIN)
:P.
The domain into which the user index should be created.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*DEFAULT:EPK.
:PD.
Allows the system to decide into which domain the object should be
created.
:PT.:PK.*SYSTEM:EPK.
:PD.
Creates the user index object into the system domain. The API can
always create a user index into the system domain, regardless of the
security level running. However, if you are running at security level
40 or greater, you must use APIs to access system-domain user index
objects.
:PT.:PK.*USER:EPK.
:PD.
Attempts to create the user index object into the user domain. This is
not always possible. If the library you are creating the user index
into does not appear in the QALWUSRDMN system value, the API cannot
create the user index into the user domain. An error message will be
returned.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/USGTRK'.Usage tracking (USGTRK) - Help
:XH3.Usage tracking (USGTRK)
:P.
The usage tracking state. Usage tracking provides machine checkpoints
to improve availability of user indexes. If a user index is found to be
a state of partial change, it will be marked as damaged.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NO:EPK.
:PD.
Do not track usage state.
:PT.:PK.*YES:EPK.
:PD.
Track usage state.
:EPARML.
:EHELP.
:HELP NAME='CRTUSRIDX/IDXSIZOPT'.Index size option (IDXSIZOPT) - Help
:XH3.Index size option (IDXSIZOPT)
:P.
The maximum size of the user index.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*MAX4GB:EPK.
:PD.
The maximum size of the user index is 4 gigabytes.
:PT.:PK.*MAX1TB:EPK.
:PD.
The maximum size of the user index is 1 terabyte.
:EPARML.
:EHELP.
:EPNLGRP.
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
|
|
Back
User Index APIs
**
** Program . . : CBX125T
** Description : Demonstrating the use of a user index
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : October 14, 2004
**
**
** Please note the explanation of the following user index attributes:
**
** Number of entries added:
** The number of entries added to the user index. The number of
** entries currently in the index can be obtained by subtracting the
** number of entries removed from the number of entries added.
**
** Number of retrieve operations:
** The number of times either the FNDINXEN (find independent index
** entry) MI instruction or Retrieve User Index Entry (QUSRTVUI) API
** has been used on this user index. The QUSRUIAT API or MATINXAT
** (materialize independent index attributes) MI instruction sets the
** number of retrieve operations to 0 after the retrieve or materialize
** is completed.
**
**
** 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( CBX125T ) - Press F10
**
** Call Pgm( CBX125T ) - Press F10 repeatedly
**
**
** Compile options:
**
** CrtRpgMod Module( CBX125T )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX125T )
** Module( CBX125T )
**
**
**-- Control spec: -----------------------------------------------------**
H Option( *SrcStmt )
**-- Api error data structure:
D ERRC0100 Ds Qualified
D BytPrv 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0
D MsgId 7a
D 1a
D MsgDta 256a
**-- Global variables:
D CurNbrIdxE s 10i 0
**-- Key & entry definition:
D IdxEnt Ds Qualified
D Key 24a Inz( *All'Key' )
D EntDta 512a Inz( *All'Data' )
**-- User index APIs parameters:
D IDXE0100 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D Entry Like( IdxEnt )
**
D EntLoc Ds Qualified
D EntOfs 10i 0
D EntLen 10i 0
**
D RtnLib s 10a
D EntAdd s 10i 0
**
D SchCri s Like( IdxEnt.Key )
D RmvCri s Like( IdxEnt.Key )
D EntNbrRtv s 10i 0
D EntNbrRmv s 10i 0
**
D IDX_NAM_Q c 'USRIDX QTEMP'
D ENT_FIX c 'F'
D UPD_IMD c '1'
D AUT_CHG c '*CHANGE'
D RPL_NO c '*NO'
D IDX_OPZ_SEQ c '0'
D KEY_INS_BYKEY c '1'
D DOM_DFT c '*DEFAULT'
**
D ENT_SCH_EQ c 1
D ENT_RMV_EQ c 1
D ENT_LOC_IGN c x'0000000000000000'
D IDX_INS_RPL c 2
D CRI_OFS_FIRST c 0
D RMV_ENT_MAX c 4095
D RTN_ENT_NONE c 0
D RTN_ENT_SINGLE c 1
**-- Retrieve user index attributes parameters:
D IDXA0100 Ds Qualified
D BytRtn 10i 0
D BytAvl 10i 0
D IdxNam 10a
D LibNam 10a
D EntAtr 1a
D IdxUpd 1a
D KeyIns 1a
D IdxOpz 1a
D 4a
D EntLen 10i 0
D EntLenMax 10i 0
D KeyLen 10i 0
D NbrEntAdd 10i 0
D NbrEntRmv 10i 0
D NbrRtvOpr 10i 0
**-- Create user index:
D CrtUsrIdx Pr ExtPgm( 'QUSCRTUI' )
D CxIdxNamQ 20a Const
D CxExtAtr 10a Const
D CxEntAtr 1a Const
D CxEntLen 10i 0 Const
D CxKeyIns 1a Const
D CxKeyLen 10i 0 Const
D CxIdxUpd 1a Const
D CxIdxOpz 1a Const
D CxPubAut 10a Const
D CxText 50a Const
** Optional 1:
D CxReplace 10a Const Options( *NoPass )
D CxError 32767a Options( *NoPass: *VarSize )
** Optional 2:
D CxDomain 10a Const Options( *NoPass )
**-- Add user index entries:
D AddUsrIdxE Pr ExtPgm( 'QUSADDUI' )
D AxRtnLib 10a
D AxEntAdd 10i 0
D AxIdxNamQ 20a Const
D AxInsTyp 10i 0 Const
D AxEntry 2000a Const Options( *VarSize )
D AxEntLen 10i 0 Const
D AxEntLoc 8a Const
D AxEntNbr 10i 0 Const
D AxError 32767a Options( *VarSize )
**-- Retrieve user index entries:
D RtvUsrIdxE Pr ExtPgm( 'QUSRTVUI' )
D RxRcvVar 2008a Options( *VarSize )
D RxRcvVarLen 10i 0 Const
D RxEntLoc 2000a Options( *VarSize )
D RxEntLocLen 10i 0 Const
D RxEntNbrRtv 10i 0
D RxRtnLib 10a
D RxIdxNamQ 20a Const
D RxFmtNam 10a Const
D RxMaxEnt 10i 0 Const
D RxSchTyp 10i 0 Const
D RxSchCri 2000a Const Options( *Varsize )
D RxSchCriLen 10i 0 Const
D RxSchCriOfs 10i 0 Const
D RxError 32767a Options( *VarSize )
**-- Remove user index entries:
D RmvUsrIdxE Pr ExtPgm( 'QUSRMVUI' )
D RmEntNbrRmv 10i 0
D RmRcvVar 2008a Options( *VarSize )
D RmRcvVarLen 10i 0 Const
D RmEntLoc 2000a Options( *VarSize )
D RmEntLocLen 10i 0 Const
D RmRtnLib 10a Const
D RmIdxNamQ 20a Const
D RmFmtNam 10a Const
D RmMaxEnt 10i 0 Const
D RmRmvTyp 10i 0 Const
D RmRmvCri 2000a Const Options( *Varsize )
D RmRmvCriLen 10i 0 Const
D RmRmvCriOfs 10i 0 Const
D RmError 32767a Options( *VarSize )
**-- Retrieve user index attributes:
D RtvUsrIdxA Pr ExtPgm( 'QUSRUIAT' )
D RaRcvVar 60a Options( *VarSize )
D RaRcvVarLen 10i 0 Const
D RaFmtNam 10a Const
D RaIdxNamQ 20a Const
D RaError 32767a Options( *VarSize )
**-- Delete user index:
D DltUsrIdx Pr ExtPgm( 'QUSDLTUI' )
D DxIdxNamQ 20a Const
D DxError 32767a Options( *VarSize )
**-- Get current number of entries:
D GetCurNbrE Pr 10i 0
D GnIdxNamQ 20a Const
**
**-- Mainline -----------------------------------------------------------**
/Free
CrtUsrIdx( IDX_NAM_Q
: *Blanks
: ENT_FIX
: %Size( IdxEnt )
: KEY_INS_BYKEY
: %Size( IdxEnt.Key )
: UPD_IMD
: IDX_OPZ_SEQ
: AUT_CHG
: *Blanks
: RPL_NO
: ERRC0100
: DOM_DFT
);
//-- Check number of current entries:
CurNbrIdxE = GetCurNbrE( IDX_NAM_Q );
AddUsrIdxE( RtnLib
: EntAdd
: IDX_NAM_Q
: IDX_INS_RPL
: IdxEnt
: %Size( IdxEnt )
: ENT_LOC_IGN
: RTN_ENT_SINGLE
: ERRC0100
);
//-- Check number of current entries:
CurNbrIdxE = GetCurNbrE( IDX_NAM_Q );
//-- Set retrieve key and clear receiver:
SchCri = IdxEnt.Key;
IdxEnt = *Blanks;
RtvUsrIdxE( IDXE0100
: %Size( IDXE0100 )
: EntLoc
: %Size( EntLoc )
: EntNbrRtv
: RtnLib
: IDX_NAM_Q
: 'IDXE0100'
: 1
: ENT_SCH_EQ
: SchCri
: %Size( SchCri )
: CRI_OFS_FIRST
: ERRC0100
);
//-- Confirm retrieved entry:
IdxEnt = IDXE0100.Entry;
SchCri = IdxEnt.Key;
IdxEnt = *Blanks;
RtvUsrIdxE( IDXE0100
: %Size( IDXE0100 )
: EntLoc
: %Size( EntLoc )
: EntNbrRtv
: RtnLib
: IDX_NAM_Q
: 'IDXE0100'
: 1
: ENT_SCH_EQ
: SchCri
: %Size( SchCri )
: CRI_OFS_FIRST
: ERRC0100
);
IdxEnt = IDXE0100.Entry;
//-- Set remove key:
RmvCri = IdxEnt.Key;
DoW GetCurNbrE( IDX_NAM_Q ) > *Zero;
RmvUsrIdxE( EntNbrRmv
: IDXE0100
: RTN_ENT_NONE
: EntLoc
: RTN_ENT_NONE
: RtnLib
: IDX_NAM_Q
: 'IDXE0100'
: RMV_ENT_MAX
: ENT_RMV_EQ
: RmvCri
: %Size( RmvCri )
: CRI_OFS_FIRST
: ERRC0100
);
EndDo;
DltUsrIdx( IDX_NAM_Q: ERRC0100 );
*InLr = *On;
Return;
/End-Free
**-- Get current number of entries: ------------------------------------**
P GetCurNbrE B
D Pi 10i 0
D GnIdxNamQ 20a Const
/Free
RtvUsrIdxA( IDXA0100
: %Size( IDXA0100 )
: 'IDXA0100'
: GnIdxNamQ
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return IDXA0100.NbrEntAdd - IDXA0100.NbrEntRmv;
EndIf;
/End-Free
P GetCurNbrE E
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
|
|
Back
|
Qp0lSetAttr & Qp0lGetAttr
| |
Set IFS object attribute & Get IFS object attribute
**
** Program . . : CBX127
** Description : Change IFS attributes - CPP
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : November 18, 2004
**
**
**
** Program summary
** ---------------
**
** Unix type APIs:
** Qp0lSetAttr Set IFS object Changes the specified attribute
** attribute for the specified IFS object.
** Not all attributes are supported
** by all file systems.
**
** MI builtins:
** _MEMMOVE Copy memory Copies a string from one pointer
** specified location to another.
**
** 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.
**
**
** Programmer's notes:
** The following Qp0lSetAttr attribute-ID is supported as of V5R1 only:
**
** 27 QP0L_ATTR_CCSID Coded characer set identifier
**
** The following Qp0lSetAttr attribute-IDs are supported as of V5R2 only:
**
** 31 QP0L_ATTR_DISK_STG_OPT How to allocate auxiliary storage
** 32 QP0L_ATTR_MAIN_STG_OPT How to allocate main storage
** 301 QP0L_ATTR_SUID Set effective user ID
** 302 QP0L_ATTR_SGID Set effective group ID
**
**
** Compile options:
** CrtRpgMod Module( CBX127 )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX127 )
** Module( CBX127 )
** ActGrp( *NEW )
**
**
**-- Control specifications: -------------------------------------------**
H Option( *SrcStmt ) BndDir( 'QC2LE' )
**-- API error information:
D ERRC0100 Ds Qualified
D BytPro 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0
D MsgId 7a
D 1a
D MsgDta 256a
**-- Global variables:
D MsgKey s 4a
**-- Object attributes:
D QP0L_ATTR_CREATE_TIME...
D c 4
D QP0L_ATTR_ACCESS_TIME...
D c 5
D QP0L_ATTR_MODIFY_TIME...
D c 7
D QP0L_ATTR_PC_READ_ONLY...
D c 17
D QP0L_ATTR_PC_HIDDEN...
D c 18
D QP0L_ATTR_PC_SYSTEM...
D c 19
D QP0L_ATTR_PC_ARCHIVE...
D c 20
D QP0L_ATTR_SYSTEM_ARCHIVE...
D c 21
D QP0L_ATTR_CODEPAGE...
D c 22
D QP0L_ATTR_ALWCKPWRT...
D c 26
D QP0L_ATTR_CCSID...
D c 27
D QP0L_ATTR_DISK_STG_OPT...
D c 31
D QP0L_ATTR_MAIN_STG_OPT...
D c 32
D QP0L_ATTR_RESET_DATE...
D c 200
D QP0L_ATTR_SUID c 300
D QP0L_ATTR_SGID c 301
**-- File attribute constants:
D QP0L_PC_NOT_READONLY...
D c x'00'
D QP0L_PC_READONLY...
D c x'01'
D QP0L_PC_NOT_HIDDEN...
D c x'00'
D QP0L_PC_HIDDEN...
D c x'01'
D QP0L_PC_NOT_SYSTEM...
D c x'00'
D QP0L_PC_SYSTEM...
D c x'01'
D QP0L_PC_NOT_CHANGED...
D c x'00'
D QP0L_PC_CHANGED...
D c x'01'
D QP0L_SYSTEM_NOT_CHANGED...
D c x'00'
D QP0L_SYSTEM_CHANGED...
D c x'01'
D QP0L_NOT_ALWCKPWRT...
D c x'00'
D QP0L_ALWCKPWRT...
D c x'01'
D QP0L_STG_NORMAL...
D c x'00'
D QP0L_STG_MINIMIZE...
D c x'01'
D QP0L_STG_DYNAMIC...
D c x'02'
D QP0L_SUID_OFF c x'00'
D QP0L_SUID_ON c x'01'
D QP0L_SGID_OFF c x'00'
D QP0L_SGID_ON c x'01'
**- Set attribute:
D SetAtr Pr 10i 0 ExtProc( 'Qp0lSetAttr' )
D SaPthNam * Value
D SaAtrLst * Value
D SaBufSizPrv 10u 0 Value
D SaFlwSymLnk 10u 0 Value
D SaDots 10i 0 Options( *NoPass )
**-- Error number:
D sys_errno Pr * ExtProc( '__errno' )
**-- Error string:
D sys_strerror Pr * ExtProc( 'strerror' )
D errno 10i 0 Value
**-- Copy memory:
D memcpy Pr * ExtProc( '_MEMMOVE' )
D pOutMem * Value
D pInpMem * Value
D iMemSiz 10u 0 Value
**-- 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 32767a Options( *VarSize )
**-- Change IFS attribute: ---------------------------------------------**
D ChgIfsAtr Pr 10i 0
D PxIfsObj 5002a Const Varying
D PxAtrId 10i 0 Const
D PxAtrVal_p * Value
D PxAtrSiz 10i 0 Const
**-- Send diagnostic message:
D SndDiagMsg Pr 10i 0
D PxMsgDta 512a Const Varying
**-- 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
**-- Entry parameters:
D CBX127 Pr
D PxIfsObj 5002a Varying
D PxFlwSymLnk 10i 0
D PxRdOnly 1a
D PxHidden 1a
D PxPcSys 1a
D PxPcArc 1a
D PxSysArc 1a
D PxAlwCkpWrt 1a
D PxCcsId 10i 0
D PxDiskStgOpt 1a
D PxMainStgOpt 1a
D PxSetEuid 1a
D PxSetEgid 1a
**
D CBX127 Pi
D PxIfsObj 5002a Varying
D PxFlwSymLnk 10i 0
D PxRdOnly 1a
D PxHidden 1a
D PxPcSys 1a
D PxPcArc 1a
D PxSysArc 1a
D PxAlwCkpWrt 1a
D PxCcsId 10i 0
D PxDiskStgOpt 1a
D PxMainStgOpt 1a
D PxSetEuid 1a
D PxSetEgid 1a
/Free
If PxCcsId > *Zero;
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_CCSID
: %Addr( PxCcsId )
: %Size( PxCcsId )
);
EndIf;
If PxRdOnly < x'FF';
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_PC_READ_ONLY
: %Addr( PxRdOnly )
: %Size( PxRdOnly )
);
EndIf;
If PxHidden < x'FF';
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_PC_HIDDEN
: %Addr( PxHidden )
: %Size( PxHidden )
);
EndIf;
If PxPcSys < x'FF';
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_PC_SYSTEM
: %Addr( PxPcSys )
: %Size( PxPcSys )
);
EndIf;
If PxPcArc < x'FF';
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_PC_ARCHIVE
: %Addr( PxPcArc )
: %Size( PxPcArc )
);
EndIf;
If PxSysArc < x'FF';
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_SYSTEM_ARCHIVE
: %Addr( PxSysArc )
: %Size( PxSysArc )
);
EndIf;
If PxAlwCkpWrt < x'FF';
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_ALWCKPWRT
: %Addr( PxAlwCkpWrt )
: %Size( PxAlwCkpWrt )
);
EndIf;
If PxDiskStgOpt < x'FF';
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_DISK_STG_OPT
: %Addr( PxDiskStgOpt )
: %Size( PxDiskStgOpt )
);
EndIf;
If PxMainStgOpt < x'FF';
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_MAIN_STG_OPT
: %Addr( PxMainStgOpt )
: %Size( PxMainStgOpt )
);
EndIf;
If PxSetEuid < x'FF';
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_SUID
: %Addr( PxSetEuid )
: %Size( PxSetEuid )
);
EndIf;
If PxSetEgid < x'FF';
ChgIfsAtr( PxIfsObj
: QP0L_ATTR_SGID
: %Addr( PxSetEgid )
: %Size( PxSetEgid )
);
EndIf;
*InLr = *On;
Return;
/End-Free
**-- Change IFS attribute: ---------------------------------------------**
P ChgIfsAtr B
D Pi 10i 0
D PxIfsObj 5002a Const Varying
D PxAtrId 10i 0 Const
D PxAtrVal_p * Value
D PxAtrSiz 10i 0 Const
**-- API Path constants:
D CUR_CCSID c 0
D CUR_CTRID c x'0000'
D CUR_LNGID c x'000000'
D CHR_DLM_1 c 0
**-- API path:
D Path Ds Qualified Align
D CcsId 10i 0 Inz( CUR_CCSID )
D CtrId 2a Inz( CUR_CTRID )
D LngId 3a Inz( CUR_LNGID )
D 3a Inz( *Allx'00' )
D PthTypI 10i 0 Inz( CHR_DLM_1 )
D PthNamLen 10i 0
D PthNamDlm 2a Inz( '/ ' )
D 10a Inz( *Allx'00' )
D PthNam 5000a
**- Set attribute buffer:
D Buffer Ds Qualified Align
D OfsNxtAtr 10u 0
D AtrId 10u 0
D SizAtr 10u 0
D 4a Inz( *Allx'00' )
D AtrDta 128a
/Free
Path.PthNam = PxIfsObj;
Path.PthNamLen = %Len( PxIfsObj );
Buffer.OfsNxtAtr = 0;
Buffer.AtrId = PxAtrId;
Buffer.SizAtr = PxAtrSiz;
memcpy( %Addr( Buffer.AtrDta ): PxAtrVal_p: PxAtrSiz );
If SetAtr( %Addr( Path )
: %Addr( Buffer )
: %Size( Buffer )
: PxFlwSymLnk
) < *Zero;
SndDiagMsg( %Char( errno ) + ': ' + strerror );
SndEscMsg( 'CHGIFSATR command ended in error' );
Else;
SndCmpMsg( 'IFS object attribute changed.' );
EndIf;
Return *Zero;
/End-Free
**
P ChgIfsAtr E
**-- Get runtime error number: -----------------------------------------**
P errno B
D Pi 10i 0
**
D Error s 10i 0 Based( pError ) NoOpt
/Free
pError = sys_errno;
Return Error;
/End-Free
P Errno E
**-- Get runtime error text: -------------------------------------------**
P strerror B
D Pi 128a Varying
/Free
Return %Str( sys_strerror( Errno ));
/End-Free
P strerror E
**-- Send diagnostic message: ------------------------------------------**
P SndDiagMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( 'CPF9897'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*DIAG'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndDiagMsg E
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
/Free
SndPgmMsg( 'CPF9898'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*ESCAPE'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndEscMsg E
**-- Send completion message: ------------------------------------------**
P SndCmpMsg B
D Pi 10i 0
D PxMsgDta 512a Const Varying
/Free
SndPgmMsg( 'CPF9897'
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*COMP'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
**
P SndCmpMsg E
Qp0lGetAttr: Because this program example contains some special code, my HTML-editor
is messing up the code. You'll have to download the zipped code here
**
** Program . . : CBX127V
** Description : Change IFS attributes - validity checking program
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : November 18, 2004
**
**
** Program description:
** This program checks the existence of the specified IFS object.
**
**
** Compile options:
** CrtRpgMod Module( CBX127V )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX127V )
** Module( CBX127V )
** ActGrp( *NEW )
**
**
**-- Control specification: --------------------------------------------**
H Option( *SrcStmt ) BndDir( 'QC2LE' )
**-- API error data structure:
D ERRC0100 Ds Qualified
D BytPrv 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0
D ExcpId 7a
D 1a
D ExcpDta 512a
**-- Global variables:
D addr s 10u 0
**-- access API constants:
D F_OK c 0
D X_OK c 1
D W_OK c 2
D R_OK c 4
**-- IFS file functions:
D access Pr 10i 0 ExtProc( 'access' )
D Path * Value Options( *String )
D Amode 10i 0 Value
**-- Error number:
D sys_errno Pr * ExtProc( '__errno' )
**-- Error string:
D sys_strerror Pr * ExtProc( 'strerror' )
D errno 10i 0 Value
**-- 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 1024a Options( *VarSize )
**-- Send diagnostic message:
D SndDiagMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**-- Send escape message:
D SndEscMsg Pr 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**-- Error identification:
D errno Pr 10i 0
D strerror Pr 128a Varying
**-- Entry parameters:
D CBX127V Pr
D PxIfsObj 5002a Varying
D PxFlwSymLnk 10i 0
D PxRdOnly 1a
D PxHidden 1a
D PxPcSys 1a
D PxPcArc 1a
D PxSysArc 1a
D PxAlwCkpWrt 1a
D PxCcsId 10i 0
D PxDskStgOpt 1a
D PxMainStgOpt 1a
D PxSetEuid 1a
D PxSetEgid 1a
**
D CBX127V Pi
D PxIfsObj 5002a Varying
D PxFlwSymLnk 10i 0
D PxRdOnly 1a
D PxHidden 1a
D PxPcSys 1a
D PxPcArc 1a
D PxSysArc 1a
D PxAlwCkpWrt 1a
D PxCcsId 10i 0
D PxDskStgOpt 1a
D PxMainStgOpt 1a
D PxSetEuid 1a
D PxSetEgid 1a
/Free
If access( PxIfsObj: F_OK ) = -1;
SndDiagMsg( 'CPD0006': '0000' + %Char( errno ) + ': ' + strerror );
SndEscMsg( 'CPF0002': '' );
EndIf;
*InLr = *On;
Return;
/End-Free
**-- Get runtime error number: -----------------------------------------**
P errno B
D Pi 10i 0
**
D Error s 10i 0 Based( pError ) NoOpt
/Free
pError = sys_errno;
Return Error;
/End-Free
P errno E
**-- Get runtime error text: -------------------------------------------**
P strerror B
D Pi 128a Varying
/Free
Return %Str( sys_strerror( errno ));
/End-Free
P strerror E
**-- Send diagnostic message: ------------------------------------------**
P SndDiagMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( PxMsgId
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*DIAG'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndDiagMsg E
**-- Send escape message: ----------------------------------------------**
P SndEscMsg B
D Pi 10i 0
D PxMsgId 7a Const
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
/Free
SndPgmMsg( PxMsgId
: 'QCPFMSG *LIBL'
: PxMsgDta
: %Len( PxMsgDta )
: '*ESCAPE'
: '*PGMBDY'
: 1
: MsgKey
: ERRC0100
);
If ERRC0100.BytAvl > *Zero;
Return -1;
Else;
Return 0;
EndIf;
/End-Free
P SndEscMsg E
Command: CBX127X
/*-------------------------------------------------------------------*/
/* */
/* Compile options: */
/* */
/* CrtCmd Cmd( CHGIFSATR ) */
/* Pgm( CBX127 ) */
/* SrcMbr( CBX127X ) */
/* VldCkr( CBX127V ) */
/* HlpPnlGrp( CBX127H ) */
/* HlpId( *CMD ) */
/* PmtOvrPgm( CBX127O ) */
/* */
/* */
/*-------------------------------------------------------------------*/
Cmd Prompt( 'Change IFS Attributes' )
Parm IFSOBJ *Pname 5000 +
Min( 1 ) +
Vary( *YES *INT2 ) +
Case( *MIXED ) +
Keyparm( *YES ) +
Prompt( 'IFS object' )
Parm SYMLNK *Int4 +
Rstd( *YES ) +
Dft( *NO ) +
SpcVal(( *NO 0 ) +
( *YES 1 )) +
Expr( *YES ) +
Keyparm( *YES ) +
Prompt( 'Symbolic link' )
Parm READONLY *Char 1 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *NO x'00' ) +
( *YES x'01' ) +
( *SAME x'FF' )) +
Expr( *YES ) +
Prompt( 'Read only' )
Parm HIDDEN *Char 1 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *NO x'00' ) +
( *YES x'01' ) +
( *SAME x'FF' )) +
Expr( *YES ) +
Prompt( 'Hidden' )
Parm PCSYSTEM *Char 1 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *NO x'00' ) +
( *YES x'01' ) +
( *SAME x'FF' )) +
Expr( *YES ) +
Prompt( 'System file' )
Parm PCARCHIVE *Char 1 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *NO x'00' ) +
( *YES x'01' ) +
( *SAME x'FF' )) +
Expr( *YES ) +
Prompt( 'Object changed - PC' )
Parm SYSARCHIVE *Char 1 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *NO x'00' ) +
( *YES x'01' ) +
( *SAME x'FF' )) +
Expr( *YES ) +
Prompt( 'Object changed - System' )
Parm ALWCKPWRT *Char 1 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *NO x'00' ) +
( *YES x'01' ) +
( *SAME x'FF' )) +
Expr( *YES ) +
Prompt( 'Allow write during save' )
Parm CCSID *Int4 +
Range( 1 65533 ) +
Dft( *SAME ) +
SpcVal(( *SAME 0 )) +
Expr( *YES ) +
Prompt( 'Coded character set ID' )
Parm DISKSTGOPT *Char 1 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *NORMAL x'00' ) +
( *MINIMIZE x'01' ) +
( *DYNAMIC x'02' ) +
( *SAME x'FF' )) +
Expr( *YES ) +
Prompt( 'Disk storage option' )
Parm MAINSTGOPT *Char 1 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *NORMAL x'00' ) +
( *MINIMIZE x'01' ) +
( *DYNAMIC x'02' ) +
( *SAME x'FF' )) +
Expr( *YES ) +
Prompt( 'Main storage option' )
Parm SETEUID *Char 1 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *NO x'00' ) +
( *YES x'01' ) +
( *SAME x'FF' )) +
Expr( *YES ) +
Prompt( 'Set effective user ID' )
Parm SETEGID *Char 1 +
Rstd( *YES ) +
Dft( *SAME ) +
SpcVal(( *NO x'00' ) +
( *YES x'01' ) +
( *SAME x'FF' )) +
Expr( *YES ) +
Prompt( 'Set effective group ID' )
Panel Group
.*-----------------------------------------------------------------------**
.*
.* Compile options:
.*
.* CrtPnlGrp PnlGrp( CBX127H )
.* SrcFile( QPNLSRC )
.* SrcMbr( *PNLGRP )
.*
.*-----------------------------------------------------------------------**
:PNLGRP.
:HELP NAME='CHGIFSATR'.Change IFS Attributes - Help
:P.
The Change IFS Attributes (CHGIFSATR) command changes one or more of
the specified IFS object's attributes. The current attribute value is
displayed when the command is prompted.
:P.
:EHELP.
:HELP NAME='CHGIFSATR/IFSOBJ'.IFS object (IFSOBJ) - Help
:XH3.IFS object (IFSOBJ)
:P.
Specify the path name to the IFS object whose attributes should be
displayed and optionally changed.
:P.
This is a required parameter.
:P.
:EHELP.
:HELP NAME='CHGIFSATR/SYMLNK'.Symbolic link (SYMLNK) - Help
:XH3.Symbolic link (SYMLNK)
:P.
If the last component in the path name is a symbolic link, this
parameter specifies whether or not to change the attribute of the
symbolic link or of the object pointed to by the symbolic link.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*NO:EPK.
:PD.
The attribute of the symbolic link object is not changed. The
attribute of the object pointed to by the symbolic link is changed.
:PT.:PK.*YES:EPK.
:PD.
If the object is a symbolic link, the attribute of the symbolic link
is changed. The attribute of the object pointed to by the symbolic
link is not changed.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/READONLY'.Read only (READONLY) - Help
:XH3.Read only (READONLY)
:P.
Whether the object can be written to or deleted, have its extended
attributes changed or deleted, or have its size changed.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PK.*NO:EPK.
:PD.
The object can be changed or deleted.
:PT.:PK.*YES:EPK.
:PD.
The object cannot be changed or deleted.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/HIDDEN'.Hidden (HIDDEN) - Help
:XH3.Hidden (HIDDEN)
:P.
Whether the object can be displayed using an ordinary directory list.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PK.*NO:EPK.
:PD.
The object is not hidden and can be displayed using an ordinary
directory listing.
:PT.:PK.*YES:EPK.
:PD.
The object is hidden and cannot be displayed using an ordinary
directory listing.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/PCSYSTEM'.System file (PCSYSTEM) - Help
:XH3.System file (PCSYSTEM)
:P.
Whether the object is a PC system file and is excluded from normal
directory searches.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PK.*NO:EPK.
:PD.
The object is not a PC system file.
:PT.:PK.*YES:EPK.
:PD.
The object is a PC system file.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/PCARCHIVE'.Object changed - PC (PCARCHIVE) - Help
:XH3.Object changed - PC (PCARCHIVE)
:P.
Whether the object has changed since the last time the file was saved
or reset by a PC client.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PK.*NO:EPK.
:PD.
The object has not changed.
:PT.:PK.*YES:EPK.
:PD.
The object has changed.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/SYSARCHIVE'.Object changed - System (SYSARCHIVE) - Help
:XH3.Object changed - System (SYSARCHIVE)
:P.
Whether the object has changed and needs to be saved. It is set on
when an object's change time is updated, and set off when the object
has been saved.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PK.*NO:EPK.
:PD.
The object has not changed and does not need to be saved.
:PT.:PK.*YES:EPK.
:PD.
The object has changed and does need to be saved.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/ALWCKPWRT'.Allow write during save (ALWCKPWRT) - Help
:XH3.Allow write during save (ALWCKPWRT)
:P.
Whether the stream file (*STMF) can be shared with readers and writers
during the save-while-active checkpoint processing. Changing this
attribute's current value may cause unexpected results. Please refer
to the Backup and Recovery book, SC41-5304 for details on this
attribute.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PK.*NO:EPK.
:PD.
The object can be shared with readers only.
:PT.:PK.*YES:EPK.
:PD.
The object can be shared with readers and writers.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/CCSID'.Coded character set ID (CCSID) - Help
:XH3.Coded character set ID (CCSID)
:P.
The code character set identifier (CCSID) of the data and extended
attributes of the object.
:P.
:NT.
Changing the CCSID does not convert the data or the extended
attributes.
:ENT.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PV.coded-character-set-identifier:EPV.
:PD.
Specify the CCSID of the data and extended attributes of the object.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/DISKSTGOPT'.Disk storage option (DISKSTGOPT) - Help
:XH3.Disk storage option (DISKSTGOPT)
:P.
This determines how auxiliary storage is allocated by the system for
the specified object. The option will take effect immediately and
be part of the next auxiliary storage allocation for the object.
This option can only be specified for stream files in the root (/),
QOpenSys and user-defined file systems. This option will be ignored
for *TYPE1 byte stream files.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PK.*NORMAL:EPK.
:PD.
The auxiliary storage will be allocated normally. That is, as
additional auxiliary storage is required, it will be allocated in
logically sized extents to accomodate the current space requirement,
and anticipated future requirements, while minimizing the number of
disk I/O operations. If the *DISKSTGOPT attribute has not been
specified for an object, this value is the default.
:PT.:PK.*MINIMIZE:EPK.
:PD.
The auxiliary storage will be allocated to minimize the space used by
the object. That is, as additional auxiliary storage is required, it
will be allocated in small sized extents to accomodate the current
space requirement. Accessing an object composed of many small extents
may increase the number of disk I/O operations for that object.
:PT.:PK.*DYNAMIC:EPK.
:PD.
The system will dynamically determine the optimum auxiliary storage
allocation for the object, balancing space used versus disk I/O
operations. For example, if a file has many small extents, yet is
frequently being read and written, then future auxiliary storage
allocations will be larger extents to minimize the number of disk I/O
operations. Or, if a file is frequently truncated, then future
auxiliary storage allocations will be small extents to minimize the
space used. Additionally, information will be maintained on the stream
file sizes for this system and its activity. This file size
information will also be used to help determine the optimum auxiliary
storage allocations for this object as it relates to the other objects
sizes.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/MAINSTGOPT'.Main storage option (MAINSTGOPT) - Help
:XH3.Main storage option (MAINSTGOPT)
:P.
This determines how main storage is allocated and used by the system
for the specified object. The option will take effect the next time
the specified object is opened. This option can only be specified
for stream files in the root (/), QOpenSys and user-defined file
systems.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PK.*NORMAL:EPK.
:PD.
The main storage will be allocated normally. That is, as much storage
as possible will be allocated and used. This minimizes the number of
disk I/O operations since the information is cached in main storage.
If the *MAINSTGOPT attribute has not been specified for an object, this
value is the default.
:PT.:PK.*MINIMIZE:EPK.
:PD.
The main storage will be allocated to minimize the space used by the
object. That is, as little main storage as possible will be allocated
and used. This minimizes main storage usage while increasing the
number of disk I/O operations since less information is cached in main
storage.
:PT.:PK.*DYNAMIC:EPK.
:PD.
The system will dynamically determine the optimum main storage
allocation for the object depending on other system activity and main
storage contention. That is, when there is little main storage
contention, as much storage as possible will be allocated and used to
minimize the number of disk I/O operations. And when there is
significant main storage contention, less main storage will be
allocated and used to minimize the main storage contention. This
option only has an effect when the storage pool's paging option is
*CALC. When the storage pool's paging option is *FIXED, the behavior
is the same as *NORMAL. When the object is accessed through a file
server, this option has no effect. Instead, its behavior is the same
as *NORMAL.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/SETEUID'.Set effective user ID (SETEUID) - Help
:XH3.Set effective user ID (SETEUID)
:P.
Set effective user ID (UID) at execution time. This value is ignored if
the specified object is a directory.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PK.*NO:EPK.
:PD.
The user ID (UID) is not set at execution time.
:PT.:PK.*YES:EPK.
:PD.
The object owner is the effective user ID (UID) at execution time.
:EPARML.
:EHELP.
:HELP NAME='CHGIFSATR/SETEGID'.Set effective group ID (SETEGID) - Help
:XH3.Set effective group ID (SETEGID)
:P.
Set effective group ID (GID) at execution time.
:P.
The possible values are:
:P.
:PARML.
:PT.:PK DEF.*SAME:EPK.
:PD.
The current attribute value is not changed.
:PT.:PK.*NO:EPK.
:PD.
If the object is a file, the group ID (GID) is not set at execution
time. If the object is a directory in the root ('/'), QOpenSys, and
user-defined file systems, the group ID (GID) of objects created in the
directory is set to the effective GID of the thread creating the
object. This value cannot be set for other file systems.
:PT.:PK.*YES:EPK.
:PD.
If the object is a file, the group ID (GID) is set at execution time.
If the object is a directory, the group ID (GID) of objects created in
the directory is set to the GID of the parent directory.
:EPARML.
:EHELP.
:EPNLGRP.
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
|
|
Back
Retrieve Users Authorized to an Object
**
** Compile options:
**
** CrtRpgMod Module( CBX119T )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX119T )
** Module( CBX119T )
** ActGrp( QILE )
**
**
**-- Specifications -----------------------------------------------------**
H Option( *SrcStmt )
**-- Api error structure: ----------------------------------------------**
D ApiError Ds
D AeBytPro 10i 0 Inz( %Size( ApiError ))
D AeBytAvl 10i 0
D AeExcpId 7a
D 1a
D AaExcpDta 256a
**-- Global variables: -------------------------------------------------**
D Idx s 10i 0
**-- User authorization parameters: ------------------------------------**
D RuRcvVar s 32767a
D RuObjNam s 4096a Varying
**
D RuFdbInf Ds
D FiBytRtnFb 10i 0
D FiBytAvlFb 10i 0
D FiBytRtnRv 10i 0
D FiBytAvlRv 10i 0
D FiNbrAutUsr 10i 0
D FiUsrEntLen 10i 0
D FiObjOwn 10a
D FiObjPgp 10a
D FiAutL 10a
D FiSnsLvl 1a
**
D RuInfEnt Ds Based( pInfEnt )
D ReUsrPrf 10a
D ReUsrTyp 1a
D ReDtaAut 10a
D ReAutlMgm 1a
D ReObjMgm 1a
D ReObjXst 1a
D ReObjAlt 1a
D ReObjRef 1a
D 10a
D ReObjOpr 1a
D ReDtaRead 1a
D ReDtaAdd 1a
D ReDtaUpd 1a
D ReDtaDlt 1a
D ReDtaExe 1a
D 10a
**-- Retrieve users authorized to an object: ---------------------------**
D RtvUsrObjAut Pr ExtPgm( 'QSYRTVUA' )
D RuRcvVar 32767a Options( *VarSize )
D RuRcvVarLen 10i 0 Const
D RuFdbInf 256a Options( *VarSize )
D RuFdbInfLen 10i 0 Const
D RuFmtNam 8a Const
D RuObjPth 4096a Const Options( *VarSize )
D RuObjPthLen 10i 0 Const
D RuError 32767a Options( *VarSize )
**
C Eval RuObjNam = '/qopensys/QUSER/BL2005.prn'
**
C CallP RtvUsrObjAut( RuRcvVar
C : %Size( RuRcvVar )
C : RuFdbInf
C : %Size( RuFdbInf )
C : 'RTUA0100'
C : RuObjNam
C : %Len( RuObjNam )
C : ApiError
C )
**
C If AeBytAvl = *Zero
**
C Eval pInfEnt = %Addr( RuRcvVar )
**
C For Idx = 1 To FiNbrAutUsr
**
**-- Do whatever...
**
C If Idx < FiNbrAutUsr
C Eval pInfEnt = pInfEnt + FiUsrEntLen
C EndIf
**
C EndFor
C EndIf
**
C Return
**
Thanks to Carsten Flensburg
|
|
Back
Validation List Object APIs
**
** Service program summary
** -----------------------
**
** Security APIs:
**
** QsyAddValidationLstEntry Adds an entry to a validation list
** object. The entry is defined by an
** Entry Id (user name), Encrypt Data
** (user password) and Entry Data
** (user description).
**
** QsyFindValidationLstEntry Finds an entry in a validation list
** object. To be able to retrieve the
** password the system value QRETSVRSEC
** must be set to 1 and the QsyEncrypt-
** Data attribute of the entry should
** have been set to 1 when the entry
** was stored.
**
** QsyChangeValidationLstEntry Changes an entry in a validation
** list object. Eligible to change are
** the password and description values
** as well as attribute information.
**
** QsyRemoveValidationLstEntry Removes an entry from a validation
** list object.
**
** QsyVerifyValidationLstEntry Verifies the existence of the speci-
** fied validation list entry and the
** and the validity of the specified
** password.
**
**
** Exported functions:
** Return values:
** VfyUsrPwd Verifies the username and password -1: Failure
** against the specified validation -2: Password error
** list.
**
** AddUsrPwd Adds a username, a password and a -1: Failure
** description to the specified -2: Password error
** validation list.
**
** ChgUsrPwd Changes the password of the speci- -1: Failure
** fied username in the specified -1: Password error
** validation list.
**
** GetUsrPwd Returns the password of the speci- Blanks: Failure
** fied username if found in the
** specified validation list.
**
** RmvUsrPwd Removes the validation list entry -1: Failure
** of the specified username in the
** specified validation list.
**
**
** Compile options:
**
** CRTRPGMOD CBX003
**
** CRTSRVPGM CBX003
**
**
**-- Header specifications: --------------------------------------------**
H NoMain Option( *SrcStmt )
**-- Entry Id: ---------------------------------------------------------**
D EntId Ds
D EiDtaLen 10i 0
D EiCcsId 10i 0 Inz( 65535 )
D EiDta 10a
**-- Encryption data: --------------------------------------------------**
D EncDta Ds
D EcDtaLen 10i 0
D EcCcsId 10i 0 Inz( 65535 )
D EcDta 10a
**-- Entry data: -------------------------------------------------------**
D EntDta Ds
D EdDtaLen 10i 0
D EdCcsID 10i 0 Inz( 65535 )
D EdDta 50a
**-- Attribute data: ---------------------------------------------------**
D AtrInf Ds
D AiNbrAtr 10i 0 Inz( 1 )
D AiAlign 12a
** Qsy_Attr_Descr_T
1 4D AdAtrLoc 10i 0 Inz( 0 )
5 8D AdAtrTyp 10i 0 Inz( 0 )
9 16D AdRes_1 8a Inz( *Allx'00' )
17 32D AdAtrId_p *
33 64D AdOthDsc 32a Inz( *Allx'00' )
** Attr_Data_Info
** Qsy_In_VLDL_T
D VldLstAtr 96a
65 68D AvAtrCcsid 10i 0 Overlay( VldLstAtr: 1 )
65 68D Inz( -1 )
69 72D AvAtrLen 10i 0 Overlay( VldLstAtr: 5 )
69 72D Inz( 1 )
73 80D AvRes_1 8a Overlay( VldLstAtr: 9 )
73 80D Inz( *Allx'00' )
81 96D AvAtrVal_p * Overlay( VldLstAtr: 17 )
81 96D Inz( %Addr( AvAtrVal ))
97192D VaInOther 96a Overlay( VldLstAtr: 1 )
D 64a Overlay( VaInOther: 33 )
D Inz( *Allx'00' )
93224D AdOtherData 32a Inz( *Allx'00' )
**
D AvAtrVal s 1a Inz( '1' )
**-- Return data: ------------------------------------------------------**
D RtnDta Ds
** Qsy_Entry_ID_Info_T
D RiDtaLen 10i 0
D RiCcsId 10i 0
D RiDta 100a
** Qsy_Entry_Encr_Data_Info_T
D RcDtaLen 10i 0
D RcCcsId 10i 0
D RcDta 600a
** Qsy_Entry_Data_Info_T
D RdDtaLen 10i 0
D RdCcsID 10i 0
D RdDta 1000a
D 4a
D RaAtrPtr *
**-- Verify user password: ---------------------------------------------**
D VfyUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 10a Const
D PxUsrPwd 10a Const
**-- Add user password: ------------------------------------------------**
D AddUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 10a Const
D PxUsrPwd 10a Const
D PxUsrDsc 50a Const
**-- Get user password: ------------------------------------------------**
D GetUsrPwd Pr 10a
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 10a Const
**-- Change user password: ---------------------------------------------**
D ChgUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 10a Const
D PxUsrPwd 10a Const
**-- Remove user password: ---------------------------------------------**
D RmvUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 10a Const
**-- Verify user password: ---------------------------------------------**
P VfyUsrPwd B Export
D Pi 10i 0
D PxVldL 10a Const
D PxVldLlib 10a Const
D PxUsrId 10a Const
D PxUsrPwd 10a Const
**-- Verify validation list entry:
D VfyVldLst Pr 10i 0 ExtProc( 'QsyVerifyValidation+
D LstEntry' )
D VvLstNam 20a Const
D VvEntId * Value
D VvEncDta * Value
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval EiDta = PxUsrId
C Eval EiDtaLen = %Len( %TrimR( EiDta ))
**
C Eval EcDta = PxUsrPwd
C Eval EcDtaLen = %Len( %TrimR( EcDta ))
**
C Return VfyVldLst( PxVldL + PxVldLlib
C : %Addr( EntId )
C : %Addr( EncDta )
C )
**
P VfyUsrPwd E
**-- Add user password: ------------------------------------------------**
P AddUsrPwd B Export
D Pi 10i 0
D PxVldL 10a Const
D PxVldLlib 10a Const
D PxUsrId 10a Const
D PxUsrPwd 10a Const
D PxUsrDsc 50a Const
**-- Add validation list entry:
D AddVldLst Pr 10i 0 ExtProc( 'QsyAddValidation+
D LstEntry' )
D AvLstNam 20a Const
D AvEntId * Value
D AvEncDta * Value
D AvEntDta * Value
D AvAtrDta * Value
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval EiDta = PxUsrId
C Eval EiDtaLen = %Len( %TrimR( EiDta ))
**
C Eval EcDta = PxUsrPwd
C Eval EcDtaLen = %Len( %TrimR( EcDta ))
**
C Eval EdDta = PxUsrDsc
C Eval EdDtaLen = %Len( %TrimR( EdDta ))
**
C Alloc 15 AdAtrId_p
C Eval %Str( AdAtrId_p: 15 ) = 'QsyEncryptData'
**
C Return AddVldLst( PxVldL + PxVldLlib
C : %Addr( EntId )
C : %Addr( EncDta )
C : %Addr( EntDta )
C : %Addr( AtrInf )
C )
**
P AddUsrPwd E
**-- Get user password: ------------------------------------------------**
P GetUsrPwd B Export
D Pi 10a
D PxVldL 10a Const
D PxVldLlib 10a Const
D PxUsrId 10a Const
**-- Find validation list entry:
D FndVldLst Pr 10i 0 ExtProc( 'QsyFindValidation+
D LstEntry' )
D FvLstNam 20a Const
D FvEntId * Value
D FvRtnDta * Value
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval EiDta = PxUsrId
C Eval EiDtaLen = %Len( %TrimR( EiDta ))
**
C If FndVldLst( PxVldL + PxVldLlib
C : %Addr( EntId )
C : %Addr( RtnDta )
C ) = -1
C Return *Blanks
**
C Else
C Return %SubSt( RcDta: 1: RcDtaLen )
C EndIf
**
P GetUsrPwd E
**-- Change user password: ---------------------------------------------**
P ChgUsrPwd B Export
D Pi 10i 0
D PxVldL 10a Const
D PxVldLlib 10a Const
D PxUsrId 10a Const
D PxUsrPwd 10a Const
**-- Change validation list entry:
D ChgVldLst Pr 10i 0 ExtProc( 'QsyChangeValidation+
D LstEntry' )
D CvLstNam 20a Const
D CvEntId * Value
D CvEncDta * Value
D CvEntDta * Value
D CvAtrDta * Value
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval EiDta = PxUsrId
C Eval EiDtaLen = %Len( %TrimR( EiDta ))
**
C Eval EcDta = PxUsrPwd
C Eval EcDtaLen = %Len( %TrimR( EcDta ))
**
C Return ChgVldLst( PxVldL + PxVldLlib
C : %Addr( EntId )
C : %Addr( EncDta )
C : *Null
C : *Null
C )
**
P ChgUsrPwd E
**-- Remove user password: ---------------------------------------------**
P RmvUsrPwd B Export
D Pi 10i 0
D PxVldL 10a Const
D PxVldLlib 10a Const
D PxUsrId 10a Const
**-- Remove validation list entry:
D RmvVldLst Pr 10i 0 ExtProc( 'QsyRemoveValidation+
D LstEntry' )
D RvLstNam 20a Const
D RvEntId * Value
**
**-- Mainline: ---------------------------------------------------------**
**
C Eval EiDta = PxUsrId
C Eval EiDtaLen = %Len( %TrimR( EiDta ))
**
C Return RmvVldLst( PxVldL + PxVldLlib
C : %Addr( EntId )
C )
**
P RmvUsrPwd E
Test validation list functions in service program CBX003
**
** Program description:
**
** Test validation list functions in service program CBX003.
**
**
** Program prerequisite:
**
** Create validation list in QGPL: CRTVLDL WEB001V
**
**
** Compile options:
**
** CRTRPGMOD ... DBGVIEW(*LIST)
**
** CRTPGM ... BNDSRVPGM(CBX003)
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- Global variables & constants: -------------------------------------**
D RtnCod s 10i 0
D UsrPwd s 10a
D VldLst c 'WEB001V'
D VldLib c '*LIBL'
**-- Verify user password: ---------------------------------------------**
D VfyUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 10a Const
D PxUsrPwd 10a Const
**-- Add user password: ------------------------------------------------**
D AddUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 10a Const
D PxUsrPwd 10a Const
D PxUsrDsc 50a Const
**-- Get user password: ------------------------------------------------**
D GetUsrPwd Pr 10a
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 10a Const
**-- Change user password: ---------------------------------------------**
D ChgUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 10a Const
D PxUsrPwd 10a Const
**-- Remove user password: ---------------------------------------------**
D RmvUsrPwd Pr 10i 0
D PxVldLst 10a Const
D PxVldLstLib 10a Const
D PxUsrId 10a Const
**-- Test user password functions: --------------------------------------**
**
C If AddUsrPwd( VldLst
C : VldLib
C : 'Dexter'
C : 'DeeDee'
C : 'Big scientist'
C ) = *Zero
**
C Eval RtnCod = VfyUsrPwd( VldLst
C : VldLib
C : 'Dexter'
C : 'DeeDee'
C )
**
C Eval RtnCod = VfyUsrPwd( VldLst
C : VldLib
C : 'Dexter'
C : 'deedee'
C )
**
C Eval UsrPwd = GetUsrPwd( VldLst
C : VldLib
C : 'Dexter'
C )
**
C Eval RtnCod = ChgUsrPwd( VldLst
C : VldLib
C : 'Dexter'
C : 'DEEDEE'
C )
**
C Eval UsrPwd = GetUsrPwd( VldLst
C : VldLib
C : 'Dexter'
C )
**
C EndIf
**
C Eval RtnCod = RmvUsrPwd( VldLst
C : VldLib
C : 'Dexter'
C )
**
C Eval *InLr = *On
**
Thanks to Carsten Flensburg
|
|
Back
Send Message (CLLE)
/*-------------------------------------------------------------------*/
/* Program: BRKMSG */
/* Description: Receive two parameters from any program and send */
/* a message to any User using the QEZSNDMG API from */
/* the Operational Assistant menu. */
/* */
/* &MSGTEXT - 80 character message */
/* &USERID - 10 character UserId to receive msg */
/* */
/* Notes: -The message text passed to this program */
/* should be limited to 80 chars. */
/* -If the user has multiple sessions open, */
/* each session will receive a message. */
/* -Use *ALLACT as USERID to notify everyone */
/*-------------------------------------------------------------------*/
PGM PARM(&MSGTEXT &USERID)
DCL VAR(&MSGTYPE) TYPE(*CHAR) LEN(10) +
VALUE('*INFO')
DCL VAR(&DELMODE) TYPE(*CHAR) LEN(10) +
VALUE('*BREAK')
DCL VAR(&MSGTEXT) TYPE(*CHAR) LEN(80)
DCL VAR(&MSGLENG) TYPE(*CHAR) LEN(04) +
VALUE(X'00000050')
DCL VAR(&USERID) TYPE(*CHAR) LEN(10)
DCL VAR(&USRCNT) TYPE(*CHAR) LEN(04) +
VALUE(X'00000001')
DCL VAR(&MSGSENT) TYPE(*CHAR) LEN(04) +
VALUE(X'00000000')
DCL VAR(&FUNCREQ) TYPE(*CHAR) LEN(04) +
VALUE(X'00000000')
DCL VAR(&ERROR) TYPE(*CHAR) LEN(256) +
VALUE(X'00000100')
DCL VAR(&SHOWMSG) TYPE(*CHAR) LEN(01) VALUE('N')
DCL VAR(&REPLYMQ) TYPE(*CHAR) LEN(20)
DCL VAR(&NAMETYPE) TYPE(*CHAR) LEN(04) +
VALUE('*USR')
CALL PGM(QEZSNDMG) PARM(&MSGTYPE &DELMODE +
&MSGTEXT &MSGLENG &USERID &USRCNT +
&MSGSENT &FUNCREQ &ERROR &SHOWMSG +
&REPLYMQ &NAMETYPE)
ENDJOB: ENDPGM
Thanks to Terry Winchester
And in RPG:
**
** Program . . : CBX505
** Description : QEZSNDMG send message API - Test
** Author . . : Carsten Flensburg
**
**
** Compile options:
** CrtRpgMod Module( CBX505 )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX505 )
** Module( CBX505 )
** ActGrp( QILE )
**
**
**-- Header specifications: --------------------------------------------**
H Option( *SrcStmt )
**-- System information:
D PgmSts Sds Qualified
D CurJob 10a Overlay( PgmSts: 244 )
D UsrPrf 10a Overlay( PgmSts: 254 )
D JobNbr 6a Overlay( PgmSts: 264 )
D CurUsr 10a Overlay( PgmSts: 358 )
**-- Global variables & constants:
D MsgTxt s 256a Varying
D Inz( 'This is a test message' )
D FncRqs s 10i 0
D MsgSntInd s 10i 0
**-- Api error data structure:
D ERRC0100 Ds Qualified
D BytPro 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0 Inz
D MsgId 7a
D 1a
D MsgDta 128a
**-- Send message:
D SndMsg Pr ExtPgm( 'QEZSNDMG' )
D MsgTyp 10a Const
D DlvMod 10a Const
D MsgTxt 494a Const Options( *VarSize )
D MsgTxtLen 10i 0 Const
D MsgRcv 10a Const Options( *VarSize ) Dim( 299 )
D MsgRcvNbr 10i 0 Const
D MsgSntInd 10i 0
D FncRqs 10i 0
D Error 32767a Options( *VarSize )
D ShwSndMsgDsp 1a Const Options( *NoPass )
D MsgQueNam 20a Const Options( *NoPass )
D NamTypInd 4a Const Options( *NoPass )
D CcsId 10i 0 Const Options( *NoPass )
/Free
SndMsg( '*INFO'
: '*BREAK'
: MsgTxt
: %Len( MsgTxt )
: PgmSts.UsrPrf
: 1
: MsgSntInd
: FncRqs
: ERRC0100
: 'N'
: *Blanks
: '*USR'
);
*InLr = *On;
Return;
/End-Free
Thanks to (as usual) Carsten Flensburg
|
|
Back
Change Library List
****************************************************************
* Description.. Library List Functions *
* Program Name. F.LIBL *
* Author....... Bradley V. Stone *
* BVS/Tools - www.bvstools.com *
****************************************************************
H NOMAIN
****************************************************************
* Prototypes *
****************************************************************
D #PushLib PR
D PR_Lib 10 VALUE
D #PopLib PR
D PR_text 10 VALUE OPTIONS(*NOPASS)
D #AddLibLE PR
D PR_Lib 10 VALUE
D PR_Pos 8 VALUE OPTIONS(*NOPASS)
D PR_RefLib 10 VALUE OPTIONS(*NOPASS)
D #ChgLibLJD PR
D PR_JobD 10 VALUE
D PR_JobDLib 10 VALUE
D #RtvLibL PR *
D PR_LibType 10 VALUE
D #VerLib PR 2 0
D PR_Lib 10 VALUE
D PR_LibType 10 VALUE
****************************************************************
* Global Definitions *
****************************************************************
D WPError DS
D EBytesP 1 4B 0 INZ(%size(EData))
D EBytesA 5 8B 0
D EMsgID 9 15
D EReserverd 16 16
D EData 17 56
*
D QCmdCmd S 512 INZ
D QCmdLength S 15 5 INZ(%size(QCmdCmd))
*//////////////////////////////////////////////////////////////*
* (#PushLib) Push a library onto the top of the libary list. *
* *
* Use: #PushLib(library) *
*//////////////////////////////////////////////////////////////*
P #PushLib B EXPORT
*--------------------------------------------------------------*
D #PushLib PI
D Lib 10 VALUE
*--------------------------------------------------------------*
C eval QCmdCmd = 'ADDLIBLE LIB(' +
C %trim(Lib) +
C ') ' +
C 'POSITION(*FIRST)'
*
C CALL 'QCMDEXC' 99
C PARM QCmdCmd
C PARM QCmdLength
*
*--------------------------------------------------------------*
C *PSSR BEGSR
C ENDSR
*--------------------------------------------------------------*
P #PushLib E
*//////////////////////////////////////////////////////////////*
* (#PopLib) Pop a library from the library list. If no value *
* is passed to this procedure, the first library is popped *
* from the library list. *
* *
* Use: #PopLib({library}) *
*//////////////////////////////////////////////////////////////*
P #PopLib B EXPORT
*--------------------------------------------------------------*
D #PopLib PI
D Lib 10 VALUE OPTIONS(*NOPASS)
*
D LibPtr S *
*
D MaxLibs C CONST(25)
*
D LibData DS BASED(LibPtr)
D #Libs 9B 0
D LibArr 10 DIM(MaxLibs)
*--------------------------------------------------------------*
*
C if (%Parms < 1) or (Lib = '*FIRST')
C eval LibPtr = #RtvLibL('*USER')
*
C if (LibPtr <> *NULL) and (#Libs > 0)
C eval Lib = (LibArr(1))
C endif
*
C endif
*
C eval QCmdCmd = 'RMVLIBLE LIB(' +
C %trim(Lib) +
C ') '
*
C CALL 'QCMDEXC' 99
C PARM QCmdCmd
C PARM QCmdLength
*
*--------------------------------------------------------------*
C *PSSR BEGSR
C ENDSR
*--------------------------------------------------------------*
P #PopLib E
*//////////////////////////////////////////////////////////////*
* (#AddLibLE) Add Library List Entry to the specified postion *
* on the library list using the same format as the ADDLIBLE *
* command. If position and/or reference library are not *
* passed, the library is pushed onto the library list. *
* *
* Use: #AddLibLE(library : *
* {*FIRST | *LAST | *
* *AFTER | *BEFORE | *REPLACE} : *
* {Reference Library}) *
*//////////////////////////////////////////////////////////////*
P #AddLibLE B EXPORT
*--------------------------------------------------------------*
D #AddLibLE PI
D Lib 10 VALUE
D Pos 8 VALUE OPTIONS(*NOPASS)
D RefLib 10 VALUE OPTIONS(*NOPASS)
*--------------------------------------------------------------*
C if (%Parms < 3) or (Pos = '*FIRST')
C CALLP #PushLib(Lib)
C else
C eval QCmdCmd = 'ADDLIBLE LIB(' +
C %trim(Lib) +
C ') ' +
C 'POSITION(' +
C %trim(Pos) + ' ' +
C %trim(RefLib) +
C ') '
*
C CALL 'QCMDEXC' 99
C PARM QCmdCmd
C PARM QCmdLength
*
C endif
*--------------------------------------------------------------*
C *PSSR BEGSR
C ENDSR
*--------------------------------------------------------------*
P #AddLibLE E
*//////////////////////////////////////////////////////////////*
* (#ChgLibLJD) Change Library List to the initial library list *
* given on the inputted job description. *
* *
* Use: #ChgLibLJD(job description : job description library) *
*//////////////////////////////////////////////////////////////*
P #ChgLibLJD B EXPORT
*--------------------------------------------------------------*
D #ChgLibLJD PI
D JobD 10 VALUE
D JobDLib 10 VALUE
*
D JobDRtn DS
D Filler1 1 360
D LLOffSet 361 364B 0
D #Libs 365 368B 0
D Filler2 369 600
*
D MaxLibs C CONST(25)
*
D LibL S 11 DIM(MaxLibs)
*
D JobDLen S 9B 0 INZ(%size(JobDRtn))
D JobDFmt S 8 INZ('JOBD0100')
D JobDLoc S 20
*
D LLCurLib S 11 INZ('*SAME')
D LLPrdLib S 11 INZ('*SAME')
D LL2PrdLib S 11 INZ('*SAME')
*
D x S 9B 0
D y S 9B 0
*--------------------------------------------------------------*
C eval JobDLoc = (JobD + JobDLib)
*
C CALL 'QWDRJOBD'
C PARM JobDRtn
C PARM JobDLen
C PARM JobDFmt
C PARM JobDLoc
C PARM WPError
*
C eval y = (LLOffSet + 1)
*
C 1 do #Libs x
C eval LibL(x) = %subst(JobDRtn:y:10)
C eval y = (y + 11)
C enddo
*
C CALL 'QLICHGLL'
C PARM LLCurLib
C PARM LLPrdLib
C PARM LL2PrdLib
C PARM LibL
C PARM #Libs
C PARM WPError
*
*--------------------------------------------------------------*
C *PSSR BEGSR
C ENDSR
*--------------------------------------------------------------*
P #ChgLibLJD E
*//////////////////////////////////////////////////////////////*
* (#RtvLibL) Retrieve Library List and return the data as a *
* pointer to a data structure that contains the library *
* information. If the pointer returned contains the value *
* *NULL, an error occured. *
* *
* Use: #RtvLibL(*SYSTEM | *PRODCUT | *CURRENT | *USER) *
*//////////////////////////////////////////////////////////////*
P #RtvLibL B EXPORT
*--------------------------------------------------------------*
D #RtvLibL PI *
D LibType 10 VALUE
*
D RtvRtnVar DS
D RtvSysLibs 65 68B 0
D RtvPrdLibs 69 72B 0
D RtvCurLibs 73 76B 0
D RtvUsrLibs 77 80B 0
D RtvData 81 400
*
D MaxLibs C CONST(25)
*
D SysData DS STATIC
D #SysLibs 9B 0
D SysArr 10 DIM(MaxLibs)
*
D PrdData DS STATIC
D #PrdLibs 9B 0
D PrdArr 10 DIM(MaxLibs)
*
D CurData DS STATIC
D #CurLibs 9B 0
D CurArr 10 DIM(MaxLibs)
*
D UsrData DS STATIC
D #UsrLibs 9B 0
D UsrArr 10 DIM(MaxLibs)
*
D RtvLen S 9B 0 INZ(400)
D RtvFmt S 8 INZ('JOBI0700')
D RtvJobName S 26 INZ('*')
D RtvID S 16
*
D x S 9B 0
D y S 9B 0
*--------------------------------------------------------------*
C CALL 'QUSRJOBI'
C PARM RtvRtnVar
C PARM RtvLen
C PARM RtvFmt
C PARM RtvJobName
C PARM RtvID
*
C eval y = 1
C eval #SysLibs = RtvSysLibs
C eval #PrdLibs = RtvPrdLibs
C eval #CurLibs = RtvCurLibs
C eval #UsrLibs = RtvUsrLibs
*
C select
C when (LibType = '*SYSTEM')
*
C 1 do #SysLibs x
C eval SysArr(x) = %subst(RtvData:y:10)
C eval y = (y + 11)
C enddo
*
C RETURN %addr(SysData)
*
C when (LibType = '*PRODUCT')
C eval y = (y + (#SysLibs * 11))
*
C 1 do #PrdLibs x
C eval PrdArr(x) = %subst(RtvData:y:10)
C eval y = (y + 11)
C enddo
*
C RETURN %addr(PrdData)
*
C when (LibType = '*CURRENT')
C eval y = (y +
C ((#SysLibs + #PrdLibs) * 11))
*
C 1 do #CurLibs x
C eval CurArr(x) = %subst(RtvData:y:10)
C eval y = (y + 11)
C enddo
*
C RETURN %addr(CurData)
*
C when (LibType = '*USER')
C eval y = (y +
C ((#SysLibs + #PrdLibs + #CurLibs) * 11))
*
C 1 do #UsrLibs x
C eval UsrArr(X) = %subst(RtvData:y:10)
C eval y = (y + 11)
C enddo
*
C RETURN %addr(UsrData)
C other
C RETURN *NULL
C endsl
*--------------------------------------------------------------*
C *PSSR BEGSR
C RETURN *NULL
C ENDSR
*--------------------------------------------------------------*
P #RtvLibL E
*//////////////////////////////////////////////////////////////*
* (#VerLib) Verify that a library is in the library list and *
* return the postion that the library is in. If the value *
* returned is 0, the library is not in the library list. If *
* the value -1 is returned, an error occured. *
* *
* Use: #VerLib(library : *
* *SYSTEM | *PRODCUT | *CURRENT | *USER) *
*//////////////////////////////////////////////////////////////*
P #VerLib B EXPORT
*--------------------------------------------------------------*
D #VerLib PI 2 0
D Lib 10 VALUE
D LibType 10 VALUE
*
D LibPtr S *
*
D MaxLibs C CONST(25)
*
D LibData DS BASED(LibPtr)
D #Libs 9B 0
D LibArr 10 DIM(MaxLibs)
*
D i S 2 0
*--------------------------------------------------------------*
C eval LibPtr = #RtvLibL(LibType)
*
C if (LibPtr = *NULL)
c RETURN -1
C endif
*
C eval i = 1
C Lib LOOKUP LibArr(i) 99
*
C if (*IN99)
C RETURN i
C else
C RETURN 0
C endif
*--------------------------------------------------------------*
C *PSSR BEGSR
C RETURN -1
C ENDSR
*--------------------------------------------------------------*
P #VerLib E
Thanks to Bradley V. Stone
|
|
Back
Page #6
Page #8
