/* REXX ------------------------------------------------------$$PROLOG*/ /* Program Name: OPSFUNCQ */ /* Description: QA test routine for OPSFUNC() external function. */ /* Customization: Change 0 to 1 to run tests as desired. */ /* Input Parameters: None */ /* Invokes: OPSFUNC(), of course. */ /* Base Release: CA-OPS/MVS 4.4 */ /* Restrictions: None */ /* Dependencies: None */ /* Change log: Add new entries to the top */ /*-----------------Changed 28-MAY-2003 by: Bob Stark -----------------*/ /* 1. Initial coding */ /*--------------------------------------------------------------------*/ /* Copyright (C) 2003 ProTech Professional Technical Services. */ /*--------------------------------------------------------------------*/ CALL ON ERROR NAME RXERROR SIGNAL ON SYNTAX NAME RXERROR SIGNAL ON NOVALUE NAME RXERROR TRACE N IF 0 THEN DO; SAY 'Testing OPSCPF()...' rc = OPSFUNC('OPSCPF','I') SAY 'OPSFUNC() rc='rc', Stack contains' QUEUED() 'lines' DO i = 1 TO QUEUED() PARSE PULL line SAY i line END i END IF 0 THEN DO; SAY 'Testing OPSDEV()...' rc = OPSFUNC('OPSDEV', 'V', 'S%S*', 'O') /* Online volumes */ SAY 'OPSFUNC() rc='rc', Stack contains' QUEUED() 'lines' DO i = 1 TO QUEUED() PARSE PULL line SAY i line END i END IF 0 THEN DO; SAY 'Testing OPSINFO()...' rc = OPSFUNC('OPSINFO','SMFID') SAY 'OPSFUNC() rc='rc', Stack contains' QUEUED() 'lines' DO i = 1 TO QUEUED() PARSE PULL line SAY i line END i END IF 1 THEN DO; SAY 'Testing OPSTATUS()...' rc = OPSFUNC('OPSTATUS', 'A','I','*') /* List all addr spaces */ SAY 'OPSFUNC() rc='rc', Stack contains' QUEUED() 'lines' DO i = 1 TO QUEUED() PARSE PULL line SAY i line END i END EXIT: IF SYMBOL('max_rc') = 'LIT' THEN max_rc = 0 EXIT max_rc /*--------------------------------------------------------------------*/ /* RXCOPY routines follow (in alphabetical order) */ /*--------------------------------------------------------------------*/ /*RXCOPY RXERROR NODUP 129 LINES COPIED ON 05-28-03 AT 15:11***********/ /*START OF RXERROR--------------------------------------Version-01.07-*/ /*:RXERROR SUBROUTINE: Generic REXX error condition handler. This */ /* routine gets control when a condition is raised, and: */ /* a. Validates that the condition is ok, and returns quietly, or */ /* b. Issues diagnostic messages about the error & where it occured. */ /* */ /* To use this routine, code the following near the top of your exec: */ /* CALL ON ERROR NAME RXERROR */ /* SIGNAL ON SYNTAX NAME RXERROR */ /* SIGNAL ON NOVALUE NAME RXERROR */ /* */ /* In addition, set the variable 'ok' to any return code values */ /* that are acceptable for host commands. For example: */ /* */ /* ok=4; ADDRESS TSO 'GETVARL GLOBAL_*'; DROP ok */ /* ok='4 8';"host cmd"; DROP ok <-- return codes 4 or 8 are ok */ /* ok='all';"host cmd"; DROP ok <-- all return codes are acceptable */ /* */ /* The first example permits GETVARL to get rc 4 and not fail or */ /* issue any error messages. Note that "ok=0" is always implied */ /* because the REXX ERROR condition is not raised if rc=0. */ /*------------------------------------------------------------------- */ /*NOTES: This subroutine does not use the PROCEDURE instruction, so */ /* variable names used within it must be _hidden. */ /* */ /* If an error occurs that's not one of the 'OK' values, */ /* execution will fall thru this subroutine and any statements */ /* following it will be executed. This is a good place to put */ /* cleanup logic, or a signal to your "cleanup-and-exit" label. */ /* */ /* Variables _RXERRORMSG1 and _RXERRORMSG2 are created when */ /* RXERROR falls thru, and may be used to send error msgs to */ /* other destinations, such as a GUI MSGBOX or ADDRESS AXC WTXC.*/ /* */ /* As a side effect, RXERROR sets ISPF "CONTROL ERRORS RETURN". */ /* If your routine doesn't run this way, you'll need to restore */ /* your ISPF CONTROL ERRORS setting. */ /* Copyright (C) 1996,2003 ProTech. All rights reserved. */ /*--------------------------------------------------------------------*/ RXERROR: TRACE N /* Turn off tracing for this func. */ _sigl = sigl RXERROR1: TRACE N /* Turn off tracing for this func. */ CALL OFF ERROR SIGNAL OFF SYNTAX IF SYMBOL('rc') = 'VAR' THEN _rc = rc ELSE _rc = 'n/a' PARSE SOURCE _EX_ENV . _EX_NAME . . . . _EX_ADDRSPC . IF POS(CONDITION('C'),'ERROR FAILURE') > 0 THEN /* Error or Failure? */ /* Yes. Were we CALLed? */ IF CONDITION('I') = 'CALL' | _EX_ENV = 'OPS/REXX' THEN IF SYMBOL('OK') = 'VAR' THEN /* Yes. Is OK a variable? */ IF WORDPOS(_rc,ok)>0 | TRANSLATE(ok)='ALL' THEN /* Is error ok? */ DO /* Yes, return */ CALL ON ERROR NAME RXERROR /* Restore the */ SIGNAL ON SYNTAX NAME RXERROR /* Error handler */ DROP ZERRLM /* Toss any ISPF error msg */ rc = _rc /* Restore orig RC for caller */ RETURN /* Return to point of error */ END IF SYMBOL('_errtext') = 'LIT' THEN _errtext = ''; /* Initialize error text */ IF CONDITION('C') = 'SYNTAX' THEN /* If a REXX syntax error, */ IF _rc >= 0 & _rc < 100 /* and rc is within valid range, */ THEN _errtext = ' ('ERRORTEXT(_rc)')';/* then get REXX error text. */ ELSE NOP; ELSE IF CONDITION('C') = 'NOVALUE' THEN /* See if undefined variable */ DO; _errtext = ' (No value for variable 'CONDITION('D')')'; _rc = 'n/a'; /* RC not set for NOVALUE */ END ELSE IF POS(CONDITION('C'),'ERROR FAILURE') > 0 THEN /*Hostcmd problem?*/ DO /* Extract host cmd name... */ _cmd = STRIP(STRIP(WORD(CONDITION('D'),1),'B','"'),'B',"'") _errtext = ' (Host command '_cmd')' _addr = ADDRESS() /* Find environment of failing cmd */ IF _sigl <= SOURCELINE() THEN/* Is source code avail? */ IF TRANSLATE(WORD(SOURCELINE(_sigl),1)) = 'ADDRESS' THEN _addr = TRANSLATE(WORD(SOURCELINE(_sigl),2)) _addr = STRIP(TRANSLATE(_addr,,'!@#$%&*()_-+=;:,./?"'"'",' ')) IF _addr = 'PPQ' & SYMBOL('PPQ.ERROR') = 'VAR' THEN _errtext = ' (Host command PPQ, 'ppq.error')' IF _addr = 'VOX' & SYMBOL('VOX.ERROR') = 'VAR' THEN _errtext = ' (Host command VOX, 'vox.error')' IF _addr = 'ASODDE' | SYMBOL('ASODDE.ERROR') = 'VAR' THEN _errtext = ' (Host command ASODDE, 'asodde.error')' IF SYMBOL('SQLCODE') = 'VAR' THEN _errtext = ' ( SQLCODE=' sqlcode')' END ELSE IF CONDITION('C') <> '' THEN _errtext = ' (Condition='CONDITION('C')', Description=', CONDITION('D')')' _rxerrormsg1 = "RXERROR Error RC "_rc""_errtext" at line "_sigl, "in EXEC" _ex_name IF _sigl <= SOURCELINE() /* Is source code avail? */ THEN _rxerrormsg2 = "RXERROR Line "_sigl": "STRIP(SOURCELINE(_sigl)) ELSE _rxerrormsg2 = "" IF _ex_addrspc = 'ISPF' THEN /* Running under ISPF? */ DO /* Yes, issue short & long msgs... */ ADDRESS ISPEXEC "CONTROL ERRORS RETURN" /* Capture all ISPF RCs */ zedsmsg = '' /* Format ISPF short message */ zedlmsg = "Error RC "_rc""_errtext" at line "_sigl" in EXEC" _ex_name IF _sigl <= SOURCELINE() /* Is source code avail? */ THEN zedlmsg = LEFT(zedlmsg': ',78)STRIP(SOURCELINE(_sigl)) IF SYMBOL('ZERRLM') = 'VAR' THEN zedlmsg = LEFT(zedlmsg,156) 'ISPF Error: 'STRIP(ZERRLM) ADDRESS ISPEXEC "SETMSG MSG(ISRZ001)" IF rc = 12 THEN /* ISPMLIB MESSAGE found? */ DO /* No, use SAY instead. */ SAY 'RXERROR ISPMLIB Message ISRZ001 Not Found' SIGNAL _SAY_ERRMSG; END SIGNAL _SAY_SQLMSG; END _SAY_ERRMSG: SAY _rxerrormsg1; IF _rxerrormsg2 <> '' THEN SAY _rxerrormsg2; SAY '' _SAY_SQLMSG: IF SYMBOL('SQLCODE') = 'VAR' & QUEUED() > 0 THEN IF WORDPOS(sqlcode,'0 100') = 0 THEN DO _i = 1 BY 1 WHILE QUEUED() > 0 PULL _stack SAY 'SQL STACK:'RIGHT(_i,2)':'_stack END /*END OF RXERROR------------------------------------------------------*/ max_rc = 12 SIGNAL EXIT