and the end
* tag into any member name (your choice)
* in file QRPGLESRC member type RPGLE. CRTBNDRPG to compile.
* NOTE: You need extract the install program only once, this same program
* will install any upload on this page.
*
* 3. Call the install program (or execute XmlPrevew) passing these 3 parms.
* 'your-member-name you uploaded this text into'
* 'your-source-file-name the member is in'
* 'your-library-name the source file is in'
*
* The various source members will be extracted and the objects required
* for the application will be created in your-library-name.
*
* Members in this install: (to view or manually extract members, scan
* Martin Rowe scripting cmd prompts
* David George intellectual input
* Thomas Raddatz command mode/where allowed
*
* Use xml tags in text to trigger:
* 1. Parse text into source members (create srcfile & member if required).
* 2. Compile source into objects.
* 3. Send installation progress user messages.
* 4. Execute qcmdexc as required.
*
* This program is free software, you can redistribute it and/or modify it
* under the terms of the GNU General Public License as published by
* the Free Software Foundation. See GNU General Public License for details
*---------------------------------------------------------------------------------------------
Fxmlinput if f 112 disk usropn uploaded text
Fqxxxsrc o f 112 disk usropn parsed out
*
* create parm prototypes
D qusrmbrd PR ExtPgm('QUSRMBRD') MEMBER DESCRIPTION
Db like(vrcvar) RCVR
D 10i 0 const RCVR LEN
D 8 const TYPE
D 20 const FILE LIB
D 10 MBR NAME
D 1 const OVERRIDE?
Db like(vApiErrDS)
*
D qmhsndpm PR ExtPgm('QMHSNDPM') SEND MESSAGES
D 7 ID
D 20 const FILE
Db like(qm_msgtxt) TEXT
D 10i 0 const LENGTH
D 10 const TYPE
D 10 QUEUE
D 10i 0 const STACK ENTRY
D 4 const KEY
Db like(vApiErrDS)
*
D qcmdexc PR ExtPgm('QCMDEXC')
D 500A options(*varsize)
D 15P 5 Const
*--------------------------------------------------------------------
D vrcvar s 145
D qm_msgid s 7
D qm_msgtxt s 65
D qm_msgq s 10
D qm_msgtyp s 10
D mbrname s 10
D mbrtype s 10
D mbrtext s 50
D srcfile s 10
D srclen s 5
D srccssid s 5
D bldexc s 500
D write_flag s 1n inz(*off)
D srcSeqno s 6s 2 inz(0)
D aa s 5u 0 inz(0)
D ll s 5u 0 inz(0)
D qs c ''''
* Error return code parm for APIs.
D vApiErrDs ds
D vbytpv 10i 0 inz(%size(vApiErrDs)) bytes provided
D vbytav 10i 0 inz(0) bytes returned
D vmsgid 7 error msgid
D vresvd 1 reserved
D vrpldta 50 replacement data
*--------------------------------------------------------------------
Ixmlinput ns
I 13 21 xmltag1
I 18 27 xmltag2
I 13 112 xmlcode
*--------------------------------------------------------------------
C *entry plist
C parm ParseSrcMbr 10 source member
C parm ParseSrcFile 10 source file
C parm ParseSrcLib 10 source lib
* xmlpreview uses this parm to redirect to user selected source file. optional
C parm OvrSrcFile 10 override to source
C exsr srValidate make sure exists
* Set user selected library *first for remainder of program
C eval bldexc = 'RMVLIBLE LIB('+
C %trimr(ParseSrcLib) + ')'
C callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)))
C eval bldexc = 'ADDLIBLE LIB('+
C %trimr(ParseSrcLib) + ') POSITION(*FIRST)'
C callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)))
*
* Override Input file to uploaded text file
C eval bldexc = 'OVRDBF FILE(XMLINPUT) TOFILE(' +
C %trimr(ParseSrcLib)+'/'+
C %trimr(ParseSrcFile) + ') MBR(' +
C %trimr(ParseSrcMbr) + ')'
C callp qcmdexc(bldexc:%len(%trimr(bldexc)))
C open xmlinput
C read xmlinput
1B C dow not %eof
* write records to outfile if flag is on
2B C select
2X C when write_flag = *on
3B C if xmltag2<>''
C eval srcSeqno=srcSeqno+1
C except write_one
3X C else
C eval write_flag=*off
C close qxxxsrc
3E C endif
* Extract values based on xml tags.
2X C when xmltag1 = 'mbrname ='
C eval mbrname = %subst(xmlcode:13:10)
2X C when xmltag1 = 'mbrtype ='
C eval mbrtype =%subst(xmlcode:13:10)
2X C when xmltag1 = 'mbrtext ='
C eval mbrtext =%subst(xmlcode:13:50)
2X C when xmltag1 = 'srcfile ='
3B C if %parms=4 xmlpreview override
C eval srcfile=OvrSrcFile
3X C else
C eval srcfile =%subst(xmlcode:13:10)
3E C endif
2X C when xmltag1 = 'srclen ='
3B C if %parms=4 xmlpreview override
C eval srclen='00112'
3X C else
C eval srclen =%subst(xmlcode:13:5)
3E C endif
2X C when xmltag1 = 'srccssid='
C eval srccssid=%subst(xmlcode:13:5)
* Start of data to copy. Create source files/mbrs as required.
2X C when xmltag1=''
* crtsrcpf
C eval bldexc = 'CRTSRCPF FILE(' +
C %trimr(ParseSrcLib)+'/'+
C %trimr(srcfile) + ') RCDLEN(' +
C srclen + ') CCSID(' +
C srccssid + ')'
C callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)))
* addpfm
C eval bldexc = 'ADDPFM FILE(' +
C %trimr(ParseSrcLib)+'/'+
C %trimr(srcfile) + ') MBR(' +
C %trimr(mbrname) + ') SRCTYPE(' +
C %trimr(mbrtype) + ') TEXT(' +
C qs+%trimr(mbrtext)+qs + ')'
C callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)))
3B C if %error
* chgpfm
C eval bldexc = 'CHGPFM FILE(' +
C %trimr(ParseSrcLib)+'/'+
C %trimr(srcfile) + ') MBR(' +
C %trimr(mbrname) + ') TEXT(' +
C qs+%trimr(mbrtext)+qs + ')'
C callp qcmdexc(bldexc:%len(%trimr(bldexc)))
* clr mbr
C eval bldexc = 'CLRPFM FILE(' +
C %trimr(ParseSrcLib)+'/'+
C %trimr(srcfile) + ') MBR(' +
C %trimr(mbrname) + ')'
C callp qcmdexc(bldexc:%len(%trimr(bldexc)))
3E C endif
* ovr to outfile mbr
C eval bldexc = 'OVRDBF QXXXSRC ' +
C %trimr(ParseSrcLib) + '/' +
C %trimr(srcfile) + ' ' +
C mbrname
C callp qcmdexc(bldexc:%len(%trimr(bldexc)))
C clear srcSeqno
C open qxxxsrc
C eval write_flag = *on
*--------------------------------------------------------------------
* Compile statement. Read next record and execute it.
* The subroutine TolibToken will replace &tolib with the
* library the user has selected at run time.
2X C when xmltag1 = ''
C read xmlinput
C eval bldexc = %trimr(xmlcode)
C exsr TolibToken
C callp qcmdexc(bldexc:%len(%trimr(bldexc)))
*--------------------------------------------------------------------
* qcmdexc statement. Build statement from each record between start
* and stop tags. When stop tag is found, execute statement.
* if dltxxx command, allow errors to be ignored.
2X C when xmltag1 = ''
C clear bldexc
C eval aa=1
C read xmlinput
3B C dow xmltag2<>''
C eval %subst(bldexc:aa:100)=xmlcode
C eval aa=aa+100
C read xmlinput
3E C enddo
C exsr TolibToken
3B C if %subst(bldexc:1:3)='DLT'
C callp(e) qcmdexc(bldexc:%len(%trimr(bldexc)))
3X C else
C callp qcmdexc(bldexc:%len(%trimr(bldexc)))
3E C endif
*--------------------------------------------------------------------
* Send messages to user as program executes
* Extract message ID, Message Type, from
* read a record and get the single line of message text.
2X C when xmltag1 = '0
C eval bldexc=%replace(%trimr(ParseSrcLib):bldexc:
C aa:6)
C eval aa=%scan('&tolib':bldexc)
1E C enddo
* if user has selected to override source files, reset SRCFILE parm in bldexcs.
1B C if %parms=4 xmlpreview override
C eval aa=%scan('SRCFILE(':bldexc)
2B C if aa>0
C eval aa=%scan('/':bldexc:aa)
3B C if aa>0
C eval ll=%scan(')':bldexc:aa)
C eval bldexc=%replace(%trimr(OvrSrcFile):bldexc:
C aa+1:ll-(aa+1))
3E C endif
2E C endif
1E C endif
C endsr
*--------------------------------------------------------------------
* Check of file, lib, member exist.
C srValidate begsr
C callp QUSRMBRD(
C vrcvar:
C 145:
C 'MBRD0100':
C ParseSrcFile + ParseSrcLib:
C ParseSrcMbr:
C '0':
C vapierrds)
* --------------------------------------------------------------------------------
* If error occurred on call, send appropriate message back to user.
1B C if vBytav>0 error occurred
2B C select
* lib not found
2X C when vmsgid = 'CPF9810'
C eval qm_msgtxt = '0000 Library ' +
C %trimr(ParseSrcLib) + ' was not found.'
* src file not found
2X C when vmsgid = 'CPF9812'
C eval qm_msgtxt = '0000 Source file ' +
C %trimr(ParseSrcFile)+' was not found in ' +
C %trimr(ParseSrcLib) + '.'
* member not found
2X C when vmsgid = 'CPF9815'
C eval qm_msgtxt = '0000 Member ' +
C %trimr(ParseSrcMbr)+' was not found in ' +
C %trimr(ParseSrcLib)+'/'+ %trimr(ParseSrcFile)
* unexpected
2X C other
C eval qm_msgtxt = '0000 Unexpected message ' +
C vmsgid + ' received. '
2E C endsl
* send message
C eval qm_msgid = 'CPD0006'
C eval qm_msgtyp = '*DIAG'
C eval qm_msgq = '*CTLBDY'
C exsr srSndMessage
C eval qm_msgtxt = *blanks
C eval qm_msgid = 'CPF0002'
C eval qm_msgtyp = '*ESCAPE'
C exsr srSndMessage
C eval *inlr=*on
C return
1E C endif
C endsr
*--------------------------------------------------------------------
C srSndMessage begsr
C callp QMHSNDPM(
C qm_msgid:
C 'QCPFMSG *LIBL ':
C qm_msgtxt:
C %size(qm_msgtxt):
C qm_msgtyp:
C qm_msgq:
C 1:
C ' ':
C vApiErrDS)
C endsr
Oqxxxsrc e write_one
O srcSeqno 6
O 12 '000000'
O xmlcode 112
* /// END OF INSTALL PGM HERE /// do not copy past this point ********** ///
]]>
* This program is free software, you can redistribute it and/or modify it under the terms
* of the GNU General Public License as published by the Free Software Foundation.
*
* 11/13/2001 Luca Brignoli (luca.brignoli@volvo.com)
* added array lookup to only load unique commands to screen.
*----------------------------------------------------------------
* program summary:
* call api to load job log messages to user space
* use pointers to get offset information
* only show valid commands
* load and display subfile of executed commands
*----------------------------------------------------------------
* api (application program interfaces) used:
* quscrtus create user space
* qusptrus retrieve pointer to user space
* qmhljobl list job log messages
* qmhsndpm send program messages
*----------------------------------------------------------------
Fcmdlogd cf e workstn
F sfile(data:rrn)
D uSpaceName s 20 inz('JCRCMDS QTEMP ')
D rrn s 5u 0
D mMsgRtv ds inz
D mMsgRtvLen 9 12i 0 length msg retrieved
D mMsgMessage 25 256 message retrieved
D mMsgLen s 10i 0 inz(%len(mMsgRtv)) length of message
*
* Arrays LUCA
D CmdList s 500 dim(1000) LUCA
D CmdCounter s 5u 0 LUCA
D CmdP s 5u 0 LUCA
*
*----------------------------------------------------------------
* Get user space list info from header section.
*----------------------------------------------------------------
D ds based(uHeadPtr)
D uOffSetToList 125 128i 0 offset to list
D uNumOfEntrys 133 136i 0 number list entries
D uSizeOfEntry 137 140i 0 list entry size
*
D uListEntry1 ds Based(uListPtr )
D uOffsetToNext 10i 0 overlay(uListEntry1:1)
D uOffsetToFlds 10i 0 overlay(uListEntry1:5)
D uNumFldsRetrnd 10i 0 overlay(uListEntry1:9)
D uMsgSeverity 10i 0 overlay(uListEntry1:12)
D uMsgId 7a overlay(uListEntry1:17)
D uMsgType 2a overlay(uListEntry1:24)
D uMsgKey 4a overlay(uListEntry1:26)
D uMsgFileName 10a overlay(uListEntry1:30)
D uMsgFileLib 10a overlay(uListEntry1:40)
*
* these fields repeat for each key selected.
D uListEntry2 ds Based(uListPtr2)
D u2OffsetToNext 10i 0
D u2LengthOfFlds 10i 0
D u2IdentifierF 10i 0
D u2TypeOfData 1a
D u2StatOfData 1a
D u2Reserved 14a
D u2LengthOfData 10i 0
D u2Data 500
*----------------------------------------------------------------
* Error return code parm for APIs.
*----------------------------------------------------------------
D vApiErrDs ds
D vbytpv 10i 0 inz(%size(vApiErrDs)) bytes provided
D vbytav 10i 0 inz(0) bytes returned
D vmsgid 7a error msgid
D vresvd 1a reserved
D vrpldta 50a replacement data
*
*----------------------------------------------------------------
* Message selection data structure.
*----------------------------------------------------------------
D MsgSelectDS ds
D msMaxMsgRequested...
D 10i 0 inz(1000) overlay(msgSelectDS:1) num of msg requested
D msListDirection...
D 10a inz('*PRV') overlay(msgSelectDS:5) List direction
D msQualifiedJobName...
D 10a inz('*') overlay(msgSelectDS:15) * = current job
D msQualifiedUserName...
D 10a inz(' ') overlay(msgSelectDS:25) = current job
D msQualifiedJobNumber...
D 6a inz(' ') overlay(msgSelectDS:35) = current job
D msInternalJobIdentifier...
D 16a inz(' ') overlay(msgSelectDS:41) = current job
D msStartingMessageKey...
D 4a inz(x'FFFFFFFF') start newest message
D overlay(msgselectDS:57)
D msMaxMsgLength...
D 10i 0 inz(500) overlay(msgSelectDS:61) id 301,302 lengths
D msMaxMsgHelpLength...
D 10i 0 inz(100) overlay(msgSelectDS:65) id 401,402,403,404
D msOffsetToIdentifiersOfFieldstoReturn...
D 10i 0 inz(84) overlay(msgSelectDS:69) to start of array
D msNumberOfFieldsToReturn...
D 10i 0 inz(1) overlay(msgSelectDS:73)
D msOffsetToCallMsgQname...
D 10i 0 inz(88) overlay(msgSelectDS:77)
D msLengthOfCallMsgQname...
D 10i 0 inz(1) overlay(msgSelectDS:81)
D msIndentifiersOfFieldsToReturn...
D 10i 0 inz(0301) overlay(msgSelectDS:85)
D msCallMessageQueueName...
D 1a inz('*') overlay(msgSelectDS:89)
*---------------------------------------------------------------------------------------------
* Create Prototypes for calls
*---------------------------------------------------------------------------------------------
D quscrtus PR ExtPgm('QUSCRTUS') create user space
D 20 Space Name
D 10 const Extended Attrb
D 10i 0 const length of space
D 1 const Hex0Init
D 10 const Use Authority
D 50 const text
D 10 const replace object
Db like(vApiErrDS) error parm
* -------------------------------------------------------------
D qmhrtvm PR ExtPgm('QMHRTVM') RETRIEVE MESSAGE
D 256 message retrieved
D 10i 0 length of message
D 8 const requested format
D 7 msg identifier
D 20 const qualified msgf name
D 128 const replacement data
D 10i 0 const len of replace data
D 10 const substitution char
D 10 const format control char
Db like(vApiErrDs)
* -------------------------------------------------------------
D system PR 10I 0 extproc('system')
D i_cmd * value options(*string)
*
D EXCP_MSGID S 7A import('_EXCP_MSGID')
* -------------------------------------------------------------
D qmhljobl PR ExtPgm('QMHLJOBL ') list job log messags
D 20 Space Name
D 8 const format name
Db like(MsgSelectDS)
D 10i 0 const LENGTH
D 8 const format of msgselect
Db like(vApiErrDS) error parm
* -------------------------------------------------------------
D qusptrus PR ExtPgm('QUSPTRUS') retrieve pointer
D 20 Space Name
D * pointer
Db like(vApiErrDS) error parm
* -------------------------------------------------------------
D qmhsndpm PR ExtPgm('QMHSNDPM') SEND MESSAGES
D 7 const ID
D 20 const FILE
D 73 const TEXT
D 10i 0 const LENGTH
D 10 const TYPE
D 10 const QUEUE
D 10i 0 const STACK ENTRY
D 4 const KEY
Db like(vApiErrDS)
* -------------------------------------------------------------
D qcmdchk PR ExtPgm('QCMDCHK')
D 500A
D 15P 5 Const
* -------------------------------------------------------------
D main PR extpgm('CMDLOGR ')
D main PI
*----------------------------------------------------------------
* Create user space
C callp QUSCRTUS( CREATE USER SPC
C uSpaceName: CREATE USER SPC
C 'TEST': EXTENDED ATRIB
C 1500000: SIZE IN BYTES
C x'00': INITIAL VALUE
C '*ALL': AUTHORITY
C 'User Space JCR ': TEXT
C '*NO': REPLACE OBJ
C vApiErrDs) ERROR
* Get pointer to user space
C callp QUSPTRUS( GET POINTER TO SPACE
C uSpaceName: SPACE LIB
C uHeadPtr: pointer to header
C vApiErrDs) error
* call api to load job log into user space.
C callp QMHLJOBL( LIST JOB LOG
C uSpaceName: USR SPACE
C 'LJOB0100': TYPE FORMAT
C MsgSelectDS: DS
C %len(MsgSelectDS):
C 'JSLT0100':
C vApiErrDs)
* Process elements
C eval CmdCounter=%elem(CmdList)+1 LUCA
C eval Cmdp =%elem(CmdList) LUCA
*
C eval uListPtr = uHeadPtr + uOffSetToList START OF LIST
1B C do uNumOfEntrys PROCESS LOOP
2B C if uMsgType = '08' or uMsgType='10'
C eval uListPtr2 = uHeadPtr + uOffsetToFlds
3B C if %subst(u2data:1:1)>' ' and
C %subst(u2data:1:2)<>'/*' and
C %subst(u2data:1:6)<>'cmdlog' and
C %subst(u2data:1:6)<>'endrqs'
C eval FullCmd=%subst(u2Data:1:U2LengthOfData)
C
* Code by Luca Brignoli to only show command once
* regardless of number times used.
* Load and lookup the array from the back end so
* the lookup doesn't have to search blank elements.
C FullCmd lookup CmdList(Cmdp) 99 LUCA
4B C if *in99 = *off LUCA
C eval CmdCounter = CmdCounter - 1 LUCA
C eval CmdList(CmdCounter) = FullCmd LUCA
*
C callp(e) qcmdchk(FullCmd:%len(%trimr(FullCmd)))
5B C if not %error
C eval cmdmsg73=FullCmd
C eval rrn=rrn+1
C write data LOAD SUBFILE
5E C endif
4E C endif
C eval Cmdp=CmdCounter LUCA
3E C endif
2E C endif
C eval uListPtr = uHeadPtr + uOffsetToNext
1E C enddo
*
* allow the user to make a selection from subfile.
C eval s1recnum=1
C eval *in01 = (rrn > 0) THERE ARE RECOR
C eval *in02 = *on DISPLAY CONTRL
1B C dow not *inkc
C write contrl DISPLAY SUBFILE
C exfmt keys GET USER RESPON
2B C if *in01=*off or *inkc or *inkl
1L C leave
2E C endif
*
* Find the record in the subfile the user has selected.
C clear errmsg
C eval *in30=*off
*
C readc data READ CHANGED
2B C dow not %eof PROCESS LOOP
C eval EXCP_MSGID = ' '
C eval *in20=*off
*
3B C if select = '1' PROMPT
C callp system(FullCMD)
3E C endif
3B C if select = '2' RUN
C callp SYSTEM('?'+FullCMD)
3E C endif
*
3B C if EXCP_MSGID>*blanks error occurred
C eval *in20=*on sbf error
C eval *in30=*on error message
*
* call retrieve message API to pull in message text
C callp QMHRTVM( rtvmsgd
C mMsgRtv : message retrieved
C mMsgLen : length of message
C 'RTVM0100': requested format
C EXCP_MSGID: msg identifier
C 'QCPFMSG *LIBL': qualified msg file
C ' ': replacement data
C 0: len of replace data
C '*YES ': substitution char
C '*NO ': format control char
C vApiErrDs)
* load error message
C eval errmsg = EXCP_MSGID +': ' +
C %subst(mMsgMessage:1:mMsgRtvLen)
3E C endif
*
* Update subfile to reflect selected change.
C clear select RESET
C eval s1recnum = rrn
C update data UPDATE SUBFILE
*
C readc data READ CHANGED
2E C enddo
1E C enddo NO SELECTION
*
* Send completion message
C callp QMHSNDPM(
C ' ':' ':
C 'Command retrieval - completed':
C 73:'*INFO ':'*CTLBDY ': 1:' ':
C vApiErrDS)
C eval *inlr = *on PROGRAM END
C return
]]>
*/
/* */
/* This program is free software, you can redistribute it and/or modify it */
/* under the terms of the GNU General Public License as published by */
/* the Free Software Foundation. See GNU General Public License for detail.*/
/*--------------------------------------------------------------------------*/
CMD PROMPT('Previously Executed Commands')
]]>