/* REXX ------------------------------------------------------$$PROLOG*/ /* Program Name: OPSALLOC */ /* Description: External function to allocate required OPS/MVS */ /* DDNAMES when running in OMVS (USS) environment */ /* Customization: Related function OPSALLOC must be customized */ /* Input Parameters: DDNAME(SYSEXEC) */ /* Invocation: From OPSADDR() function. */ /* Invokes: None. */ /* Returns: return code, optional lines to stack. */ /* Related Routines: OPSADDR */ /* Base Release: CA-OPS/MVS 4.4 */ /* Restrictions: None. */ /* Dependencies: 1. Must be on the UNIX PATH if called from USS. */ /* 2. OPS/MVS commands must be accessable to UNIX. */ /* 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. No war-*/ /*--------------------------------------------------------------------*/ TRACE N SIGNAL ON ERROR NAME RXERROR SIGNAL ON HALT NAME RXERROR SIGNAL ON SYNTAX NAME RXERROR SIGNAL ON NOVALUE NAME RXERROR ddname = '' debug = '' rc = KWPARSE(ARG(1),'DDNAME DEBUG') IF rc <> 0 THEN CALL ERRMSGX 'KWparse() failed, rc='rc rc = 0 IF ddname <> '' THEN SELECT /* CUSTOMISE HERE!!! (Replace with your datasets...) */ WHEN ddname = 'SYSEXEC' THEN DO IF 0 THEN DO /* Old test code left behind to show what did NOT work... */ SAY "OPSDYNAM('INFO DD(SYSEXEC)')="OPSDYNAM('INFO DD(SYSEXEC)', 'CMDRESP(REXX) ') SAY OPSIFCD '= SVC99 INFO CODE' SAY OPSERCD '= SVC99 ERROR CODE' SAY OPSDD '= DDNAME' SAY OPSDSN '= DSNAME' SAY OPSDSORG '= DSORG (INFO request)' /* This approach just didn't work - never allocated anything */ rc=OPSDYNAM("ALLOC DD(SYSEXEC)", "DSN('BSTARK.CLIST', 'SYS2.OPSD.REXX') SHR") SAY OPSIFCD '= SVC99 INFO CODE' END rc = BPXWDYN("ALLOC FI(SYSEXEC) SHR MSG(2)", "DSN(BSTARK.CLIST) REUSE") IF BPXWDYN("ALLOC FI(TMP) DA(SYS2.OPSD.REXX) SHR MSG(2) REUSE")=0 THEN CALL BPXWDYN "CONCAT DDLIST(SYSEXEC,TMP) MSG(2)" IF rc <> 0 THEN DO; SAY 'BPXWDYN() ALLOC FAILED, rc='rc; SIGNAL EXIT; END END OTHERWISE CALL ERRMSGX 'DDNAME('ddname') not supported.' END IF rc <> 0 THEN CALL ERRMSGX 'OPSDYNAM() RC='rc EXIT: IF SYMBOL('maxrc') <> 'VAR' THEN maxrc = 0 RETURN maxrc /*--------------------------------------------------------------------*/ /* RXCOPY routines follow (in alphabetical order) */ /*--------------------------------------------------------------------*/ /*RXCOPY ERRMSGX NODUP 27 LINES COPIED ON 05-28-03 AT 12:38************/ /*-Start of ERRMSGX function----------------------------Version-01.04-*/ /*:ERRMSGX SUBROUTINE: Issues a formatted error message and exits. */ /* Parameters: Message text */ /* DOES NOT RETURN! */ /* For example: */ /* IF missing <> '' */ /* then call ERRMSGX('Missing required parameter(s):'missing) */ /* Copyright (C) 1996,2003 ProTech. All rights reserved. */ /*--------------------------------------------------------------------*/ ERRMSGX: TRACE N PARSE ARG _errmsgx_text PARSE SOURCE . . _errmsgx_filename . _errmsgx_errtext = 'REXX Error: '_errmsgx_filename' '_errmsgx_text SAY _errmsgx_errtext IF ADDRESS() = 'AXC' THEN DO ADDRESS AXC "WTXC '"_errmsgx_errtext"'" ADDRESS AXC "WTOH '"_errmsgx_errtext"'" END IF SYMBOL('max_rc') = 'LIT' /* Does max_rc variable exist? */ THEN max_rc = 8 /* No, initialize it to 8. */ ELSE IF DATATYPE(max_rc) = 'NUM' /* Yes, is it numeric? */ THEN max_rc = MAX(8,max_rc) /* Yes, bump it up to 8 */ SIGNAL EXIT /*-End of ERRMSGX function-------------------------------------------*/ /*RXCOPY KWPARSE NODUP 128 LINES COPIED ON 05-28-03 AT 12:38***********/ /*Start of KWPARSE Function-----------------------------Version-01.03-*/ /*:KWPARSE Subroutine: Extracts keyword parameters from the data */ /* passed to it, and sets the value of the keyword into REXX */ /* variables that match the keyword name. KWPARSE supports two */ /* methods of defining allowable keywords: */ /* 1. Define keywords as rexx variables before calling KWPARSE, and */ /* leave off the 2nd positional parm. */ /* 2. List the keywords by name in the 2nd positional parm. This */ /* method is preferable if you have other active rexx variables */ /* might get mistaken for parms and reset, or if you want to */ /* support abbreviated keywords. */ /* Returns: 0: Data parsed successfully. */ /* text: Error occured, text gives the details. */ /* For example: */ /* PARSE ARG parms <* Copy callers arguments to rexx var */ /* parms = "MSG('Hello world') DEBUG SELFTEST" */ /* msg = 'Test message' <* Define 'MSG' keyword default */ /* selftest = '' <* Define 'SELFTEST' keycode */ /* debug = '' <* Define 'DEBUG' keycode */ /* CALL kwparse(parms) <* Call KWPARSE w/ imlicit kw defn. */ /* */ /* CALL kwparse(parms,'MSG SELFTEST DEBUG' <*w/ exlicit kw defn. */ /* */ /* Usage Notes: */ /* o Keycode variables that have been parsed will be set to their */ /* own names. To test for their presence, check for non-null, ie: */ /* IF DEBUG <> '' THEN TRACE R */ /* o Invalid keywords are warned with a msg, ignored, and retcode = 4 */ /* o Some invalid input isn't detectible, e.g. a keyword w/o parens */ /* is treated as a keycode, and visa versa. */ /* o If you specify a keyword list (2nd positional parm), then */ /* keywords may be abbreviated, if the abbreviation is unique. */ /* Copyright (C) 1995,2003 ProTech. All rights reserved. */ /*--------------------------------------------------------------------*/ KWPARSE: TRACE Normal /* Turn off rexx tracing */ PARSE arg _parm /* Copy calling arguments */ PARSE version _rxlang _rxversion . IF _rxlang='REXX370' & _rxversion<3.52 /* Is diadic VALUE() avail? */ THEN _dvalue = 0 /* No, have to interpret */ ELSE _dvalue = 1 /* Yes, remember to use it. */ _kwparse_maxrc = '' /* Initialize return code */ DO _i = 1 TO 2 /* 2 passes, most specific to */ /* least, starting w/ quoted data */ /*------------------------------------------------------------------*/ /* Keyword extraction logic: Extract all keyword parameters, */ /* eliminating them and their data from _PARM as each one is */ /* found. REVERSE is used to make the last word of _PARML (the */ /* keyword) into the first word, because parse can be used to */ /* extract the first word from a string, but there is no REXX */ /* function to extract the last word from a string. */ /*------------------------------------------------------------------*/ DO WHILE _parm <> '' /* Done if we run out of input */ SELECT WHEN _i = 1 THEN PARSE VAR _parm, _parml "('" +0 _delim +2 _value "')" _parmr WHEN _i = 2 THEN PARSE VAR _parm, _parml "(" +0 _delim +1 _value ")" _parmr END /* SELECT */ IF _delim = '' THEN LEAVE /* No keywords left, we're done */ PARSE VALUE REVERSE(_parml) WITH _kw _parml /* get keyword */ _kw = TRANSLATE(REVERSE(_kw)) /* Un-reverse & upcase the keyword */ _parm = REVERSE(_parml)_parmr /* Glue remaining parms together */ IF KWPARSE_KWVALID(ARG(2)) <> '' THEN /* Keyword valid? */ IF _dvalue /* Diadic VALUE() available? */ THEN _value = VALUE(_kw,_value) /* Yes, use it. */ ELSE INTERPRET _kw" = VALUE('_value')" /* No, use interpret. */ END /* DO WHILE _parm <> '' */ END /* DO _i = 1 to 2 */ /* Final pass extracts one-word "Keycodes", like DEBUG */ DROP _value DO WHILE _parm <> '' PARSE UPPER VAR _parm _kw _parm /* Extract one "keycode" */ IF KWPARSE_KWVALID(ARG(2)) <> '' THEN /* Keyword valid? */ IF _dvalue /* Diadic VALUE() available? */ THEN CALL VALUE _kw,_kw /* Yes, use enhanced value */ ELSE INTERPRET _kw" = VALUE('_kw')" /* No, use interpret. */ END /* DO WHILE _parm <> '' */ DROP _parm _parml _parmr _delim _i _j _kw _value _rxlang, _rxversion _dvalue _kwfull IF _kwparse_maxrc = '' THEN _kwparse_maxrc = 0 return _kwparse_maxrc KWPARSE_KWVALID: IF ARG(1) <> '' THEN /* Keyword list passed by caller? */ DO /* Yes, use it to determine kw name*/ IF WORDPOS(_kw,TRANSLATE(ARG(1)))=0 THEN /* KW not in list? */ DO /* No. Look for abbrev. */ _kwfull='' /* See if keywd is a unique abbreviation in list */ DO _j = 1 to WORDS(ARG(1)) /* Look at each keyword in list */ IF ABBREV(TRANSLATE(WORD(ARG(1),_j)),_kw) /* Abbrev?*/ THEN _kwfull=_kwfull TRANSLATE(WORD(ARG(1),_j)) /* Yes. */ END _j IF WORDS(_kwfull) = 1 /* Unique keyword found, Replace */ THEN _kw = STRIP(_kwfull) /* abbrev w/ full, and fall thru. */ ELSE DO IF WORDS(_kwfull) > 1 THEN /* Found, but not unique. Sorry. */ IF SYMBOL('_value') = 'VAR' THEN _kwparse_maxrc = _kwparse_maxrc, 'Ignoring ambiguous keyword:'_kw'('_value'),', 'could be any one of '_kwfull';' ELSE _kwparse_maxrc = _kwparse_maxrc, 'Ignoring ambiguous keycode:'_kw',', 'could be any one of '_kwfull';' ELSE IF SYMBOL('_value') = 'VAR' THEN _kwparse_maxrc = _kwparse_maxrc, 'Ignoring unrecognized keyword:'_kw'('_value');' ELSE _kwparse_maxrc = _kwparse_maxrc, 'Ignoring unrecognized keycode:'_kw';' RETURN '' /* Get next parm */ END END END ELSE /* No explicit keyword list, */ IF symbol(_kw) <> 'VAR' THEN /* see if keyword is a rexx var. */ DO IF SYMBOL('_value') = 'VAR' THEN _kwparse_maxrc = _kwparse_maxrc, 'Ignoring unrecognized keyword:'_kw'('_value');' ELSE _kwparse_maxrc = _kwparse_maxrc, 'Ignoring unrecognized keycode:'_kw';' RETURN '' /* Get next parm */ END RETURN _kw /*End of KWPARSE function---------------------------------------------*/ /*RXCOPY RXERROR NODUP 129 LINES COPIED ON 05-28-03 AT 12:38***********/ /*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------------------------------------------------------*/ maxrc = 'RXERROR 'CONDITION('C') IF ARG(1) = 'RECURSE' /* Store data where OPS can get it.*/ THEN CALL OPSSETV 'GLVJOBID.OPSPULL ('result')' PARSE SOURCE env . IF env = 'OPS/REXX' THEN IF OPSGETV('GLVJOBID.OPSPULL') = 'RXERROR HALT' THEN DO SIGNAL OFF SYNTAX SAY "INTENTIONAL SYNTAX ERROR TO PROPAGATE HALT:" 1/0 END SIGNAL EXIT