|
Code:
- /////////////////////////////////////////////////////////////////////
- // Copyright (c) 2010 Dennis E. Lovelady
- // All rights reseved.
- //
- // Redistribution and use in source and binary forms, with or without
- // modification, are permitted provided that the following conditions
- // are met:
- // 1. Redistributions of source code must retain the above copyright
- // notice, this list of conditions and the following disclaimer.
- // 2. Redistributions in binary form must reproduce the above
- // notice, this list of conditions and the following disclaimer in
- // the documentation and/or other materials provided with the
- // distribution.
- //
- // THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS''
- // AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
- // TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
- // PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR
- // OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- // SPECIAL, EXEMPLARY, OR CONSEQUENTIALDAMAGES (INCLUDING, BUT NOT
- // LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
- // OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
- // AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- // LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
- // ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
- // POSSIBILITY OF SUCH DAMAGE.
- /////////////////////////////////////////////////////////////////////
-
- H Option(*SRCSTMT: *NoShowCpy) NoMain BndDir('QC2LE')
-
- ////////////////////////////////////////////////////////////////////
- // Retrieve call stack for debugging purposes
- // --
- // This procedure will retrieve and return the call stack suitable
- // for reporting the condition of the call stack at the time it is
- // called. The intended purpose is to allow such information to be
- // placed in the job log for analysis of issues and similar
- // situations. An example use of this would be to place reference
- // to it within an error handling routine, which might then
- // write the call stack information (as a *DIAG message) to the job
- // log just prior to issuing an escape message or similar.
- // --
- // The output can be trimmed such that the top of the call stack
- // and the last (n) entries don't appear. (For example, if the
- // output should not contain the name of this procedure nor the
- // errorHandler procedure from which it is called.
- // The entries are separated by a pair of colon characters (::) so
- // that the output might look like this:
- // QUOCMD/x01E1::TSTCALLSTK/2700::TSTCALLSTK(showCallStack)/9600
- // If preferred, the output may be shown in bottom-to-top fashion:
- // TSTCALLSTK(showCallStack)/9600::TSTCALLSTK/2700::QUOCMD/x01E1
- ////////////////////////////////////////////////////////////////////
-
- D/COPY QSYSINC/QRPGLESRC,QWVRCSTK
-
- D showCallStack PR 65535 ExtProc('showCallStack') Varying
- D topToSkip 10I 0 Value Options(*NoPass)
- D bottomToSkip 10I 0 Value Options(*NoPass)
- D bottomToTop N Value Options(*NoPass)
-
-
- P showCallStack B Export
- D showCallStack PI 65535 Varying
- D parmSkipTop 10I 0 Value Options(*NoPass)
- D parmSkipBotm 10I 0 Value Options(*NoPass)
- D parmOrder N Value Options(*NoPass)
-
-
- D RtvCallStack PR ExtPgm('QWVRCSTK')
- D receiver Const like(myReceiver)
- D rcvrSize 10I 0 Const
- D rcvFormat 8 Const
- D jobIDinfo Const likeDS(rqsJob)
- D jobInfoFmt 8 Const
- D myUSEC Like(errorStruct)
-
-
-
- D convertHexChar PR ExtProc('cvthc')
- D ptrCharReturn * Value
- D ptrHexSrc * Value
- D hexLength 10I 0 Value
-
-
- D errorStruct DS Inz Qualified
- D QUSBPRV 10I 0 Inz(%Size(errorStruct))
- D QUSBAVL 10I 0
- D QUSEI 7
- D 1
- D QUSED01 4096
- D bytesProvided Overlay(QUSBPRV)
- D Like(errorStruct.QUSBPRV)
- D bytesAvailable...
- D Overlay(QUSBAVL)
- D Like(errorStruct.QUSBAVL)
- D messageID Overlay(QUSEI)
- D Like(errorStruct.QUSEI)
- D messageData Overlay(QUSED01)
- D Like(errorStruct.QUSED01)
-
-
- D entryList S 65535 Varying
-
- D topToSkip S 10I 0 Inz(0)
- D bottomToSkip S 10I 0 Inz(0)
- D bottomToTop S N Inz(*Off)
-
- D entryString S 4096 Varying Dim(256)
- D procName S 4096 Varying
- D stmtIDs S 10 Dim(8) Based(pStmtIDs)
- D procNameArea S 4096 Based(pProcNameArea)
- D I S 10U 0
- D J S 10U 0
- D stmtID S 10 Varying
- D hexInt S 8
- D incr S 10I 0
- D start S 10I 0
- D stop S 10I 0
-
- D pReceiver S * Inz(%Addr(myReceiver))
- D myReceiver S 65535
- D hdr DS LikeDS(QWVK0100) Based(pReceiver)
- D pEntry S *
- D entry DS LikeDS(QWVCSTKE) Based(pEntry)
-
-
- D rqsJob DS Qualified Inz
- D jobname 10 Inz('*')
- D jobuser 10 Inz(*Blanks)
- D jobNumber 6 Inz(*Blanks)
- D intJobID 16 Inz(*Blanks)
- D 2 Inz(X'0000')
- D threadIndic 10I 0 Inz(2)
- D threadID 8 Inz(X'0000000000000000')
-
- /Free
-
- Reset errorStruct ;
- errorStruct.bytesProvided = %Size(errorStruct) ;
- If %Parms >= 1 ;
- topToSkip = parmSkipTop ;
- If %Parms >= 2 ;
- bottomToSkip = parmSkipBotm ;
- If %Parms >= 3 ;
- bottomToTop = parmOrder ;
- EndIF ;
- EndIF ;
- EndIF ;
-
- Clear entryList ; // Clear the field to be returned to caller
-
- // Retrieve the call stack information via IBM API
-
- rtvCalLStack(myReceiver: %Size(myReceiver)
- : 'CSTK0100'
- : rqsJob: 'JIDF0100'
- : errorStruct) ;
-
- // Position our header's pointer to the receiver area.
-
- pEntry = pReceiver + hdr.QWVEO ; // First entry
- For I = 1 to hdr.QWVERTN ; // For each call stack entry
- If entry.QWVPL = *Zero ; // No procedure name
- %Len(procName) = *Zero ; // Clear our copy
- Else ;
- pProcNameArea = pEntry + entry.QWVPD ;
- procName = %Subst(procNameArea: 1: entry.QWVPL) ;
- EndIF ;
- pStmtIDs = pEntry + entry.QWVSD ; // Point to the Stmt IDs
- entryString(I) = %Trim(entry.QWVPGMN) ;
- If %Len(procName) > *Zero and procName <> entry.QWVPGMN ;
- entryString(I) += '(' + %Trim(procName) + ')' ;
- EndIF ;
- If entry.QWVSRTN > *Zero ; // If stmt IDs present
- For J = 1 to entry.QWVSRTN ; // For each stmt ID
- stmtID = %Trim(stmtIDs(J)) ;
- DoW %Subst(stmtID: 1: 1) = '0' and %Len(stmtID) > 1 ;
- stmtID = %Subst(stmtID: 2) ;
- EndDO ;
- entryString(I) += '/' + %Trim(stmtID) ;
- EndFOR ;
- ElseIF entry.QWVCTION > *Zero ; // MI instruction #
- convertHexChar(%Addr(hexInt): %Addr(entry.QWVCTION)
- : %Size(hexInt)) ;
- If %Subst(hexInt: 1: 4) = '0000' ;
- entryString(I) += '/x' + %Subst(hexInt: 5) ;
- Else ;
- entryString(I) += '/x' + hexInt ;
- EndIF ;
- EndIF ;
- If %Len(entryList) > *Zero ;
- entryList += '::' ;
- EndIF ;
- // Finished with this entry. Since we have the length of this
- // entry in entry.QWVEL, we will add this value to current
- // pEntry to get next pEntry.
- pEntry += entry.QWVEL ; // Length this entry; -> Next
- EndFOR ;
-
- // Well, that was fun. Now let's order our output as requested,
- // and return all except any entries that the caller wanted skipped.
-
- Clear entryList ;
- If bottomToTop ; // Same sequence as IBM API
- incr = 1 ; // We'll INCREMENT our array idx
- start = bottomToSkip + 1 ; // Starting at ...
- stop = hdr.QWVERTN - topToSkip ; // Last entry to use
- Else ; // Oldest first
- incr = -1 ; // We'll DECREMENT our index
- start = hdr.QWVERTN - topToSkip ; // Starting at...
- stop = bottomToSkip + 1 ; // Last entry to use
- EndIF ;
- I = start ; // Ready ... go!
- For J = 1 to %Abs(stop - start) + 1 ;
- If %Scan('_QRNP_PEP_': entryString(I)) = 0
- and %Scan('_CL_PEP': entryString(I)) = 0 ;
- If %Len(entryList) > *Zero and %Len(entryString(I)) > 0 ;
- entryList += '::' ;
- EndIF ;
- entryList += entryString(I) ;
- EndIF ;
- I += incr ;
- EndFOR ;
-
- Return entryList ;
-
- *INLR = *On ;
- Return ;
-
- /End-free
-
- P E
-
-
-
-
- H Option(*SRCSTMT: *NoShowCpy) BNDDIR('LUVBNDDIR') DftActGrp(*NO)
-
-
- D showCallStack PR 65535 ExtProc('showCallStack') Varying
- D topToSkip 10I 0 Value Options(*NoPass)
- D bottomToSkip 10I 0 Value Options(*NoPass)
- D bottomToTop N Value Options(*NoPass)
-
-
- D subProc PR 65535 ExtProc('mySub') Varying
- D skipTop 10I 0 Value
- D skipBottom 10I 0 Value
- D oldestOnTop N Value
-
-
- D stack S 512 Varying
-
-
- D QUILNGTX PR ExtPgm('QUILNGTX')
- D text 65535a const options(*varsize)
- D length 10i 0 const
- D msgid 7a const
- D qualmsgf 20a const
- D errorCode 20i 0 const
-
-
- D Qp0zInitEnv pr 10i 0 extproc('Qp0zInitEnv')
-
-
- /Free
-
-
- Qp0zInitEnv() ;
- stack = subProc(2: 0: *Off) ;
- QUILNGTX(stack: %len(stack): *blanks: *blanks: 0);
- stack = subProc(2: 1: *On) ;
- QUILNGTX(stack: %len(stack): *blanks: *blanks: 0);
- stack = showCallStack() ;
- QUILNGTX(stack: %len(stack): *blanks: *blanks: 0);
- *INLR = *On ;
- Return ;
-
- /End-free
-
- P subProc B
- D subProc PI 65535 Varying
- D skipTop 10I 0 Value
- D skipBottom 10I 0 Value
- D oldestOnTop N Value
-
- /Free
- Return showCallStack(skipTop: skipBottom: oldestOnTop) ;
- /End-free
-
- P E
-
-
-
-
-
-
|
|