*============================================================================================* * * * RTVCSTKE * * Retrieve previous entry on call stack. * * * * Compile as module then issue CRTPGM. You may use either as bind module, service program, * * or program. Note that on each stack there may be a system Program_Entry_Procedure entry. * * * * This program is provided as it is. Use at your own risk. * * http://www.datacrush.info * * * *============================================================================================* * Usage notes * * ------------ * * Please take note when passing in *ENTRY parameter to this module: * * Step_No : Expects the number of "backwards" call stack you want to retrieve. * * Step_Info : Returns call stack information (follow StackInfo data structure). * * Error_Ind : Returns "Y" if an error had occured. * *============================================================================================* * Maintenance Log * * --------------- * * Trace Date Pgmr. Notes * * ------------------------------------------------------------------------------------------ * * 20050411 Datacrush Enhancements. * * 20021231 Datacrush New. * *============================================================================================* *--------------------------------------------------------------------------------------------- * Controls *--------------------------------------------------------------------------------------------- * H AltSeq(*None) * *------------------------------------------------------------------------------------------ * Copybooks *------------------------------------------------------------------------------------------ * D/Copy Qsysinc/Qrpglesrc,Qwvrcstk D/Copy Qsysinc/Qrpglesrc,Qusec * *------------------------------------------------------------------------------------------ * Local data structures *------------------------------------------------------------------------------------------ * * Use with API D JobIdent Ds D JobName 10A Inz('*') D UserName 10A Inz(*Blanks) D JobNumber 6A Inz(*Blanks) D InternalId 16A Inz(*Blanks) D Reserved 2A Inz(*AllX'00') D ThreadInd 9B 0 Inz(1) D ThreadId 8A Inz(*AllX'00') * * Data structure to return to caller D StackInfo Ds Occurs(cMaxStorage) Inz D ReqLvl Like(Qwvrl01) Req. Level D PgmNam Like(Qwvpgmn) Pgm. Name D PgmLib Like(Qwvpgml) Pgm. Library D Inst Like(Qwvction) Instruction D ModNam Like(Qwvmn) Mod. Name D ModLib Like(Qwvmlib) Mod. Library D ActGrp Like(Qwvagn) Act. Group D ProcNam 50A Procedure * *------------------------------------------------------------------------------------------ * Local variables *------------------------------------------------------------------------------------------ * * Use with API D RcvVar S 2048A Inz(*Blanks) D RcvVarLen S 9B 0 Inz(%Size(RcvVar)) D FmtName_1 S 8A Inz('CSTK0100') D FmtName_2 S 8A Inz('JIDF0100') D ErrorCode S Like(Qusec) Inz(*Blanks) * * Offset calculations D Pos S 9B 0 Inz(*Zeros) D Cnt S 9B 0 Inz(*Zeros) D Idx S 9B 0 Inz(*Zeros) * * Use with entry parameters D Step_No S 10I 0 D Step_Info S Like(StackInfo) D Error_Ind S 1A * * Use as image to entry parameters D iStep_No S Like(Step_No) Inz(*Zeros) D iStep_Info S Like(Step_Info) Inz(*Blanks) D iError_Ind S Like(Error_Ind) Inz(*Blanks) * * Use with program flow controls D nPssr S 1N Inz(*Off) D nPssrCnt S 5I 0 Inz(*Zeros) * *------------------------------------------------------------------------------------------ * Local Constants *------------------------------------------------------------------------------------------ * * Use with return indicator D cYes C Const('Y') D cNo C Const('N') * * Use as static values D cMaxStorage C Const(255) * *------------------------------------------------------------------------------------------ * Keys and parameters list *------------------------------------------------------------------------------------------ * C *Entry Plist C Parm Step_No C Parm Step_Info C Parm Error_Ind * C PQwvrcstk Plist C Parm RcvVar C Parm RcvVarLen C Parm FmtName_1 C Parm JobIdent C Parm FmtName_2 C Parm ErrorCode * *------------------------------------------------------------------------------------------ * Main logic *------------------------------------------------------------------------------------------ * C If (nPssr = *Off) C ExSr SrInit C ExSr SrMain C ExSr SrRetn C Return * C Else C ExSr SrRetn C Move *On *InLr C EndIf * *------------------------------------------------------------------------------------------ * SrMain Sub Routine * Process call stack vectors *------------------------------------------------------------------------------------------ * C SrMain BegSr * C Eval Qusbprv = (%Size(Qusec)) C Z-Add *Zeros Qusbavl C Movel(P) Qusec ErrorCode * C Call 'QWVRCSTK' PQwvrcstk * C Movel(P) RcvVar Qwvk0100 C Z-Add Qwveo Pos C Add 1 Pos * C Z-Add *Zeros Cnt C DoW (Cnt < Qwvertn) And (Cnt < %Elem(StackInfo)) C Add 1 Cnt C Cnt Occur StackInfo C Eval Qwvcstke = (%Subst(RcvVar:Pos: C (%Size(Qwvcstke)))) C Z-Add Qwvrl01 ReqLvl C Movel(P) Qwvpgmn PgmNam C Movel(P) Qwvpgml PgmLib C Z-Add Qwvction Inst C Movel(P) Qwvmn ModNam C Movel(P) Qwvmlib ModLib C Movel(P) Qwvagn ActGrp C Eval ProcNam = (%Subst(RcvVar:Pos+Qwvpd:Qwvpl)) C Eval Pos = (Pos + Qwvel) C EndDo * C Sub 1 Cnt C Add 2 iStep_No C Clear iStep_Info * C If (iStep_No <= (Cnt / 2)) And C (iStep_No >= 2) C Eval Idx = (iStep_No * 2) C Sub 1 Idx C If (Idx > *Zeros) And (Idx <= %Elem(StackInfo)) C Idx Occur StackInfo C Movel(P) StackInfo iStep_Info C Else C Move *Blanks iStep_Info C Movel(P) cYes iError_Ind C EndIf C EndIf * C EndSr * *------------------------------------------------------------------------------------------ * SrInit Sub Routine * Program initialization routine *------------------------------------------------------------------------------------------ * C SrInit BegSr * C If (%Parms >= 1) C Z-Add Step_No iStep_No C EndIf C If (%Parms <= 0) Or C ((%Parms >= 1) And (Step_No <= *Zeros)) C Z-Add 1 iStep_No C EndIf * C Move *Blanks iStep_Info C Movel(P) cNo iError_Ind * C EndSr * *------------------------------------------------------------------------------------------ * SrRetn Sub Routine * Program return decision routine *------------------------------------------------------------------------------------------ * C SrRetn BegSr * C If (nPssrCnt < 2) C If (%Parms >= 2) C Movel(P) iStep_Info Step_Info C EndIf C If (%Parms >= 3) C Movel(P) iError_Ind Error_Ind C EndIf * C Else C Z-Add *Zeros nPssrCnt C EndIf * C EndSr * *------------------------------------------------------------------------------------------ * *Pssr Sub Routine * Exception handling routine *------------------------------------------------------------------------------------------ * C *Pssr BegSr * C Move *On nPssr C Add 1 nPssrCnt C Movel(P) cYes iError_Ind * C EndSr *