**free
//& Apache License ============================================================*
// Copyright © 2008-2021 TEMBO Technology Lab (Pty) Ltd.                       *
// Created by AO Foundation - www.adsero-optima.com                            *
// Original TEMPLATE author: Tommy Atkins - Chief Development Officer          *
//                                                                             *
// Licensed under the Apache License, Version 2.0 (the "License");             *
// you may not use this file except in compliance with the License.            *
// You may obtain a copy of the License at                                     *
//                       http://www.apache.org/licenses/LICENSE-2.0            *
//                                                                             *
// Unless required by applicable law or agreed to in writing, software         *
// distributed under the License is distributed on an "AS IS" BASIS,           *
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.    *
// See the License for the specific language governing permissions and         *
// limitations under the License.                                              *
//                                                                             *
// The above copyright notice and this permission notice shall be included in  *
// all copies or substantial portions of the Software.                         *
//                     https://www.i-nterprise.org/                            *
//                     https://www.adsero-optima.com/                          *
//=============================================================================*
//& Error Handler Services - ERR Internal Utilities
ctl-opt nomain aut(*use) extbinint(*yes) option(*nodebugio) debug;
//====================================================================
//& Exports
//  Application Error Handlers - Module 03
//  EXPORT SYMBOL(RTVCSTK00)      /* Retrieve Call Procedures
//  EXPORT SYMBOL(GetCSE_1)       /* Retrieve Target Call Stack Entry
//  EXPORT SYMBOL(PEP     )       /* Check if CSE is PEP
//  EXPORT SYMBOL(Cmd     )       /* Execute Command
//====================================================================
//& Prototypes
/include *LIBL/SRCCPY,ERR03       Move *DIAG and Resend *ESCAPE Messages
//==========================================================
dcl-pr   QWVRCSTK       extpgm('QWVRCSTK');
          Rcvr          char(4096)      options(*varsize);
          RcvrL          int(10)  const;
          RcvFmt        char(8)   const;
          JobIdInf      char(26)  const options(*varsize);
          JobIdFmt      char(8)   const;
          ErrorCode               like(EC);
end-pr;
//==========================================================
dcl-pr   ExeCmd         extpgm('QCMDEXC');
          P1            varchar(1024) const options(*varsize);
          P2            packed(15:5)  const;
end-pr;
//====================================================================
//& Data Definitions
/include *LIBL/SRCCPY,API_EC      API Error Code Data Structure
//==========================================================
dcl-ds   JobIdInf;
          JobName       char(10)  inz('*');
          UserName      char(10)  inz(' ');
          JobNo         char( 6)  inz(' ');
          IntJobId      char(16)  inz(' ');
          Rsvd1         char( 2)  inz(x'0000');
          ThreadInd      int(10)  inz(1);
          ThreadId      char( 8)  inz(x'0000000000000000');
end-ds;
//==========================================================
dcl-s    CS0100P   pointer   inz(%addr(CS0100));
dcl-s    CS0100L    int(10)  inz(%len(CS0100));
dcl-ds   CS0100     len(65534);
          BytesRet       int(10);
          BytesAvail     int(10);
          NoEntriesTh    int(10);
          CallStackOS    int(10);
          NoEntriesRet   int(10);
          ThreadIdRet   char(8) ;
          InfStatus     char(1) ;
          Resvd4        char(1) ;
end-ds;
//==========================================================
dcl-s    CSEntryP  pointer;
dcl-ds   CSE        len(65535)    based(CSEntryP) qualified;
          Length         int(10);
          StmIdOS        int(10);
          StmIdNo        int(10);
          ProcNameOS     int(10);
          ProcNameLen    int(10);
          ReqLev         int(10);
          ProgName      char(10);
          ProgLib       char(10);
          MIInstrNo      int(10);
          ModName       char(10);
          ModLib        char(10);
          CntrlBndry    char( 1);
          Resvd3        char( 3);
          ActGrpNo       uns(10);
          ActGrpName    char(10);
          Resvd2        char( 2);
          ProgASPName   char(10);
          ProgLibName   char(10);
          ProgASPNo      int(10);
          ProgLibASPNo   int(10);
          ActGrpNoLong   int(20);
          //  Reserved CHAR(*)
          //  Statement identifiers  ARRAY(*) of CHAR(10)
          //  Procedure name  CHAR(*)
end-ds;
//==========================================================
dcl-s    ProcNameP      pointer;
dcl-s    ProcName       char(256)    based(ProcNameP);
dcl-s    Procedure      char(256);
//& ==================================================================
//& GetCSE1: Retrieve Target CSE for Error Handlers
dcl-proc GetCSE1   export;
    dcl-pi    *n    int(10);
         MT    char(1)   const options(*nopass);
    end-pi;
//==========================================================
dcl-s    I      int(10);
//==========================================================
monitor;
   //=======================================================
   QWVRCSTK(CS0100:CS0100L:'CSTK0100':JobIdInf:'JIDF0100':EC);
   CSEntryP = CS0100P+CallStackOS; // Point to GetCSE1
   CSEntryP += CSE.Length;         // Point to ERR??
   CSEntryP += CSE.Length;         // Point to Caller of ERR??
   I = 2;
   //=======================================================
   select;
       //===================================================
       when %parms < 1;             // No Target = Default = Caller-1
            CSEntryP += CSE.Length; // Back up 1 in the Call Stack
            if PEP();               // If PEP
               return I+1;          // Return 3
            else;
               return I;            // Return 2
            endif;
       //===================================================
       when MT = 'P';                   // Program Boundary
            dow not PEP();              // Check Not PEP
                I += 1;                 // Add 1 to Counter
                CSEntryP += CSE.Length; // Step to Previous Entry
            enddo;
            return I;                   // Return 1 Before the PEP
       //===================================================
       when MT = 'C';                    // Control Boundary
            dow CSE.CntrlBndry = '0';    // Check not Control Boundary
                I += 1;                  // Add 1 to Counter
                CSEntryP += CSE.Length;  // Step to Previous Entry
            enddo;
            return I;                    // Return Counter to Control Boundary
       //===================================================
       other;
            return %int(MT) + 1;
       //===================================================
   endsl;
   //=======================================================
on-error;
endmon;
//==========================================================
end-proc;
//====================================================================
//& PEP: Check if CSE is PEP
dcl-proc PEP;
    dcl-pi    *n    ind      end-pi;
//==========================================================
monitor;
   //=======================================================
   ProcNameP = CSEntryP + CSE.ProcNameOS;
   Procedure = %subst(ProcName:1:CSE.ProcNameLen);
   if %scan('PEP':Procedure) <> 0;
       return '1';
   else;
       return '0';
   endif;
   //=======================================================
on-error;
endmon;
//==========================================================
end-proc;
//====================================================================
//& Cmd: Execute Command
dcl-proc Cmd       export;
    dcl-pi *n;
         Cmd$      varchar(4096) const  options(*varsize);
    end-pi;
//==========================================================
monitor;
//==========================================================
   ExeCmd(Cmd$:%len(Cmd$));
//==========================================================
on-error;
   ERR03();
endmon;
//==========================================================
end-proc;
//&===================================================================