/*---------Language: REXX-------------------------------------$$PROLOG*/ /* Program Name: OPS */ /* Description: Setup and launch the OPS/MVS SYSVIEW ISPF program*/ /* This program performs ALLOC, LIBDEF, etc., then */ /* launches SysView. */ /* Customization: See >>>CUSTOMIZE HERE<<< to set dsnames, etc., */ /* Input Parameters: option Initial OPS/MVS panel number */ /* SYSID(sysid) Default MSF system */ /* SUBSYS(ssid) OPS/MVS subsystem */ /* COMMAND(commandtext) Option 6 MVS command */ /* GLOBAL Copy OPS/MVS SYSCHK1 so a copy */ /* of global variables/tables are */ /* available in option 2.1. */ /* DEBUG Activate debugging */ /* Invocation: From ISPF command line or menu panel. */ /* Invokes: SYSVIEW */ /* Return Codes: 0 - Successful Completion */ /* Related Routines: */ /* Base Release: CA-OPS/MVS 4.5 or higher */ /* Restrictions: None */ /* Dependencies: None */ /*-----------------Changed 09/15/2006 by: Bob Stark --------------1.1-*/ /* 1. Changed to launch opsView instead of SysView */ /*-----------------Changed 03/17/1999 by: Bob Stark --------------1.0-*/ /* 1. Cleanup for distribution version 1.0 */ /*-----------------Changed 01/30/1999 by: Bob Stark ------------------*/ /* Changed by/Date: Bob Stark 01/30/1999 */ /* 1. Initial coding */ /*--------------------------------------------------------------------*/ /* Copyright (C) 1999 ProTech Professional Technical Services. No war-*/ /* ranty expressed or implied. Permission to use, copy, and distribute*/ /* this document without fee is hereby granted, provided that this */ /* copyright notice appear in all copies. Permission to modify the */ /* code is granted, but not the right to distribute the modified code,*/ /* which should be returned to the maintainer for inclusion into the */ /* distributed version. Contacts: 412-373-8855 www.protechpts.com */ /*--------------------------------------------------------------------*/ CALL ON ERROR NAME RXERROR SIGNAL ON SYNTAX NAME RXERROR SIGNAL ON NOVALUE NAME RXERROR SIGNAL ON HALT NAME RXERROR TRACE N userid = STRIP(USERID()) smfid = MVSVAR('SYSSMFID') /* >>>CUSTOMIZE HERE<<< Set the following values to match your DSNAMEs*/ appl = 'OPS ' /* ISPF APPL name. Default: OPS */ debug = '' /* Keycode DEBUG requests tracing. */ sysid = '' /* Default MSF system name. */ subsys = 'OPSS' /* OPS/MVS subsystem name. Def=OPSS*/ command = '' /* Command to issue from SysView 6 */ global = '' /* Keycode GLOBAL requests SYSCHK1 */ prefix = 'SYS2.OPS11.' /* Prefix for following DSNAMEs */ clistlib = prefix'FBCLIST' /* SYSPROC library. */ execlib = prefix'REXX' /* SYSEXEC library. */ opsexec = prefix'OPSEXEC' /* OPSEXEC library. */ plib = prefix'OPSPLIB' /* ISPPLIB library (ISPF panels) */ mlib = prefix'OPSMLIB' /* ISPMLIB library (ISPF messages) */ tlib = prefix'OPSTLIB' /* ISPTLIB library (ISPF tables) */ slib = prefix'OPSSLIB' /* ISPSLIB library (ISPF Skeletons)*/ ispflock = plib /* Used to determine if active. */ opssyschk = 'SYS2.OPSPROD.'smfid'.SYSCHK1' /* OPS/MVS SYSCHK1 DSNAME */ usrsyschk = userid'.OPS.SYSCHK1' /* Private copy of OPS SYSCHK1. */ /*--------------------------------------------------------------------*/ /* Figure out if the first parm is an OPS/MVS panel number, or if is */ /* just a keyword or keycode to be passed to KWPARSE(). */ /*--------------------------------------------------------------------*/ PARSE ARG option parms IF DATATYPE(LEFT(option,1)) <> 'NUM' & POS('.',option) = 0 THEN DO parms = option parms /* tack it back onto the parms. */ option = '' /* No option */ END rc = KWPARSE(parms) IF rc <> 0 THEN CALL ERRMSGX 'KWPARSE Failed, rc='rc IF debug <> '' THEN TRACE I IF ISPFLMF() <> 'YES' THEN CALL ERRMSGX 'Must run under ISPF' /* ADDRESS ISPEXEC "VGET (ZAPPLID)" IF zapplid <> appl THEN DO PARSE SOURCE . . execname . ADDRESS ISPEXEC "SELECT CMD("execname") NEWAPPL("appl") PASSLIB" EXIT END */ ADDRESS ISPEXEC "LIBDEF ISPPLIB DATASET ID('"plib"')" IF rc = 0 THEN ISPPLIB = 'YES' panel = 'OPPRIMOP' /* OPS/MVS primary panel */ CALL PROGMSG "PANEL("panel") TEXT(Issuing ISPF LIBDEFs)" ADDRESS ISPEXEC "LIBDEF ISPMLIB DATASET ID('"mlib"')" IF rc = 0 THEN ISPMLIB = 'YES' ADDRESS ISPEXEC "LIBDEF ISPSLIB DATASET ID('"slib"')" IF rc = 0 THEN ISPSLIB = 'YES' ADDRESS ISPEXEC "LIBDEF ISPTLIB DATASET ID('"tlib"')" IF rc = 0 THEN ISPTLIB = 'YES' CALL PROGMSG "PANEL("panel") TEXT(Issuing ALTLIB ACTIVATEs)" ADDRESS TSO "ALTLIB ACTIVATE APPLICATION(CLIST) DATASET('"clistlib"')" IF rc = 0 THEN ALTCLIST = 'YES' ADDRESS TSO "ALTLIB ACTIVATE APPLICATION(EXEC) DATASET('"execlib"')" IF rc = 0 THEN ALTEXEC = 'YES' IF OTHERSPF() = 'NO' THEN DO ADDRESS TSO "ALLOC F(OPSEXEC) DSN('"opsexec"') SHR" END /* IF OTHERSPF() = 'NO' THEN */ /*--------------------------------------------------------------------*/ /* See if we are to copy the OPS/MVS SYSCHK1 dataset. If so, then */ /* do it. The user should only use AOFTEST (Option 2.1) in this */ /* logical screen, so that no other screen tries to open the SYSCHK1 */ /* VSAM dataset for output. */ /*--------------------------------------------------------------------*/ IF global <> '' THEN DO i = 1 TO 1 /* Yes, copy SYSCHK1. Loop is so we can use LEAVE i */ IF i = 1 THEN DO /* See if SYSCHK1 already ALLOC'd */ rc = MDDINFO('SYSCHK1','STEM(DDINFO.)') IF ddinfo.0 > 0 THEN DO SAY 'SYSCHK1 already allocated in another screen' LEAVE i END END /*------------------------------------------------------------------*/ /* Display the primary OPS/MVS panel, with an ISPF message to let */ /* User know that we are working on copying their SYSCHK1. */ /*------------------------------------------------------------------*/ CALL PROGMSG "PANEL("panel")", "TEXT(Copying OPS/MVS SYSCHK1 dataset for private tables & vars)" /* Allocate the OPS SYSCHK1 file */ CALL OUTTRAP 'CMDOUT.' ADDRESS TSO "ALLOC F(OPSYSCHK) DS('"opssyschk"') SHR" CALL OUTTRAP 'OFF' IF rc <> 0 THEN DO /* unable to allocate the OPS file, so we can't copy it */ Say 'Unable to allocate' opssyschk', rc='rc DO j = 1 TO cmdout.0; SAY j cmdout.j; END j LEAVE i END DO j = 1 TO 2 /* Retry loop in case we create it */ /* Allocate the private copy of the SYSCHK1 */ CALL OUTTRAP 'CMDOUT.' ok = 'ALL' ADDRESS TSO "ALLOC F(SYSCHK1) DS('"usrsyschk"') SHR" DROP ok CALL OUTTRAP 'OFF' IF rc = 0 THEN /* Did it work? */ DO /* Yes. */ SYSCHK1 = 'YES' /* Create var to remember to FREE */ LEAVE j /* Allocation worked, we're done */ END IF j > 1 THEN /* Didn't work. Any retries left? */ DO /* No, bail out on SYSCHK1 */ /* unable to allocate the OPS file, so we can't copy it */ Say 'Unable to allocate' usrsyschk', rc='rc DO k = 1 TO cmdout.0; SAY k cmdout.k; END k LEAVE i /* Time to bail out. */ END /* Unable to allocate SYSCHK1. assume that it's because it */ /* doesn't exist. Create a new one, modeled after the OPS one. */ ADDRESS TSO "DEFINE CLUSTER(NAME('"usrsyschk"')", "MODEL('"opssyschk"')", "REUSE", ")", "DATA(NAME('"usrsyschk".DATA'))" IF rc <> 0 THEN DO SAY 'Unable to create' usrsyschk', rc='rc LEAVE i END END j /* copy the OPS SYSCHK1 to the private one */ CALL OUTTRAP 'CMDOUT.' OK = 'ALL' ADDRESS TSO "REPRO INFILE(OPSYSCHK) OUTFILE(SYSCHK1) REPLACE REUSE" DROP ok CALL OUTTRAP 'OFF.' IF rc <> 0 THEN DO SAY 'Copy from 'opssyschk' to 'usrsyschk' failed, rc='rc DO j = 1 TO cmdout.0; SAY j cmdout.j; END j END ADDRESS TSO "FREE FILE(OPSYSCHK)" END i CALL OUTTRAP "CMDOUT." ADDRESS TSO "ALLOC DSNAME('"ispflock"') SHR FILE(OPSCRN"zscreen")" CALL OUTTRAP "OFF" IF rc <> 0 THEN DO SAY "ALLOC DSNAME('"ispflock"') FILE(OPSCRN"zscreen") rc="rc DO i = 1 TO cmdout.0; SAY i cmdout.i; END i END /*--------------------------------------------------------------------*/ /* Build the parms that we're going to pass to SYSVIEW. */ /*--------------------------------------------------------------------*/ sysparms = option IF subsys <> '' THEN sysparms = SUBWORD(sysparms' SUBSYS('subsys')',1) IF sysid <> '' THEN sysparms = SUBWORD(sysparms' SYSID('sysid')',1) IF command <> '' THEN sysparms = SUBWORD(sysparms' SUBSYS('command')',1) ADDRESS TSO "OPSVIEW "sysparms EXIT: ok = 'ALL' panel = '' /* No panel for PROGMSGs now... */ CALL PROGMSG "PANEL("panel") TEXT(Cleaning up OPS/MVS ALLOCs/LIBDEFs)" IF SYMBOL('ZSCREEN') = 'VAR' THEN ADDRESS TSO "FREE FILE(OPSCRN"zscreen")" IF SYMBOL('SYSCHK1') = 'VAR' THEN DO DROP syschk1 CALL OUTTRAP 'CMDOUT.' ADDRESS TSO "FREE FILE(SYSCHK1)" CALL OUTTRAP 'OFF' END IF OTHERSPF() = 'NO' THEN DO CALL OUTTRAP 'CMDOUT.' ADDRESS TSO "FREE FILE(OPSEXEC)" CALL OUTTRAP 'OFF' END IF SYMBOL('ALTEXEC') = 'VAR' THEN DO DROP altexec ADDRESS TSO "ALTLIB DEACTIVATE APPLICATION(EXEC)" END IF SYMBOL('ALTCLIST') = 'VAR' THEN DO DROP altclist ADDRESS TSO "ALTLIB DEACTIVATE APPLICATION(CLIST)" END IF SYMBOL('ISPMLIB') = 'VAR' THEN DO DROP ispmlib ADDRESS ISPEXEC "LIBDEF ISPMLIB" END IF SYMBOL('ISPLLIB') = 'VAR' THEN DO DROP ispplib ADDRESS ISPEXEC "LIBDEF ISPPLIB" END IF SYMBOL('ISPTLIB') = 'VAR' THEN DO DROP isptlib ADDRESS ISPEXEC "LIBDEF ISPTLIB" END IF SYMBOL('ISPSLIB') = 'VAR' THEN DO DROP ispslib ADDRESS ISPEXEC "LIBDEF ISPSLIB" END IF SYMBOL('max_rc') = 'LIT' THEN max_rc = 0 EXIT max_rc /*-Start of PROGMSG function------------------------------------------*/ /*:PROGMSG function: Send an "In progress" message via ISPF. */ /* rc = PROGMSG('PANEL(pnlname) TEXT(text of message)') */ /* Returns: YES or NO */ /*--------------------------------------------------------------------*/ PROGMSG: TRACE N PARSE UPPER ARG 1 'PANEL(' _progpanel ')' PARSE ARG 1 'TEXT(' zedlmsg ')' zedsmsg = '' /* Format ISPF short message */ ADDRESS ISPEXEC "CONTROL DISPLAY LOCK" csr = 'ZCMD' ADDRESS ISPEXEC "DISPLAY PANEL("_progpanel") CURSOR(&CSR) MSG(ISRZ001)" panel = '' /* blank panel name for next msg */ RETURN /*-Start of OTHERSPF function-----------------------------------------*/ /*:OTHERSPF function: Determine if there are other instances of this */ /* ISPF dialog active. */ /* Returns: YES or NO */ /*--------------------------------------------------------------------*/ OTHERSPF: TRACE N /* Get our ISPF screen number */ ADDRESS ISPEXEC "VGET (ZSCREEN)" rc = MDDINFO('OPSCRN*','STEM(DDINFO.)') others = 'NO' DO i = 1 TO ddinfo.0 IF ddinfo.i <> 'OPSCRN'zscreen THEN DO others = 'YES' LEAVE i END END i RETURN others /*--------------------------------------------------------------------*/ /* RXCOPY routines follow (in alphabetical order) */ /*--------------------------------------------------------------------*/ /*RXCOPY ERRMSGX **** 22 LINES COPIED ON 01-30-99 AT 06:07*************/ /*-Start of ERRMSGX function----------------------------Version-01.02-*/ /*: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 Washington Systems. 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 "WTO '"_errmsgx_errtext"'" END SIGNAL EXIT /*-End of ERRMSGX function-------------------------------------------*/ /*RXCOPY GETENV **** 125 LINES COPIED ON 01-30-99 AT 06:07*************/ /*-Start of GETENV subroutine---------------------------Version-01.06-*/ /*:GETENV Subroutine: Determines current ASO product environment. */ /* Returns: ATMCMS CMDCMS ATMREXX ATMTSO MVSTSO OPSREXX OPSTSO */ /* CMDRULE DOMRULE EOMRULE GLVRULE MSGRULE OMGRULE REQRULE SCRRULE */ /* SECRULE TODRULE NETVMVS */ /* AXCOS2 CMDOS2 AXCONT CMDONT AXCWNT CMDWNT AXCW95 CMDW95 */ /* CMDDOS AXCUNIX CMDUNIX RAWUNIX UNKNOWN */ /* Note: All variables used in this routine should be _hidden. */ /* Copyright (C) 1995,1998 Washington Systems. All rights reserved. */ /*--------------------------------------------------------------------*/ GETENV: IF SYMBOL('the_environment')='VAR' /* If we were already called, */ THEN RETURN the_environment /* then just return the same answer*/ TRACE N /* Turn off rexx tracing */ the_environment = 'UNKNOWN' /* Initialize - assume unknown */ PARSE UPPER SOURCE _src +3 . _type . IF _src = 'OPS' THEN DO /* Running in OPS. Assume xxxRULE */ the_environment = OPSINFO('EVENTTYPE')'RULE' IF the_environment = 'NONERULE' /* Not running in a rule? */ THEN the_environment = 'OPSREXX' /* No, return OPSREXX instead */ SIGNAL GETENV_EXIT END IF _src = 'UNI' THEN DO IF ADDRESS() = 'AXC' THEN DO; the_environment = 'AXCUNIX'; SIGNAL GETENV_EXIT; END IF POS(TRANSLATE(ADDRESS()),'UNIX KSH CSH') > 0 THEN DO; the_environment = 'CMDUNIX'; SIGNAL GETENV_EXIT; END IF POS(TRANSLATE(ADDRESS()),'COMMAND') > 0 THEN DO; the_environment = 'RAWUNIX'; SIGNAL GETENV_EXIT; END END IF _src = 'OS/' THEN DO IF ADDRESS() = 'AXC' THEN DO; the_environment = 'AXCOS2'; SIGNAL GETENV_EXIT; END IF POS(TRANSLATE(ADDRESS()),'CMD PMREXX') > 0 THEN DO; the_environment = 'CMDOS2'; SIGNAL GETENV_EXIT; END END IF _src = 'WIN' THEN DO PARSE UPPER SOURCE _src . _src = 'W'RIGHT(_src,2) /* WNT or W95 */ IF ADDRESS() = 'AXC' THEN DO; the_environment = 'AXC'_src; SIGNAL GETENV_EXIT; END IF TRANSLATE(ADDRESS()) = 'CMD' THEN DO; the_environment = 'CMD'_src; SIGNAL GETENV_EXIT; END END IF _src = 'NT ' THEN DO _src = 'ONT' /* OpenREXX Running on NT */ IF ADDRESS() = 'AXC' THEN DO; the_environment = 'AXC'_src; SIGNAL GETENV_EXIT; END IF TRANSLATE(ADDRESS()) = 'CMD' THEN DO; the_environment = 'CMD'_src; SIGNAL GETENV_EXIT; END END IF _src = 'DOS' THEN DO IF TRANSLATE(ADDRESS()) = 'COMMAND' THEN DO; the_environment = 'CMDDOS'; SIGNAL GETENV_EXIT; END END IF _src = 'TSO' THEN DO /* Setup OUTTRAP if possible. */ IF ADDRESS() = 'MVS' /* Running MVS native rexx? */ THEN DO; the_environment = 'ATMREXX'; SIGNAL GETENV_EXIT; END IF ADDRESS() = 'NETVIEW' /* Running inside NetView? */ THEN DO; the_environment = 'NETVMVS'; SIGNAL GETENV_EXIT; END /*------------------------------------------------------------------*/ /* Outtrap is used to determine if OPS or AutoMate is active. If */ /* trap is already active, and we are nested too deeply to see the */ /* variables needed to restore the caller's outtrap, then we can't */ /* run, or we'd mess up the caller. */ /*------------------------------------------------------------------*/ INTERPRET "_savtrap = OUTTRAP()" /* Is outtrap active? */ IF _savtrap = 'OFF' THEN _savtrap = "x = OUTTRAP('OFF')" /*No, build outtrap shutoff cmd*/ ELSE DO INTERPRET "_symbol = SYMBOL('"_savtrap"MAX')" IF _symbol = 'VAR' /* Active, but restore data avail */ THEN _savtrap = "x=OUTTRAP("_savtrap","_savtrap"MAX,"_savtrap"CON)" ELSE DO /* Outtrap restore data not exposed*/ SAY 'GETENV error: OUTTRAP() Active and cannot be used' DROP _savtrap /* Keep exit from restoring outtrap*/ SIGNAL GETENV_EXIT END END /* Turn off TSO error messages (come out if command not found) */ INTERPRET "_msg_status=MSG('OFF')"/* Interpret to hide from OPS/REXX*/ INTERPRET "x = OUTTRAP('_outtrap.',1,'NOCONCAT')" /*Activate outtrap*/ /*------------------------------------------------------------------*/ /* Issue the STATETBL command. In AutoMate, this produces no output */ /* if MSG(OFF), which we need to keep -3 error msgs from coming out.*/ /*------------------------------------------------------------------*/ CALL OFF ERROR /* Keep us from entering RXERROR */ ADDRESS TSO 'STATETBL LIST CMDRESP(TERMINAL)' IF rc < 0 THEN DO; the_environment = 'MVSTSO'; SIGNAL GETENV_EXIT; END IF _outtrap.0 = 1 THEN the_environment = 'OPSTSO' ELSE the_environment = 'ATMTSO' SIGNAL GETENV_EXIT END IF _src = 'CMS' THEN DO ADDRESS CMS 'PIPE COMMAND GETVAR ATMID ATMID | STEM _outtrap.' IF RC <> -3 THEN DO; the_environment = 'ATMCMS'; SIGNAL GETENV_EXIT; END ELSE DO; the_environment = 'CMDCMS'; SIGNAL GETENV_EXIT; END END GETENV_EXIT: IF _src = 'TSO' THEN DO /* Restore callers environment */ IF SYMBOL('_savtrap') = 'VAR' THEN DO INTERPRET _savtrap /* Restore caller's OUTTRAP status */ INTERPRET "CALL MSG _msg_status" /* Restore caller's MSG() status */ END END DROP _src _savtrap _msg_status _outtrap. RETURN the_environment /*-End of GETENV subroutine-----------------------------------------*/ /*RXCOPY ISPFLMF **** 28 LINES COPIED ON 01-30-99 AT 06:07*************/ /*-Start of ISPFLMF function---------------------------Version-01.04-*/ /*:ISPFLMF Subroutine: Determines if ISPF Library Mgmt is available. */ /* Returns: YES or NO */ /* Note 1: This routine calls GETENV, so you must RXCOPY GETENV. */ /* Copyright (C) 1996, 1998 Washington Systems. All rights reserved. */ /*--------------------------------------------------------------------*/ ISPFLMF: PROCEDURE EXPOSE ispflmf_save the_environment gbl. TRACE N /* Turn off rexx tracing */ IF SYMBOL('ispflmf_save')='VAR' /* If we were already called, */ THEN RETURN ispflmf_save /* then just return the same answer*/ ispflmf_save = 'NO' /* Assume LMF not available */ IF POS(GETENV(),'ATMTSO OPSTSO MVSTSO ATMREXX OPSREXX REQRULE') = 0 THEN SIGNAL ISPFLMF_EXIT PARSE SOURCE . . . . . . . _ex_addrspc . IF _ex_addrspc = 'ISPF' THEN SIGNAL ISPFLMF_YES IF _ex_addrspc <> '' THEN SIGNAL ISPFLMF_EXIT /* Null in OPS/REXX */ IF GETENV() = 'OPSREXX' THEN IF LEFT(OPSINFO('VERSION'),5) >= '04.02' THEN INTERPRET "IF OPSINFO('ISPF')='ACTIVE' THEN SIGNAL ISPFLMF_YES;", "ELSE SIGNAL ISPFLMF_EXIT" ok='all'; ADDRESS ISPEXEC "LMINIT DATAID(DUMMY) DDNAME(DUMMY) ENQ(SHR)" IF rc <> 8 THEN SIGNAL ISPFLMF_EXIT ISPFLMF_YES: ispflmf_save = 'YES' ISPFLMF_EXIT: RETURN ispflmf_save /*-End of ISPFLMF function-------------------------------------------*/ /*RXCOPY KWPARSE **** 128 LINES COPIED ON 01-30-99 AT 06:07************/ /*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) 1998 Washington Systems. 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 MDDINFO **** 42 LINES COPIED ON 11-24-98 AT 20:32*************/ /*-Start of MDDINFO function----------------------------Version-01.00-*/ /*:MDDINFO Function: An MVS function to return info on allocated */ /* DD names. Faster than issuing LISTA ST cmd. */ /* Parms: ddn_mask,STEM(stemname) */ /* where: ddn_mask is a specific DDNAME, or a mask. */ /* stemname is a stem variable name. Default is DDINFO. */ /* Returns: 0 if it worked, data in the stemname. variable */ /* Example: asid = MDDINFO('ISP*','STEM(DDINFO.)') */ /* Copyright (C) 1999 Washington Systems. All rights reserved. */ /*--------------------------------------------------------------------*/ MDDINFO: TRACE N PARSE UPPER ARG _mddnmask , 1 'STEM(' _mddstem ')' IF _mddstem = '' THEN _mddstem = 'DDINFO.' /* PSATOLD -> TCB; TCBTIO -> TIOT */ _mddtiot = MSTORAGE('21C?+C','LENGTH(4) TYPE(X)') /* Offset +x'18' to 1st entry */ _mddtioentry = D2X(X2D(_mddtiot)+X2D('18')) PARSE VALUE MSTORAGE(_mddtioentry,'LENGTH(20) TYPE(C)'), WITH 1 _mddtioelngh 2 _mddtioestta 3 5 _mddtioeddnm +8 . _mddtioelngh = C2D(_mddtioelngh) _mddn = 0 DO WHILE _mddtioelngh <> 0 IF BITAND(_mddtioestta,'10000000'b) <> '10000000'b THEN DO /* SAY _mddtioentry _mddtioelngh _mddtioeddnm */ IF _mddtioeddnm <> '' THEN IF PATMATCH(_mddnmask,_mddtioeddnm) = 1 THEN DO _mddn = _mddn + 1 CALL VALUE _mddstem''_mddn,STRIP(_mddtioeddnm) END END _mddtioentry = D2X(X2D(_mddtioentry)+_mddtioelngh) PARSE VALUE MSTORAGE(_mddtioentry,'LENGTH('_mddtioelngh') TYPE(C)'), WITH 1 _mddtioelngh 2 _mddtioestta 3 5 _mddtioeddnm +8 . _mddtioelngh = C2D(_mddtioelngh) END CALL VALUE _mddstem''0,_mddn /* set stem.0 value */ RETURN 0 /*-End of MDDINFO function--------------------------------------------*/ /*RXCOPY MSTORAGE **** 82 LINES COPIED ON 11-24-98 AT 20:32************/ /*-Start of MSTORAGE function---------------------------Version-01.01-*/ /*:MSTORAGE Function: An MVS function to navigate thru MVS control */ /* blocks using pointers, similar to TSO TEST. */ /* Parms: addr_expr, options */ /* where: addr_expr is an address expression similar to TSO test: */ /* e.g. 224? returns the storage pointed to by */ /* the 31 bit pointer at location '00000224'x. */ /* % may be used for 24 bit pointers. */ /* + may be used to specify an offset in hex. */ /* options LENGTH(# bytes to return) */ /* TYPE(C | D | X) */ /* C=Return char data (may be unprintable) */ /* D=Return decimal number data */ /* X=Return printable hex data */ /* Returns: The data from storage. */ /* Example: asid = MSTORAGE('224?+24','LENGTH(2) TYPE(X)') */ /* Copyright (C) 1998 Washington Systems. All rights reserved. */ /*--------------------------------------------------------------------*/ MSTORAGE: TRACE N PARSE ARG _mstexpr , 1 'LENGTH(' _mstlength ')' 1 'TYPE(' _msttype ')' _mstexpr = STRIP(_mstexpr) DO _msti = 1 BY 1 WHILE _mstexpr <> '' /* Break expr down to stem */ IF POS(LEFT(_mstexpr,1),'+?%') = 0 THEN /* Expr start w/ operator? */ DO /* No, look for one inside */ PARSE VAR _mstexpr 1 _msta1 '?' 1 _msta2 '%' 1 _msta3 '+' /* Find the nearest operator. */ _mstopos = MIN(LENGTH(_msta1),LENGTH(_msta2),LENGTH(_msta3)) /* Store lead data in stem, and remove from operator */ _msto._msti = SUBSTR(_mstexpr,1,_mstopos) PARSE VAR _mstexpr (_msto._msti) _mstexpr END ELSE /* Yes, expr does start w/ oper, move it to stem var*/ PARSE VAR _mstexpr 1 _msto._msti 2 _mstexpr END _msti _msto.0 = _msti-1 PARSE SOURCE _EX_ENV . _EX_NAME . . . . _EX_ADDRSPC . DO _msti = 1 TO _msto.0 /* Now evaluate the stem */ SELECT WHEN _msto._msti = '%' THEN DO IF SYMBOL('_mstptr') <> 'VAR' THEN SIGNAL MSTORERR1 _mstptr = C2X(BITAND(RIGHT(X2C(_mstptr),4,'00'x),'00FFFFFF'x)) IF _EX_ENV = 'OPS/REXX' THEN _mstptr = OPSTORE('S',X2C(_mstptr),4) ELSE INTERPRET "ptr = STORAGE(_mstptr,4)" _mstptr = C2X(_mstptr) END WHEN _msto._msti = '?' THEN DO IF SYMBOL('_mstptr') <> 'VAR' THEN SIGNAL MSTORERR1 _mstptr = C2X(BITAND(RIGHT(X2C(_mstptr),4,'00'x),'7FFFFFFF'x)) IF _EX_ENV = 'OPS/REXX' THEN _mstptr = OPSTORE('S',X2C(_mstptr),4) ELSE INTERPRET "_mstptr = STORAGE(_mstptr,4)" _mstptr = C2X(_mstptr) END WHEN _msto._msti = '+' THEN DO IF SYMBOL('_mstptr') <> 'VAR' THEN SIGNAL MSTORERR1 _msti = _msti+1 _mstptr = X2D(_mstptr) + X2D(_msto._msti) _mstptr = D2X(_mstptr) END OTHERWISE _mstptr = _msto._msti END END _msti IF _EX_ENV = 'OPS/REXX' THEN _mstdata = OPSTORE('S',X2C(_mstptr),_mstlength) ELSE INTERPRET "_mstdata = STORAGE(_mstptr,_mstlength)" IF _msttype = 'X' THEN _mstdata = C2X(_mstdata) IF _msttype = 'D' THEN _mstdata = C2D(_mstdata) RETURN _mstdata MSTORERR1: SAY 'Incorrectly formed pointer expression' RETURN /* Force error: "Function returned no data" */ /*-End of MSTORAGE function-------------------------------------------*/ /*RXCOPY PATMATCH **** 67 LINES COPIED ON 11-24-98 AT 20:32************/ /*-Start of PATMATCH function---------------------------Version-01.01-*/ /*:PATMATCH function - Performs ISPF-type pattern matching on a pair */ /* of strings: 1st string is the pattern, 2nd is the data. */ /* Example: rc=PATMATCH('*EFG*','ABCDEFGH') */ /* Returns: 0: Pattern does not match the data. */ /* 1: Pattern does match the data. */ /* text: Error occured, text gives the details. */ /* Copyright (C) 1996, 1998 Washington Systems. All rights reserved. */ /*--------------------------------------------------------------------*/ PATMATCH: PROCEDURE EXPOSE gbl. TRACE N IF ARG() <> 2 THEN RETURN 'PATMATCH ERROR: 2 parms required, caller', 'passed 'ARG()' parms' haystack = ARG(2) /* Data to be searched w/ pattern */ pattern = ARG(1) /* Search pattern */ wild = 0 /* No '*' seen (yet) */ DO WHILE pattern <> '' /* Process pattern from L to R */ a = POS('*',pattern) /* Look for '*' in pattern */ IF a > 0 THEN /* If found, extract any */ DO /* preceeding search string */ PARSE VAR pattern needle '*' +0 newpattern IF needle = '' THEN DO /* If no preceeding search string, */ wild = 1 /* mark next search as 'wild card'*/ PARSE VAR newpattern 2 pattern /* remove '*' from pattern */ ITERATE /* and continue testing */ END END p = POS('%',pattern) /* Look for '%' in pattern */ IF p > 0 & (a = 0 | p < a) THEN /* If found before any '*', extract*/ DO /* any preceeding search string */ PARSE VAR pattern needle '%' +0 newpattern IF needle = '' THEN DO /* If no preceeding search string, */ needle = LEFT(haystack,1) /* take next text as search string */ PARSE VAR newpattern 2 newpattern wild = 0 /* Mark next search 'not wild card'*/ END END IF p = 0 & a = 0 /* No special chars, use remainder */ THEN PARSE VAR pattern needle newpattern pattern = newpattern /* Update pattern for next pass */ pos = POS(needle,haystack) /* Look for this pattern */ IF pos = 0 THEN RETURN 0 /* Not found, outta here */ IF pos > 1 THEN /* Found, but not at start-of-text */ IF wild <> 1 /* Wild card char in effect? */ THEN RETURN 0 /* No wild card, outta here */ wild = 0 /* Reset wild card character */ len = LENGTH(haystack)-LENGTH(needle)-pos+1 haystack = RIGHT(haystack,len) /* Remove data that we just scanned*/ IF haystack = '' THEN DO /* No more data to scan... */ IF pattern = '' /* Out of pattern as well? */ THEN RETURN 1 /* Yes, that's a match. */ IF pattern = '*' /* Did pattern end with wild card? */ THEN RETURN 1 /* Yes, that's a match too. */ RETURN 0 /* Else, sorry, not a match. */ END END /* Ran out of pattern to scan */ IF wild = 1 /* Did pattern end with wild card? */ THEN RETURN 1 /* Yes, that's a match. */ ELSE RETURN 0 /* Else, sorry, not a match. */ /*-End of PATMATCH function-------------------------------------------*/ /*RXCOPY RXERROR **** 122 LINES COPIED ON 01-30-99 AT 06:07************/ /*START OF RXERROR--------------------------------------Version-01.05-*/ /*: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. */ /* */ /* 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,1998 Washington Systems. All rights reserved. */ /*--------------------------------------------------------------------*/ RXERROR: TRACE N /* Turn off tracing for this func. */ _sigl = sigl 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 _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 _errtext = ' (Condition='CONDITION('C')', Description=', CONDITION('D')')' 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 "RXERROR Error RC "_rc""_errtext" at line "_sigl, "in EXEC "_ex_name IF _sigl <= SOURCELINE() /* Is source code avail? */ THEN SAY "RXERROR Source Line "_sigl": "STRIP(SOURCELINE(_sigl)) 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