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