You must be logged in to use the copy button.

        
**free
ctl-opt
    copyright('Copyright JAS, Inc. 2024')
    nomain debug option(*srcstmt : *nodebugio)  ccsid(*char:*jobrun)
    decedit(*jobrun) alwnull(*usrctl)
    DatFmt(*ISO) TimFmt(*ISO);
//*****************************************************************************
//  PURPOSE: This application will get the name of the caller application
//  COMPILE Module: CRTRPGMOD MODULE(*CURLIB/JSCALLSTK) SRCFILE(*CURLIB/QRPGLESRC)
//                  SRCMBR(JSCALLSTK) DBGVIEW(*SOURCE) REPLACE(*YES)
//  COMPILE SrvPgm: CRTSRVPGM SRVPGM(*CURLIB/JSCALLSTK) EXPORT(*ALL) ACTGRP(*CALLER)
//                  ADDBNDDIRE BNDDIR(JSUPE1/JASTOOL) OBJ((JSCALLSTK))
// **********************************************************************************

/define Get_Caller_pr
/copy qProtosrc,JSCALLSTK

dcl-proc Get_Caller export;

/define Get_Caller_pi
/copy qProtosrc,JSCALLSTK

//*****************************************************************************
/copy QSYSINC/QRPGLESRC,QWVRCSTK
/copy QSYSINC/QRPGLESRC,QWCATTR

  dcl-pr Rtv_CallStack        extpgm('QWVRCSTK');
    CStkRcvr              likeds(QWVK0100) options(*varsize);
    CStkRLen              int(10:0) const;
    CStkRFmt              char(8)   const;
    CStkJInfo             likeds(QWCF0100) options(*varsize);
    CStkJFmt              char(8)   const;
    CStkErrC              likeds(ApiErrC)  options(*varsize);
  end-pr;

  dcl-ds ApiErrC        Qualified Inz;
    BytProv             Int(10:0) Inz(%size(ApiErrC));
    BytAvail            Int(10:0);
    MsgId               Char(7);
    Reserved            Char(1);
    MsgData             Char(3000);
  end-ds;

  // data structure to return a call stack entry
  dcl-ds IBMAPI_CStkE     qualified;
    QWVEL                 int(10:0);               // Entry Length
    QWVSD                 int(10:0);               // Stmt Displacement
    QWVSRTN               int(10:0);               // Stmt Returned
    QWVPD                 int(10:0);               // Proc Displacement
    QWVPL                 int(10:0);               // Proc Length
    QWVRL01               int(10:0);               // Request Level
    QWVPGMN               char(10);                // Program Name
    QWVPGML               char(10);                // Program Library
    QWVCTION              int(10:0);               // Instruction
    QWVMN                 char(10);                // Module Name
    QWVMLIB               char(10);                // Module Library
    QWVCB                 char(1);                 // Control Bdy
    QWVERVED01            char(3);                 // Reserved
    QWVAGNBR              uns(10:0);               // Act Group Number
    QWVAGN                char(10);                // Act Group Name
    QWVRSV201             char(2);                 // Reserved 2
    QWVPASPN              char(10);                // Program ASP Name
    QWVLASPN              char(10);                // Pgm Library ASP Name
    QWVPASPN00            int(10:0);               // Program ASP Number
    QWVLASPN00            int(10:0);               // Pgm Library ASP No.
    QWVAGNL               uns(20:0);               // Act Group No. (Long)
    QWVSI                 char(10);                // Statement Ident.
    QWVPN                 char(200);               // Procedure Name
  end-ds;

  dcl-s w_Count            int(10:0) inz(*zero);
  dcl-s w_Program char(10) inz;

  dcl-ds CallStack      len(65535) qualified;
    Hdr                 likeds(QWVK0100);
  end-ds;

  dcl-ds CurrEntry      likeds(IBMAPI_CStkE) Based(CurrPtr);
  dcl-s  w_PgmPosition  int(10:0) inz;
  dcl-s w_PgmLevel      char(50)  inz;
  //** Main *********************************************************************
  if %parms >= %parmnum(p_PgmPosition) and not %omitted(p_PgmPosition)
                                       and p_PgmPosition > 0;
    w_PgmPosition = p_PgmPosition;
  else;
    // Position 3 is the default location of the calling program
    // but if the calling program calls this service program then the location
    // will be in 8th position depending on how deep this application is called
    // in the procedure
    w_PgmPosition = 3;
  endIf;

  clear QWCF0100;                    // initialize job info structure
  QWCJN02 = '*';                     // for current job
  QWCERVED06 = *loval;               // no internal job identifier
  QWCTI00 = 1;                       // use currently running thread
  QWCTI01 = *loval;                  // no thread identifier
  callp Rtv_CallStack( CallStack: %len(CallStack)     : 'CSTK0100'
                                : QWCF0100: 'JIDF0100': ApiErrC );

  if ApiErrC.BytAvail > *zero;         // if API issued an error message
    return w_Program;                  // exit
  endif;

  CurrPtr = %addr(CallStack) + CallStack.Hdr.QWVEO; // point to first entry
  w_Count = 1;                         // find specified program name
  dou w_Count = w_PgmPosition;         // Calling pgm is on position 3rd
    if %parms >= %parmnum(p_Debug);
      w_PgmLevel = %char(w_Count) + '=' + %trim(CurrEntry.QWVPGMN);
      dsply w_PgmLevel;
    endIf;

    CurrPtr += CurrEntry.QWVEL;        // point to next entry
    w_Count += 1;
  enddo;

  w_Program = CurrEntry.QWVPGMN;
  return w_Program;                 // return the call stack entry
end-proc;