*=================================================================================== * MIT License * Copyright (c) 2016 TEMBO Technology Labs (Pty) Ltd. * Author: Tommy Atkins - Chief Development Officer * * Permission is hereby granted, free of charge, to any person obtaining a copy of this * software and associated documentation files (the "Software"), to deal in the Software * without restriction, including without limitation the rights to use, copy, modify, * merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit * persons to whom the Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in all copies * or substantial portions of the Software. * ================================================================================== * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, * INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR * PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE * FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR * OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. *=================================================================================== h nomain aut(*use) *=============================================================== * Retrieval of Job Call Stack Information * CallStkEnt: Retrieve Target CSE for Error Handlers *=============================================================== d EC ds d ByteIn 9b 0 inz(0) d ByteOut 9b 0 inz(0) d ErrorId 7 inz(' ') d Resvd1 1 inz(' ') d ErrorDta 20 inz(' ') *=============================================================== d QWVRCSTK pr extpgm('QWVRCSTK') d Rcvr 4096 options(*varsize) d RcvrL 10i 0 d RcvFmt 8 const d JobIdInf 26 const options(*varsize) d JobIdFmt 8 const d ErrorCode like(EC) *=============================================================== d JobIdInf ds d JobName 10 inz('*') d UserName 10 inz(' ') d JobNo 6 inz(' ') d IntJobId 16 inz(' ') d Rsvd1 2 inz(x'0000') d ThreadInd 10i 0 inz(1) d ThreadId 8 inz(x'0000000000000000') *=============================================================== d CS0100P s * inz(%addr(CS0100)) d CS0100L s 10i 0 inz(%len(CS0100)) d CS0100 ds 65534 d BytesRet 10i 0 d BytesAvail 10i 0 d NoEntriesTh 10i 0 d CallStackOS 10i 0 d NoEntriesRet 10i 0 d ThreadIdRet 8 d InfStatus 1 d Resvd 1 *=============================================================== d CSEntryP s * d CSE ds 65535 based(CSEntryP) qualified d Length 10i 0 d StmIdOS 10i 0 d StmIdNo 10i 0 d ProcNameOS 10i 0 d ProcNameLen 10i 0 d ReqLev 10i 0 d ProgName 10 d ProgLib 10 d MIInstrNo 10i 0 d ModName 10 d ModLib 10 d CntrlBndry 1 d Resvd 3 d ActGrpNo 10u 0 d ActGrpName 10 d Resvd2 2 d ProgASPName 10 d ProgLibName 10 d ProgASPNo 10i 0 d ProgLibASPNo 10i 0 d ActGrpNoLong 20u 0 * Reserved CHAR(*) * Statement identifiers ARRAY(*) of CHAR(10) * Procedure name CHAR(*) *=============================================================== d ProcNameP s * d ProcName s 256 based(ProcNameP) d Procedure s 256 *=============================================================== d CallStkEnt pr 10i 0 d MT 1 const options(*nopass) *=============================================================== d PEP pr n *=============================================================== * CallStkEnt: Retrieve Target CSE for Error Handlers <<<<<<<<<<< *=============================================================== p CallStkEnt b export d CallStkEnt pi 10i 0 d MT 1 const options(*nopass) *=========================================== d I s 10i 0 *=========================================== /free //========================================= QWVRCSTK(CS0100:CS0100L:'CSTK0100':JobIdInf:'JIDF0100':EC); CSEntryP = CS0100P+CallStackOS; CSEntryP += CSE.Length; CSEntryP += CSE.Length; I = 2; //========================================= if %parms < 1; CSEntryP += CSE.Length; if PEP(); return I+1; else; return I; endif; endif; //========================================= if MT = 'P'; // Program Boundary dow not PEP(); I += 1; CSEntryP += CSE.Length; enddo; return I; endif; //========================================= if MT = 'C'; // Control Boundary dow CSE.CntrlBndry = '0'; I += 1; CSEntryP += CSE.Length; enddo; return I; endif; //========================================= /end-free *=========================================== p CallStkEnt e *=============================================================== * PEP: Check if CSE is PEP <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< *=============================================================== p PEP b d PEP pi n *=========================================== /free //========================================= ProcNameP = CSEntryP + CSE.ProcNameOS; Procedure = %subst(ProcName:1:CSE.ProcNameLen); //========================================= if %scan('PEP':Procedure) <> 0; return '1'; else; return '0'; endif; //========================================= /end-free p PEP e *===============================================================