***************************************************************** * Program Description **** ***************************************************************** *Program Name : VFNDOBJ *Author : Victor Voilevitch *Date : 25.05.1999 *Programming Language: RPG *Description: This program finds an object by its description text *Header Files Included: QUSGEN - Generic Header of a User Space * QUSEC - Error Code Parameter * (Copied into Program) * QUSLOBJ - List Objects API * *APIs Used: QUSCRTUS - Create User Space * QUSLOBJ - List Objects * QUSRTVUS - Retrieve User Space * QUSDLTUS - Delete User Space * QMHSNDPM - Send Program Message * QMHRMVPM - Remove Program Message * QUSRJOBI - Retrieve Job Information API * QWTCHGJB - Change Job API F***************************************************************** F* Files **** F***************************************************************** F* Display file FVFNDOBJDCF E WORKSTN * E***************************************************************** E* Message Arrays **** E***************************************************************** E* E #ER 80 80 1 E #E2 1 2 80 E #WH 1 25 23 E* Message Id Array E #ID 7 1 E* RUNSQL command E #RS 1 1 50 E* Select parameter E #SS 50 1 E* File/Library Name E #NN 10 1 E #N2 10 1 * I***************************************************************** I* Data Structures **** I***************************************************************** I* I* I. Generic Header of a User Space Include I* I/COPY QSYSINC/QRPGSRC,QUSGEN I* I***************************************************************** I* II. Error Code Parameter Include for the APIs I* I* The following QUSEC include is copied into this program I* so that the variable length field can be defined as a I* fixed length. I* I*Header File Name: H/QUSEC I* IQUSBN DS I* Qus EC I B 1 40QUSBNB I* Bytes Provided I B 5 80QUSBNC I* Bytes Available I 9 15 QUSBND I* Exception Id I 16 16 QUSBNF I* Reserved I* 17 17 QUSBNG I* I* Varying length I 17 100 QUSBNG I* I***************************************************************** I* I* III. List Objects API Include I* I/COPY QSYSINC/QRPGSRC,QUSLOBJ I* I***************************************************************** I* Qualified User Space Data Structure I* IUSERSP DS I I 'VFNDOBJUS ' 1 10 USRSPC I I 'QTEMP ' 11 20 SPCLIB I***************************************************************** I* Qualified Object Name Data Structure I* IOBJECT DS I I '*ALL ' 1 10 OBJNAM I I '*LIBL ' 11 20 OBJLIB I* I***************************************************************** I* Miscellaneous Data Structure I* I DS I* Set up parameters for the Create User Space API I I 'VFNDOBJUS ' 1 10 EXTATR I I X'00' 11 11 INTVAL I 12 12 RSVD1 I I 256 B 13 160INTSIZ I I '*ALL ' 17 26 PUBAUT I I 'User space for - 27 76 TEXT I 'objects list - I 'STORE ' I I '*YES ' 77 87 REPLAC I* Set up parameters for the List Objects API I I 'OBJL0200' 88 95 FORMAT I I '*ALL ' 96 105 OBJTYP I 106 108 RSVD2 I* Set up parameters for the Retrieve User Space API I I 1 B 109 1120STRPOS I I 192 B 113 1160LENDTA I B 117 1200COUNT I* I***************************************************************** I* Parameters DS for send pgm msg API I* I DS I I 'CPF9898' 1 7 #MSGID I 8 27 #MSGF I I 'QCPFMSG' 8 17 #MSGFI I I '*LIBL' 18 27 #MSGFL I 28 155 #MSGDT I I 80 B 156 1590#MSGDL I I '*INFO' 160 169 #MSGTP I I 'VFNDOBJ' 170 179 #QUEUE I I 0 B 180 1830#SNDTO I 184 187 #MSGKY I I 0 B 188 1910#ERRCD I* I***************************************************************** I* Parameters DS for send pgm msg API (SQL messages) I* I DS I 1 7 #QSGID I 8 27 #QSGF I I 'QCPFMSG' 8 17 #QSGFI I I '*LIBL' 18 27 #QSGFL I 28 155 #QSGDT I B 156 1590#QSGDL I I '*INFO' 160 169 #QSGTP I I 'VFNDOBJ' 170 179 #QSQUE I I 0 B 180 1830#QSSTO I 184 187 #QSMKY I I 0 B 188 1910#QSRCD I* I***************************************************************** I* Parameters DS for retrieve Job Information I* a) Information Returned I@JOBI DS I* Run Priority I B 65 680#JIRUN I* b) Length of a) I DS I I 68 B 1 40#JILEN I* I***************************************************************** I* Parameters DS for changing Job I* Information Transferred I@JOBC DS I* Number Of Keys I I 1 B 1 40#JCKEN I* Length Of Whole Key I I 20 B 5 80#JCKEL I* Key I I 1802 B 9 120#JCKEY I* Type Of Data I I 'B' 13 13 #JCDAP I* Reserved I 14 16 #JCD1 I* Length Of Data I I 4 B 17 200#JCDAL I* Data I B 21 240#JCRUN I* I***************************************************************** I* Program status information DS I* I@SPSDS SDS I *PROGRAM MSGPQ I* I***************************************************************** I* Binary 4-digits zeroes field I X'00000000' C C#0000 I***************************************************************** I* Binary 4,0 to Zoned 4,0 conversion DS I DS I B 1 40#XER1 I 1 40#XID I***************************************************************** I* Parameters DS for copy into file command I* I@COPYS DS I I 'CPYF FROMFILE(' 1 20 #CPY1 I I 'QTEMP/FINDTBL2) ' 21 40 #CPY2 I I 'TOFILE( ' 41 60 #CPY3 I 61 70 #LNAME I I '/' 71 71 #CPY4 I 72 81 #FNAME I I ') MBROPT(*ADD) ' 82 101 #CPY5 I I 'CRTFILE(*YES) ' 102 121 #CPY6 I* * C***************************************************************** C* Mainline **** C***************************************************************** C* C* Change Run Priority. C* C* a) Retrieve Current Run Priority. C CALL 'QUSRJOBI'@PJOBI C* See if any errors were returned in the error code parameter. C QUSBNC IFGT 0 C MOVEL*OFF #RUNF C ENDIF C Z-ADD24 #N Error # C EXSR ERRCOD C* C* b) Change Run Priority. C #RUNF IFEQ *ON C Z-ADD1 #JCRUN C CALL 'QWTCHGJB'@PJOBC C* See if any errors were returned in the error code parameter. C QUSBNC IFGT 0 C MOVEL*OFF #RUNF C ENDIF C Z-ADD25 #N Error # C EXSR ERRCOD C ENDIF C* C* Create a user space. C Z-ADD100 QUSBNB len of QUSBN C CALL 'QUSCRTUS' C PARM USERSP C PARM EXTATR C PARM INTSIZ C PARM INTVAL C PARM PUBAUT C PARM TEXT C PARM REPLAC C PARM QUSBN C* See if any errors were returned in the error code parameter. C Z-ADD1 #N Error # C EXSR ERRCOD C* C* Default input C MOVELOBJLIB $LIBL P C MOVELOBJTYP $TYPE P C MOVEL'Y' $CASE P C* C* Create a tables. C/EXEC SQL C+ Create Table QTEMP/FINDTBL1 C+ ( Library Char(10), C+ Object Char(10), C+ Type Char( 7), C+ Desc Char(50) C+ ) C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD6 #N C EXSR ERRSQL C* C/EXEC SQL C+ Create Table QTEMP/FINDTBL2 C+ ( Library Char(10), C+ Object Char(10), C+ Type Char( 7), C+ Desc Char(50) C+ ) C/END-EXEC C* C* See if any errors were returned in the error code parameter. C Z-ADD7 #N C EXSR ERRSQL C* C/EXEC SQL C+ Label On Table QTEMP/FINDTBL2 Is C+ 'VFNDOBJ - output file' C/END-EXEC C* C* See if any errors were returned in the error code parameter. C Z-ADD17 #N C EXSR ERRSQL C* C/EXEC SQL C+ Create Table QTEMP/FINDTBL3 C+ ( Desc Char(50) C+ ) C/END-EXEC C* C* See if any errors were returned in the error code parameter. C Z-ADD18 #N C EXSR ERRSQL C* C*==================================================== C*== Start of main cycle ==== C*== get input and process it ==== C*==================================================== C *INKC DOWEQ*OFF C* C* Get user input values C WRITEMSGCTL C EXFMTMAIN C* C* HELP pressed C *IN01 IFEQ *ON C EXFMTWHELP C ITER C ENDIF C* F3 pressed C *INKC IFEQ *ON C ITER C ENDIF C* C* F8 pressed C *INKH IFEQ *ON F8 pressed C *IN20 IFEQ *ON Found any C CALL 'QCMDEXC' 21 C PARM #RS C PARM 50 #RSL 155 C *IN21 IFEQ *ON QCMDEXC error C* Process errors returned from the API. C MOVEL#WH,10 #STR C MOVEA#STR #ER,18 C MOVEA#ER #MSGDT C EXSR MSGSND C ENDIF QCMDEXC error C ENDIF Found any C ITER C ENDIF F8 pressed C* C* F9 pressed C *INKI IFEQ *ON F9 pressed C *IN20 IFEQ *ON Found any C *IN26 DOWEQ*ON While not Enter C *INKL ANDEQ*OFF And not F12 C EXFMTWCOPY C ENDDO C *IN26 IFNE *ON Enter Pressed C* Prepare names and copy into C CLEAR#FNAME C CLEAR#LNAME C CLEAR#N2 C* File name... C MOVEA$FNAME #NN P C ' ' CHECK$FNAME #C 23 C 23 MOVEA#NN,#C #FNAME file...... C* Library name... C MOVEA$LNAME #NN P C ' ' CHECK$LNAME #C 23 Left char C ' ' CHEKR$LNAME #G 20 23 Right char C Z-ADD10 #J 20 Last pos to C Z-ADD#G #K 20 Last pos from C 23 #C DO #G #P C MOVE #NN,#K #N2,#J C SUB 1 #J C SUB 1 #K C ENDDO C MOVEA#N2 #LNAME .......lib C* Copying... C CALL 'QCMDEXC' 21 C PARM @COPYS C PARM 121 #RSL C *IN21 IFEQ *ON QCMDEXC error C* Process errors returned from the API. C MOVEL#WH,16 #STR C MOVEA#STR #ER,18 C MOVEA#ER #MSGDT C EXSR MSGSND C ENDIF QCMDEXC error C ENDIF Enter Pressed C ENDIF Found any C ITER C ENDIF F9 pressed C* C* Not Enter pressed C *IN26 IFEQ *ON C ITER C ENDIF C* C* Hide F8, F9 Buttons C MOVE *OFF *IN20 C Z-ADD0 NNALL C Z-ADD0 NNSEL C* C* Clearing tables. C/EXEC SQL C+ Delete From QTEMP/FINDTBL1 C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD13 #N C EXSR ERRSQL C* C/EXEC SQL C+ Delete From QTEMP/FINDTBL2 C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD14 #N C EXSR ERRSQL C* C/EXEC SQL C+ Delete From QTEMP/FINDTBL3 C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD22 #N C EXSR ERRSQL C* C* Clear messages C CALL 'QMHRMVPM' C PARM 'VFNDOBJ' #CLRQ 10 C PARM C#0000 #CLRCN 4 C PARM ' ' #CLRKY 4 C PARM '*ALL' #CLRRM 10 C PARM C#0000 #CLRER 4 C* C* Handle input request C MOVEL$LIBL OBJLIB P C MOVEL$TYPE OBJTYP P C* C* Get a list of all objects in the library. C CALL 'QUSLOBJ' C PARM USERSP C PARM FORMAT C PARM OBJECT C PARM OBJTYP C PARM QUSBN C* See if any errors were returned in the error code parameter. C Z-ADD2 #N C EXSR ERRCOD C* C* Look at the generic header. This contains information C* about the list data section that is needed when processing C* the entries. C Z-ADD1 STRPOS start of QUSBP C Z-ADD192 LENDTA len of QUSBP C CALL 'QUSRTVUS' C PARM USERSP C PARM STRPOS C PARM LENDTA C PARM QUSBP C PARM QUSBN C* See if any errors were returned in the error code parameter. C Z-ADD3 #N C EXSR ERRCOD C* C* C* Check the information status field, QUSBPJ, to see if the C* API was able to return all the information. Possible values C* are: C -- Complete and accurate C* P -- Partial but accurate C* I -- Incomplete. C QUSBPJ IFEQ 'C' C QUSBPJ OREQ 'P' C* C* Issue message how many objects found with any description. C MOVE *ON *IN22 C Z-ADDQUSBPS NNALL C* C* -------------------------------- C* -- handle list of objects -- C* -------------------------------- C* Check to see if any entries were put into the user space. C QUSBPS IFGT 0 C Z-ADD1 COUNT C* Because RPG is Base 1, the offset must be increased by one. C QUSBPQ ADD 1 STRPOS C Z-ADD91 LENDTA C* C* Build selecting criteria. C* C* Convert to Uppercase if needed C $CASE IFNE 'Y' no match case C* Add one row into the table 3 for conversion to uppercase C/EXEC SQL C+ Insert Into QTEMP/FINDTBL3 C+ Values (:$DESC) C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD20 #N C EXSR ERRSQL C* C* Read one row from table 3 (converted to uppercase by standard C* SQL tools independent of language) C/EXEC SQL C+ Select Upper(Desc) C+ Into :$DESC C+ From QTEMP/FINDTBL3 C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD21 #N C EXSR ERRSQL C* C ENDIF no match case C* C CLEAR#SS C MOVEA$DESC #SS,1 C* Fill left blanks with '%' C ' ' CHECK$DESC #C 20 23 C N23 Z-ADD50 #C all blanks C 23 SUB 1 #C last blank C 1 DO #C #P 20 C MOVE '%' #SS,#P C ENDDO C* Fill right blanks with '%' C ' ' CHEKR$DESC #C 20 23 C 23 ADD 1 #C C 23 #C DO 50 #P C MOVE '%' #SS,#P C ENDDO C* Selecting criteria is ready. C MOVEA#SS #SELCT 50 C* C* Walk through all the entries in the user space. C COUNT DOWLEQUSBPS C CALL 'QUSRTVUS' C PARM USERSP C PARM STRPOS C PARM LENDTA C PARM QUSDN C PARM QUSBN C* See if any errors were returned in the error code parameter. C Z-ADD4 #N C EXSR ERRCOD C* C* ============= Process the concrete object ==============. C* 1. Add one row in the table 1 ==========================. C/EXEC SQL C+ Insert Into QTEMP/FINDTBL1 C+ Values (:QUSDNC, :QUSDNB, :QUSDND, :QUSDNH) C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD8 #N C EXSR ERRSQL C* C* 2. Select the row into table 2 =========================. C $CASE IFNE 'Y' NO match case C/EXEC SQL C+ Insert Into QTEMP/FINDTBL2 C+ Select * C+ From QTEMP/FINDTBL1 C+ Where Upper(Desc) Like :#SELCT C/END-EXEC C ELSE match case ! C/EXEC SQL C+ Insert Into QTEMP/FINDTBL2 C+ Select * C+ From QTEMP/FINDTBL1 C+ Where Desc Like :#SELCT C/END-EXEC C ENDIF match case ? C* See if any errors were returned in the error code parameter. C Z-ADD9 #N C EXSR ERRSQL C* C* See if any errors were returned in the error code parameter. C Z-ADD15 #N C EXSR ERRSQL C* 3. Delete the row from table 1 =========================. C/EXEC SQL C+ Delete From QTEMP/FINDTBL1 C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD13 #N C EXSR ERRSQL C* C* ============= End of processing the concrete object ====. C* C ADD 1 COUNT C ADD QUSBPT STRPOS C* ** do for each objects C ENDDO C* C* Count the selected objects. C/EXEC SQL C+ Select Count(*) C+ Into :NNSEL C+ From QTEMP/FINDTBL2 C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD15 #N C EXSR ERRSQL C* C* Show F8, F9 Buttons C NNSEL IFGT 0 C MOVE *ON *IN20 C ENDIF C* C* -------------------------------- C* -- end handle list of objects -- C* -------------------------------- C* ** if objects > 0 C ENDIF C* C* ** if status is 'C' or 'P' C ENDIF C* C* Information in the user space is not accurate. C QUSBPJ IFEQ 'I' C MOVEA#E2,1 #MSGDT C EXSR MSGSND C ENDIF C* C* Information in the user space is partial. C QUSBPJ IFEQ 'P' C MOVEA#E2,2 #MSGDT C EXSR MSGSND C ENDIF C* C* ** do until F3 pressed C ENDDO C*==================================================== C*== End of main cycle ==== C*== get input and process it ==== C*==================================================== C* C* Delete the user space called APIUG1 in library QGPL. C CALL 'QUSDLTUS' C PARM USERSP C PARM QUSBN C* See if any errors were returned in the error code parameter. C Z-ADD5 #N C EXSR ERRCOD C* C* Deleting tables. C/EXEC SQL C+ Drop Table QTEMP/FINDTBL1 C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD11 #N C EXSR ERRSQL C* C/EXEC SQL C+ Drop Table QTEMP/FINDTBL2 C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD12 #N C EXSR ERRSQL C* C/EXEC SQL C+ Drop Table QTEMP/FINDTBL3 C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD19 #N C EXSR ERRSQL C* C* C* Restore Run Priority. C #RUNF IFEQ *ON C Z-ADD#JIRUN #JCRUN C CALL 'QWTCHGJB'@PJOBC C* See if any errors were returned in the error code parameter. C Z-ADD25 #N Error # C EXSR ERRCOD C ENDIF C* C* C* C SETON LR C RETRN C* C***************************************************************** C* End of Mainline **** C***************************************************************** C* C***************************************************************** C* Subroutine to handle errors returned in the error code **** C* parameter (User Space errors). **** C***************************************************************** C* C ERRCOD BEGSR C QUSBNC IFGT 0 C* C* Process errors returned from the API. C MOVEL#WH,#N #STR C MOVEA#STR #ER,18 C MOVEA#ER #MSGDT C EXSR MSGSND C* Original message returned by API C CALL 'QMHSNDPM' C PARM QUSBND C PARM #MSGF C PARM QUSBNG C PARM QUSBNC C PARM #MSGTP C PARM #QUEUE C PARM #SNDTO C PARM #MSGKY C PARM #ERRCD C* Exit if US create/delete error C #N IFEQ 1 C #N OREQ 5 C EXSR EXIT C ENDIF C* C ENDIF C ENDSR C* * C***************************************************************** C* Subroutine to handle errors returned in the error code **** C* parameter (SQL errors). **** C***************************************************************** C* C ERRSQL BEGSR C SQLCOD IFLT 0 C* C* Process errors returned from the API. C MOVEL#WH,#N #STR C MOVEA#STR #ER,18 C MOVEA#ER #MSGDT C EXSR MSGSND C* Original message returned by API C MOVEA'CPF' #ID,1 C Z-ADDSQLER1 #XER1 C MOVEL#XID ##TMPS 4 C MOVEA##TMPS #ID,4 C MOVEA#ID #QSGID C CALL 'QMHSNDPM' C PARM #QSGID C PARM #QSGF C PARM SQLERM #QSGDT C PARM SQLERL #QSGDL C PARM #QSGTP C PARM #QSQUE C PARM #QSSTO C PARM #QSMKY C PARM #QSRCD C* Exit if tables create/drop error C #N IFEQ 6 create error C SQLCOD ANDNE-601 already exist C #N OREQ 7 create error C SQLCOD ANDNE-601 already exist C #N OREQ 18 create error C SQLCOD ANDNE-601 already exist C #N OREQ 11 C #N OREQ 12 C #N OREQ 19 C EXSR EXIT C ENDIF C* C ENDIF C ENDSR C* * C***************************************************************** C* Subroutine to send program message to current message queue**** C***************************************************************** C* C MSGSND BEGSR C CALL 'QMHSNDPM' C PARM #MSGID C PARM #MSGF C PARM #MSGDT C PARM #MSGDL C PARM #MSGTP C PARM #QUEUE C PARM #SNDTO C PARM #MSGKY C PARM #ERRCD C ENDSR C***************************************************************** C* Subroutine to exit **** C***************************************************************** C* C EXIT BEGSR C SETON LR C RETRN C ENDSR C* C***************************************************************** C* Initialization **** C***************************************************************** C* C *INZSR BEGSR C* C *NAMVAR DEFN #N 20 err# C *NAMVAR DEFN #STR 23 err data C MOVEL*ON #RUNF 1 Run Prty Flag C* C* Cancel Commitment C/EXEC SQL C+ Set Transaction Isolation Level No Commit C/END-EXEC C* See if any errors were returned in the error code parameter. C Z-ADD23 #N C EXSR ERRSQL C* C ENDSR C* C***************************************************************** C* Parameters List **** C***************************************************************** C* C* Retrieving Job Information API C @PJOBI PLIST C PARM @JOBI C PARM #JILEN C PARM 'JOBI0100'P@FORM 8 C PARM '*' P@JOB 26 C PARM *BLANKS P@JOBN 16 C PARM QUSBN C* C* Change Job API C @PJOBC PLIST C PARM '*' P@JOB 26 C PARM *BLANKS P@JOBN 16 C PARM 'JOBC0100'P@FORM 8 C PARM @JOBC C PARM QUSBN C* C***************************************************************** ** Error occured by ** The objects information is incomplete - process stopped The objects information is partial but accurate - process was continued ** creating userspace 1 getting list of objects 2 retrieving header 3 retrieving object info 4 deleting userspace 5 creating table 1 6 creating table 2 7 inserting into table 1 8 inserting into table 2 9 viewing table 2 10 dropping table 1 11 dropping table 2 12 deleting from table 1 13 deleting from table 2 14 counting table 2 15 copying into file 16 labeling table 2 17 creating table 3 18 dropping table 3 19 inserting into table 3 20 selecting from table 3 21 deleting from table 3 22 cancelling commitment 23 retrieving Job inf. 24 changing run priority 25 ** RUNQRY QRYFILE((QTEMP/FINDTBL2))