identification division. program-id. ETPETRN. author. Heirloom Computing Inc. ****************************************************************** * Copyright (C) 2010-2013 Heirloom Computing Inc * * * * ALL RIGHTS RESERVED * ****************************************************************** * * * Property of Heirloom Computing Inc. This software contains * * confidential and proprietary information of Heirloom Computing * * Inc. and is made available solely pursuant to the terms of a * * software license agreement, which governs its use. * * * * No disclosure, reproduction or use of any portion of these * * materials may be made without the express written consent of * * Heirloom Computing Inc. * * * ****************************************************************** * ETPETRN - a non-BMS transaction to be LINKed to from ELPL * a non-BMS transaction (application transaction) that * modifies the COMMAREA and returns * special incoming (space-separated) commarea commands: * 'INSERT' - insert the time-of-day into a table T * 'SYNC' - issue EXEC CICS SYNC following the insert * 'COMMIT' - issue EXEC SQL COMMIT * 'PROG ETPETRN' - recursively EXEC LINK PROGRAM(ETPETRN), return via RETURN * 'TRAN ETRN' - recursively EXEC LINK TRAN('ETRN'), return via EXEC RETURN * 'CALL ETPETRN' - recursively CALL ETPETRN, return via GOBACK * 'GOBACK' - GOBACK from an EXEC LINK instead of EXEC RETURN * 'RETURN' - EXEC RETURN from a CALL instead of GOBACK * 'ABEND' - issue EXEC CICS ABEND * 'COUNT' - increment count (and print) a working-storage variable * 'INIT' - issue the COBOL INITIALIZE on that ws variable * example: 'CALL ETPETRN TRAN ETRN INSERT GOBACK COMMIT' * call ETPETRN via COBOL 'call' statement, which will process * the remaining command 'TRAN ETRN INSERT GOBACK COMMIT' which * will execute TRAN ETRN, which executes INSERT, GOBACK, COMMIT * note: journal1 must be set up to log info * note: PROG, TRAN, CALL pass the COMMAREA, stripped of the current * command, as the new COMMAREA or USING parameter. * note: COUNT and INITIALIZE are often used while testing multiple * invocations with PROG, TRAN, CALL and with ETP "reinitialize * on link" setting to see how WS vars are reset or not. environment division. data division. working-storage section. COPY DFHAID. 01 ws-program-name pic x(8) value 'ETPETRN'. 01 ws-cwa-ptr pointer. 01 ws-commarea. 03 ws-parms pic x(100). 01 ws-info-msg pic x(100). 01 ws-time pic 9(6). 01 ws-len pic 9(9). 01 ws-trandate pic Z(6). 01 ws-trantime pic Z(6). 01 WS-RESPONSE PIC S9(9) COMP. 01 WS-RESPONSEX PIC S9(9). 01 WS-SQLCODE PIC S9(9). 01 ws-recurse PIC X(100). 01 ws-next-tran PIC X(4). 01 ws-next-prog PIC X(8). 01 ws-return-how PIC X(1). 88 via-exit VALUE '00'. 88 via-exec-return VALUE '01'. 88 via-goback VALUE '02'. 01 ws-i PIC S9(9) COMP. 01 ws-char PIC X. 01 ws-mem-leak-test. 02 POI-CQPOIN01. 03 POI-IPOINT POINTER. 01 ws-count PIC S9(4) COMP VALUE 0. 01 ws-count-disp PIC S9(4). 01 result-code pic s9(5) comp. 01 m-err pic x(100). EXEC SQL INCLUDE SQLCA END-EXEC. linkage section. 01 dfhcommarea. 03 pic x occurs 0 to 32700 times depending on eibcalen. ***--------------------------------------------------------------* *** ETRN Stuff * ***--------------------------------------------------------------* procedure division. main-para. * this is an application transaction, no BMS map * it should be invoked with * EXEC CICS LINK TRANSID('ETRN') COMMAREA(myca) END-EXEC * print the comm area and modify it perform cics-mainline. * return to the caller exec cics return commarea(ws-commarea) end-exec stop run . ***--------------------------------------------------------------* cics-mainline section. cics-mainline-para. move eibcalen to ws-len. move spaces to ws-info-msg string "ETRN COMMAREA LENGTH:" ws-len into ws-info-msg. exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec if eibcalen <= length of ws-commarea and eibcalen >= 0 move spaces to ws-commarea move dfhcommarea(1:eibcalen) to ws-commarea move spaces to ws-info-msg string "ETRN COMMAREA:" ws-commarea into ws-info-msg exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec end-if * by default we will simply exit (neither GOBACK nor EXEC CICS RETURN) set via-exit to true. move spaces to ws-next-tran. move spaces to ws-next-prog. move eibdate to ws-trandate. move eibtime to ws-trantime. move spaces to ws-info-msg. string "ETRN EIBDATE " ws-trandate " AND EIBTIME " ws-trantime into ws-info-msg. exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec * only do work if we received a COMMAREA as a (short) parameter if eibcalen <= length of ws-commarea and eibcalen >= 30 move spaces to ws-commarea move dfhcommarea(1:eibcalen) to ws-commarea * * try to create a memory leak if COMMAREA is 'POINTER' if ws-commarea(1:7) = 'POINTER' then * strip off POINTER so same context can EXEC or CALL compute ws-len = ws-len - 8 string ws-commarea(9:ws-len) into ws-recurse move ws-recurse to ws-commarea * this assigns a WS pointer, #1803 concerns LS ptr set POI-IPOINT to address of dfhcommarea move spaces to ws-info-msg move "ETRN assigning a POINTER" to ws-info-msg exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec display ws-info-msg on syserr end-if * EXEC cics LINK a TRANsaction recursively! if ws-commarea(1:5) = 'EXEC ' or ws-commarea(1:5) = 'LINK ' or ws-commarea(1:5) = 'TRAN' then * get ready for recursion string ws-commarea(6:4) into ws-next-tran compute ws-len = ws-len - 10 string ws-commarea(11:ws-len) into ws-recurse move ws-recurse to ws-commarea move spaces to ws-info-msg string "ETRN EXEC LINK TRAN(" ws-next-tran ") COMMAREA=" ws-recurse into ws-info-msg exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec display ws-info-msg on syserr exec cics link transid(ws-next-tran) commarea(ws-recurse) length(ws-len) end-exec * by default, a EXEC LINK TRANSID() returns via EXEC RETURN set via-exec-return to true * exec cics link a PROGram program recursively! else if ws-commarea(1:5) = 'PROG ' then * get ready for recursion string ws-commarea(6:8) delimited by space into ws-next-prog move 'x' to ws-char perform varying ws-i from 6 by 1 until ws-char = space move ws-commarea(ws-i:1) to ws-char end-perform compute ws-len = ws-len - ws-i string ws-commarea(ws-i:ws-len) into ws-recurse move ws-recurse to ws-commarea move spaces to ws-info-msg string "ETRN EXEC LINK PROG(" ws-next-prog ") COMMAREA=" ws-recurse into ws-info-msg exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec display ws-info-msg on syserr exec cics link program(ws-next-prog) commarea(ws-recurse) length(ws-len) end-exec * by default, a EXEC LINK PROG() returns via EXEC RETURN set via-exec-return to true * CALL a program recursively! else if ws-commarea(1:5) = 'CALL ' then * get ready for recursion string ws-commarea(6:8) delimited by space into ws-next-prog move 'x' to ws-char perform varying ws-i from 6 by 1 until ws-char = space move ws-commarea(ws-i:1) to ws-char end-perform compute ws-len = ws-len - ws-i string ws-commarea(ws-i:ws-len) into ws-recurse move ws-recurse to ws-commarea move spaces to ws-info-msg string "ETRN CALL '" ws-next-prog "' USING COMMAREA=" ws-recurse into ws-info-msg exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec display ws-info-msg on syserr * make the call with the *real* commarea and eiblk as parms * (this may be an issue in #1803) move ws-recurse(1:ws-len) to dfhcommarea(1:ws-len) move ws-len to eibcalen call ws-next-prog using dfheiblk dfhcommarea * by default, a CALL returns via GOBACK set via-goback to true end-if end-if end-if * * ABEND if incoming COMMAREA is 'ABEND' if ws-commarea(1:5) = 'ABEND' move spaces to ws-info-msg move "ETRN is being asked to ABEND" to ws-info-msg exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec display ws-info-msg on syserr exec cics ABEND ABCODE('DEAD') end-exec end-if * * INIT if incoming COMMAREA is 'INIT' if ws-commarea(1:4) = 'INIT' compute ws-len = ws-len - 5 string ws-commarea(6:ws-len) into ws-recurse move ws-recurse to ws-commarea initialize ws-count move spaces to ws-info-msg move ws-count to ws-count-disp string "ETRN INTIALIZED COUNTER '" ws-count-disp "'" into ws-info-msg exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec display ws-info-msg on syserr end-if * * COUNT if incoming COMMAREA is 'COUNT' if ws-commarea(1:5) = 'COUNT' compute ws-len = ws-len - 6 string ws-commarea(7:ws-len) into ws-recurse move ws-recurse to ws-commarea compute ws-count = ws-count + 1 move spaces to ws-info-msg move ws-count to ws-count-disp string "ETRN incremented COUNT '" ws-count-disp "'" into ws-info-msg exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec display ws-info-msg on syserr end-if * carry out an insert if COMMAREA is 'INSERT' if ws-commarea(1:6) = 'INSERT' compute ws-len = ws-len - 8 string ws-commarea(9:ws-len) into ws-recurse move ws-recurse to ws-commarea move eibtime to ws-time move spaces to ws-info-msg string "ETRN is doing a SQL insert " ws-time into ws-info-msg exec cics write journalname('journal1') from (ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec display ws-info-msg on syserr * assume table 't' exists with 1 char(n) column exec sql insert into t values(:ws-time) end-exec if sqlcode not = 0 then display "SQL Error: " SQLERRMC on syserr end-if end-if * carry out an CICS SYNC if COMMAREA is 'SYNC' if ws-commarea(1:4) = 'SYNC' compute ws-len = ws-len - 6 string ws-commarea(7:ws-len) into ws-recurse move ws-recurse to ws-commarea exec cics syncpoint resp(ws-response) end-exec move ws-response to ws-responsex move spaces to ws-info-msg string "ETRN did a CICS SYNCPOINT, RESP:" WS-RESPONSEX into ws-info-msg exec cics write journalname('journal1') from (ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec display ws-info-msg on syserr end-if * carry out an SQL COMMIT if COMMAREA is 'COMMIT' if ws-commarea(1:6) = 'COMMIT' compute ws-len = ws-len - 8 string ws-commarea(9:ws-len) into ws-recurse move ws-recurse to ws-commarea exec sql commit work end-exec move SQLCODE to WS-SQLCODE move spaces to ws-info-msg string "ETRN did a SQL COMMIT, SQLCODE:" WS-SQLCODE into ws-info-msg exec cics write journalname('journal1') from (ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec display ws-info-msg on syserr end-if * decide how to return - via EXEC CICS RETURN if ws-commarea(1:6) = 'RETURN' compute ws-len = ws-len - 8 string ws-commarea(9:ws-len) into ws-recurse move ws-recurse to ws-commarea set via-exec-return to true end-if * decide how to return - via GO BACK if ws-commarea(1:6) = 'GOBACK' compute ws-len = ws-len - 8 string ws-commarea(9:ws-len) into ws-recurse move ws-recurse to ws-commarea set via-goback to true end-if * return current date in commarea of length 80 move spaces to ws-commarea move ws-count to ws-count-disp string "The current time is " current-time " (EIBTIME " ws-trantime ", COUNT " ws-count-disp ")" into ws-commarea * copy up to the number of bytes supplied in the orig * commarea but not more than the 80 if eibcalen > 100 move 100 to eibcalen end-if move ws-commarea(1:eibcalen) to dfhcommarea(1:eibcalen) else move spaces to ws-info-msg move "ETRN: Supply COMMAREA >30 and <100 bytes." to ws-info-msg exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec end-if move eibcalen to ws-len move spaces to ws-info-msg string "ETRN RETURNING COMMAREA LENGTH:" ws-len into ws-info-msg. exec cics write journalname('journal1') from(ws-info-msg) flength(80) jtypeid('RC') prefix('ETP') end-exec move spaces to ws-info-msg string "ETRN RETURNING COMMAREA:" ws-commarea into ws-info-msg. exec cics write journalname('journal1') from(ws-info-msg) flength(82) jtypeid('RC') prefix('ETP') end-exec * return according to the specification if via-exec-return then exec cics return end-exec end-if if via-goback then goback end-if. * neither -- simply exit exit. end-program.