*=================================================================================== * Check for Legacy Program Service Procedure *=================================================================================== * 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) *=============================================================== * Percolate *DIAG messages and ReSend *ESCAPE messages d ERR03 pr d MT 1 const options(*nopass) *=============================================================== 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(' ') *=============================================================== *CheckLegacy pr n extproc('UTLSRV@001A') d UTLSRV@001A pr n d Program 10 *=============================================================== * Retrieve Call Stack Entries 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 RVP s * inz(%addr(RV)) d RVL s 10i 0 inz(%len(RV)) d RV 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 Res1 1 *=============================================================== d CSEP s * d CSE ds 65535 based(CSEP) d Len 10i 0 d StmIdOS 10i 0 d StmIdNo 10i 0 d PNOS 10i 0 d PNLen 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 Res2 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 PP s * d PN s 256 based(PP) d Procedure s 256 *=============================================================== d Libs ds d Lib1 10 inz('Library1') d Lib2 10 inz('Library2') d Lib3 10 inz('Library3') d Lib4 10 inz('Library4') d Lib5 10 inz('Library5') d Lib6 10 inz('Library6') *=============================================================== d PEPEnt pr n *=============================================================== * Scan for Legacy Library <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< *=============================================================== * This procedure scans for the calling procedures originating library * and if found in the list of Legacy libraries returns a *TRUE * indicator and the name of the program issuing the call. p UTLSRV@001A b export d UTLSRV@001A pi n d Program 10 *===================================================== d I s 5i 0 *===================================================== /free //============================================================= monitor; //================================================ // Retrieve the call stack QWVRCSTK(RV:RVL:'CSTK0100':JobIdInf:'JIDF0100':EC); CSEP = RVP + CallStackOS; // Point to the list of call stack entries //================================================ dou PEPEnt(); // Read the call stack until a procedure CSEP += CSE.Len; // containing "PEP" is found, which indicates enddo; // the program entry point for the Trigger Pgm. //================================================ // Look for the next non-blank procedure name. // This will be the procedure which issued the file action. // OS functions operate in the *DFTACTGRP and therefore have // blank procedure names. //================================================ dou CSE.PNOS <> 0; // Entry has Procedure Name - Exit CSEP += CSE.Len; // Move to next Entry enddo; // No Procedure Name indicates OS Function //================================================ Program = ProgName; //================================================ if %scan(ProgLib:Libs:1) <> 0; return '1'; else; return '0'; endif; //================================================ on-error; ERR03(); endmon; //============================================================= /end-free p UTLSRV@001A e *=============================================================== * Check if CSE is a PEP <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< *=============================================================== p PEPEnt b d PEPEnt pi n *===================================================== /free //=================================================== monitor; //================================================ if CSE.PNOS = 0; // Procedure Name Offset (PNOS) = 0 if no Procedure Name return '0'; endif; //================================================ PP = CSEP + CSE.PNOS; Procedure = %subst(PN:1:CSE.PNLen); //================================================ if %scan('PEP':Procedure) <> 0; // Check Procedure Name for "PEP" return '1'; // "PEP" = Program Entry Point else; return '0'; // Not "PEP' endif; //================================================ on-error; ERR03(); endmon; //=================================================== /end-free p PEPEnt e *===============================================================