/*---------Language: TSO/E REXX or OPS/REXX-------------------$$PROLOG*/ /* Program Name: IMSCMD */ /* Description: "Wrapper" for OPSCMD and ADDRESS OPER for */ /* issuing IMS commands, to serialize the IMS WTOR. */ /* Input Parameters: '/ims cmd' CMDWAIT(10) CMDRESP(REXX) IMS(imsid) */ /* DFS000I(NO) PREFIX(CMDOUT) LOG(YES) */ /* MAXCMDOUT(200) */ /* - Use character pair delimiters, e.g. $/DIS A$ */ /* - No output will be returned unless you specify */ /* CMDRESP(CLIST) or CMDRESP(REXX) and CMDWAIT(>0)*/ /* REXX Examples: */ /* INTERPRET IMSCMD("'/DIS A' CMDRESP(REXX) CMDWAIT(10) IMS(IMSP)") */ /* CALL IMSCMD "'/CHE SNAPQ' CMDWAIT(0) IMS(IMST)" */ /* */ /* Rule Examples: */ /* TSOCMD(OI IMSCMD '''/DIS A''' IMS(IMSP)) */ /* ADDRESS OSF "'/CHE SNAPQ' IMS(IMST)" */ /* */ /* Statvars Used: GLOBAL0.IMSCMD.imsid.Q */ /* Invocation: Called by rules or other REXX execs */ /* Invokes: None */ /* Return Codes: 0 - Successful Completion */ /* Related Routines: REPLY rule, DFS996I rule, DATETIME rule. */ /* Base Release: CA-OPS/MVS 4.2. */ /* Restrictions: None */ /* Dependencies: None */ /* Change log: Add new entries to the top */ /*-----------------Changed 17-Nov-2006 by: Bob Stark--------------1.2-*/ /* 1. Fixed bug where semicolons returned by IMS messed up retvar() */ /*-----------------Changed 19-JUL-1999 by: Bob Stark--------------1.1-*/ /* 1. Add support for IMS commands that have embedded single quotes. */ /* These must be entered with the quotes doubled, e.g. */ /* CALL IMSCMD "$/RMLIST DBRC=''RECON STATUS''.$ IMS(IPSA)" */ /* 2. Fixed the ASID compare to use "==" instead of "=" to resolve */ /* problems when the ASID contains an "E" (e.g. 00E7) and REXX */ /* converts the number to scientific notation. */ /* 3. Cleanup for distribution on ProTech web site. */ /*-----------------Changed 11/01/1998 by: Bob Stark ------------------*/ /* 1. Added MAXCMDOUT(nnn) option for commands with a lot of output. */ /*-----------------Changed 09/18/1998 by: Bob Stark ------------------*/ /* 1. Added LOG(YES|NO) Option to log traffic delivered via the BMP. */ /*-----------------Changed 09/17/1998 by: Bob Stark ------------------*/ /* 1. Fixed problem with CMDRESP(CLIST) setting CMDOUT0, not CMDOUT. */ /* 2. Added PREFIX(cmdout) parm. */ /*-----------------Changed 09/15/1998 by: Bob Stark ------------------*/ /* 1. Moved loop which removes DFS000I msgids. */ /* 2. Fix problem where the CMDWAIT(0) queued behind CMDWAIT(>0), */ /* and no one ever issued the command, causing lock timeouts. */ /* The fix is that when we wait in line to be first, then lock the */ /* queue, remove our command from the queue when we lock it, so */ /* the DFS996I rule will issue any CMDWAIT(0) commands that are */ /* waiting behind us. This makes it flow thru the same logic as */ /* when we are the only caller, and nothing is on the queue. */ /*-----------------Changed 08/13/1998 by: Bob Stark ------------------*/ /* 1. Added logic to timeout the lock if it is held too long. */ /* 2. Added logic to remove hex garbage from BMP command response */ /*-----------------Changed 07/20/1998 by: Bob Stark ------------------*/ /* 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 */ /*--------------------------------------------------------------------*/ OPTIONS 'OPSWXTRN=OUTTRAP' CALL ON ERROR NAME RXERROR SIGNAL ON SYNTAX NAME RXERROR SIGNAL ON NOVALUE NAME RXERROR TRACE N cmdresp = 'NOWHERE' /* Default CMDRESP(CLIST|REXX|NOWH+*/ cmdwait = 0 /* Default CMDWAIT(xx) value */ maxcmdout = 200 /* Default MAXCMDOUT(nn) value */ debug = '' dfs000i = 'NO' /* Do you want to see DFS000I msgs?*/ imsid = '' log = 'YES' /* Should Cmd & Response from BMP? */ prefix = 'CMDOUT' valparms = 'DEBUG DFS000I CMDWAIT CMDRESP IMSID MAXCMDOUT PREFIX' /*--------------------------------------------------------------------*/ /* Find first non-blank character in the first parm, and use it as */ /* the command delimiter, e.g. $/DIS A$ */ /*--------------------------------------------------------------------*/ delim = LEFT(STRIP(ARG(1)),1) /* First non-blank character... */ PARSE ARG (delim) cmd (delim) +0 found +1 parms IF cmd = '' | found <> delim THEN DO max_rc = 16 CALL ERRMSGX 'Missing or invalid IMS command' END parms = TRANSLATE(parms) /* Uppercase any incoming parms... */ rc = KWPARSE(parms,valparms) IF rc <> 0 THEN CALL ERRMSGX 'KWPARSE Failed, rc='rc IF debug <> '' THEN TRACE I CALL KWVALID 'CMDRESP','NONBLANK LIST(CLIST,REXX,NOWHERE)','PARMINV' CALL KWVALID 'CMDWAIT','NONBLANK RANGE(0,600)','PARMINV' CALL KWVALID 'DFS000I','NONBLANK LIST(YES,NO)','PARMINV' CALL KWVALID 'IMSID','NONBLANK','PARMINV' CALL KWVALID 'LOG','NONBLANK LIST(YES,NO)','PARMINV' CALL KWVALID 'MAXCMDOUT','RANGE(0,2000)','PARMINV' CALL KWVALID 'PREFIX','NONBLANK','PARMINV' IF cmdresp = 'NOWHERE' & cmdwait > 0 /* If no response, trim */ THEN cmdwait = 0 /* CMDWAIT to 0 */ IF maxcmdout <> 200 THEN maxcmdout = 'MAXCMDOUT('maxcmdout')' ELSE maxcmdout = '' SIGNAL INIT PARMINV: /* Common handler for KWVALID error*/ max_rc = 16 SIGNAL EXIT INIT: IF cmdwait = 0 /* If caller doesn't want output */ THEN SIGNAL WTORCMD /* Then we're going to use WTOR REPL*/ /*--------------------------------------------------------------------*/ /* Determine if our command can be issued via the BMP, and the BMP is */ /* active. If so, just issue it, and the BMP will do the queueing */ /* for us. Note that this list can't be monkeyed with willy-nilly, */ /* it must stay in sync with what is coded in the CA-OPS BMP. */ /*--------------------------------------------------------------------*/ cmdw1 = TRANSLATE(WORD(cmd,1)) SELECT WHEN ABBREV('/CANCEL',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/CHECKPOINT',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/ERESTART',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/EXCLUSIVE',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/EXIT',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/FORMAT',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/HOLD',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/IAM',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/LOCK',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/MODIFY',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/MSVERIFY',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/NRESTART',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/RCLSDST',cmdw1) = 1 THEN SIGNAL WTORCMD WHEN ABBREV('/RCOMPT',cmdw1) = 1 THEN SIGNAL WTORCMD OTHERWISE /* See if the BMP is active. If so, cmd can be issued now. */ rc = OPBMPACT(imsid) IF rc = 1 THEN /* BMP is active, issue the cmd */ DO sendtype = 'BMP' SIGNAL REALLY_ISSUE_THE_IMS_COMMAND END IF rc = -1 THEN /* IMS region not even active? */ DO /* Yes, it's not active */ max_rc = 52 /* ADDRESS OPER gives rc = 52 for */ SIGNAL EXIT /* "IMS region not active" */ END END WTORCMD: sendtype = 'WTOR' weownlock = 0 /* We don't own the IMS lock (yet) */ cmdtoissue = "COMMAND('"cmd"') IMSID("imsid") CMDRESP("cmdresp") ", "CMDWAIT("cmdwait")" glvname = 'GLOBAL0.IMSCMD.'imsid'.Q' DO i = 1 BY 1 UNTIL updated = 1 current = OPSGETV(glvname" TOKEN(cookie)") IF WORDS(current) > 0 /* Is variable valid? */ THEN replyid = WORD(current,1) /* Yes, extract replyid */ ELSE replyid = 1 /* No, make up initial replyid */ IF replyid < 0 /* Is the queue locked? */ THEN new = current' 'cmdtoissue'$EOT$' /* Yes, append to endofqueue */ ELSE IF WORDS(current) > 1 /* Any cmds already queued? */ THEN new = current' 'cmdtoissue'$EOT$'/* Yes, append to endofqueue*/ ELSE DO /* No, just try to get lock */ new = '-'replyid /* Indicate "locked" */ weownlock = 1 /* Remember our handiwork */ END updated = OPSSETV(glvname "("new") TOKEN("cookie")") IF updated = 0 THEN weownlock = 0 /* Sorry, not just yet! */ END i /*--------------------------------------------------------------------*/ /* Now we are in one of three states: */ /* 1. Cmd has been queued, the caller wants the cmd output, so */ /* we must wait for our command to be first in line. */ /* 2. Cmd has been queued, but we don't need to wait for cmd output, */ /* some rule will issue the command for us when IMS WTOR is free. */ /* 3. We locked the queue, there is nothing on it, issue our command. */ /*--------------------------------------------------------------------*/ IF WORDS(new) > 1 & cmdwait > 0 THEN /* Do we need to wait? */ DO i = 1 BY 1 UNTIL updated = 1 /* Yes, start waiting... */ updated = 0 IF RIGHT(GETENV(),3) = 'TSO' /* Are we running TSO/E REXX? */ THEN ADDRESS TSO "OPSWAIT 1" /* Yes, use TSO cmd to wait */ ELSE CALL OPSWAIT 1 /* No, use OPSWAIT REXX function */ IF i // 30 = 0 /* If we've waited 30 laps, better */ THEN CALL CHKTIMEOUT /* see if the lock owner died */ current = OPSGETV(glvname" TOKEN(cookie)") PARSE VAR current replyid firstcmd '$EOT$' nextcmd IF replyid < 0 /* Someone have the lock? */, THEN ITERATE i /* Yes, wait patiently... */ /* Parse out actual IMS command 19-JUL-1999 */ Parse var firstcmd . "COMMAND('" actualcmd "')" remaincmd /* If quotes in cmd, double them up (' -> '') to match cmdtoissue. */ IF POS("'",actualcmd) > 0 THEN firstcmd = "COMMAND('"XREPLACE(actualcmd,"'","''")"')"remaincmd IF firstcmd<>'' & firstcmd <> cmdtoissue /* Is it our turn yet? */, THEN ITERATE i /* No, be patient... */ new = '-'replyid' 'nextcmd /* Attempt to lock queue 09/15*/ updated = OPSSETV(glvname "("new") TOKEN("cookie")") IF updated = 1 THEN weownlock = 1 /* Remember we own the lock */ END i /*--------------------------------------------------------------------*/ /* If the queue is locked, then it is ours. Issue our command. */ /*--------------------------------------------------------------------*/ cmdout.0 = 0 /* Init counter in case no output */ IF weownlock = 0 /* Do we own the lock queue? */ THEN SIGNAL EXIT /* No, cmd queued, we're done */ REALLY_ISSUE_THE_IMS_COMMAND: DO i = 1 BY 1 until max_rc <> 56 /* Yes, issue the command */ /*------------------------------------------------------------------*/ /* CMDs issued by the OPS BMP don't get logged, so we will log them.*/ /*------------------------------------------------------------------*/ IF sendtype = 'BMP' & i = 1 & log = 'YES' THEN DO wtodata = "MSGID(IMSCMDC) MCSFLAGS(HRDCPY)", "TEXT('COMMAND("cmd") IMSID("imsid") CMDWAIT("cmdwait")", maxcmdout"')" ADDRESS TSO "OPSWTO "wtodata END /*------------------------------------------------------------------*/ /* If the caller specifies CMDRESP(CLIST), we end up working with */ /* the data in REXX variables, then converting it to CLIST format */ /* right before we return. */ /*------------------------------------------------------------------*/ IF cmdresp = 'CLIST' /* Does caller want CMDRESP(CLIST)?*/ THEN tcmdresp = 'REXX' /* Yes, pretend its REXX */ ELSE tcmdresp = cmdresp /* No, honor the caller's request */ IF cmdwait > 0 THEN output = 'OUTPUT' ELSE output = 'NOOUTPUT' ok = 'ALL' SELECT WHEN RIGHT(GETENV(),3) = 'TSO' & cmdwait > 0 THEN /* TSO/E REXX? */ DO /* Yes, use OPSCMD TSO cmd */ CALL OUTTRAP "CMDOUT." ADDRESS TSO "OPSCMD COMMAND('"cmd"') IMSID("imsid") "output, "CMDWAIT("cmdwait") CMDRESP("tcmdresp")", maxcmdout CALL OUTTRAP "OFF" max_rc = rc /*--------------------------------------------------------------*/ /* If the command goes thru the BMP, there may be trailing hex */ /* data, starting with a '15'x. We remove this extra junk. */ /*--------------------------------------------------------------*/ delimiter = '15'x IF sendtype = 'BMP' THEN DO j = 1 TO cmdout.0 PARSE VAR cmdout.j cmdout.j (delimiter) . END j END WHEN RIGHT(GETENV(),3) <> 'TSO' & cmdwait > 0 THEN /* No TSO/E RX?*/ DO CALL OPSCLEDQ /* Clean off the REXX stack */ ADDRESS OPER "COMMAND('"cmd"') IMSID("imsid") CMDWAIT("cmdwait")", maxcmdout max_rc = rc /*--------------------------------------------------------------*/ /* If the command goes thru the BMP, there may be trailing hex */ /* data, starting with a '15'x. We remove this extra junk. */ /*--------------------------------------------------------------*/ delimiter = '15'x DO j = 1 TO QUEUED() PULL cmdout.j (delimiter) . END j cmdout.0 = j-1 /* Set count of lines returned */ END /*----------------------------------------------------------------*/ /* If CMDWAIT is 0, then just reply to the WTOR, so that the */ /* output is logged. */ /*----------------------------------------------------------------*/ WHEN RIGHT(GETENV(),3) = 'TSO' & cmdwait = 0 THEN /* TSO/E REXX? */ DO /* Yes, use OPSCMD TSO cmd */ ADDRESS TSO "OPSCMD COMMAND('R "replyid","cmd"') NOOUTPUT" max_rc = rc END WHEN RIGHT(GETENV(),3) <> 'TSO' & cmdwait = 0 THEN /* No TSO/E RX?*/ DO /* No, it's OPS/REXX, use ADDR OPER*/ ADDRESS OPER "COMMAND('R "replyid","cmd"')" max_rc = rc END END DROP ok /*------------------------------------------------------------------*/ /* There is a chance that with all of this serialization jazz, that */ /* the command still missed the IMS WTOR. This is because not */ /* everything in the free world calls this routine to issue their */ /* IMS commands. If the operator replies to IMS directly, there is */ /* a chance that can mess us up. If it does, we just wait & retry. */ /*------------------------------------------------------------------*/ IF max_rc = 56 THEN DO IF RIGHT(GETENV(),3) = 'TSO' /* Are we running TSO/E REXX? */ THEN ADDRESS TSO "OPSWAIT 1" /* Yes, use TSO cmd to wait */ ELSE CALL OPSWAIT 1 /* No, use OPSWAIT REXX function */ ITERATE i /* Go back & take another lap. */ END END i /*--------------------------------------------------------------------*/ /* CMD responses issued by OPS BMP don't get logged, so we log them. */ /*--------------------------------------------------------------------*/ IF sendtype = 'BMP' & log = 'YES' THEN DO i = 1 TO cmdout.0 wtodata = "MSGID(IMSCMDR) MCSFLAGS(HRDCPY) TEXT('"cmdout.i"')" ADDRESS TSO "OPSWTO "wtodata END i /*--------------------------------------------------------------------*/ /* See if we are to remove the DFS000I msgid from the front of the */ /* output, like AutoMate/MVS used to. If so, do it. */ /*--------------------------------------------------------------------*/ IF dfs000i = 'NO' THEN DO i = 1 TO cmdout.0 IF ABBREV(cmdout.i,'DFS000I ') = 1 THEN cmdout.i = SUBSTR(cmdout.i,9,LENGTH(cmdout.i)-8) END i IF sendtype <> 'WTOR' /* Did we send via the WTOR? */ THEN SIGNAL EXIT /* No, no unlocking required. */ SIGNAL EXIT IF weownlock = 1 THEN /* Are we the lock owner?*/ DO i = 1 BY 1 UNTIL updated = 1 /* Yes, free it. */ current = OPSGETV(glvname" TOKEN(cookie)") PARSE VAR current replyid nextcmd IF replyid < 0 /* Is the queue locked? */ THEN replyid = -replyid /* Yes, shouldn't be, so unlock it.*/ new = replyid' 'nextcmd updated = OPSSETV(glvname "("new") TOKEN("cookie")") IF updated = 1 THEN weownlock = 0 /* Remember we own the lock */ END i EXIT: /*--------------------------------------------------------------------*/ /* Note that the careful variable checking in the following section */ /* is due to the fact that the error handler comes here when it traps.*/ /*--------------------------------------------------------------------*/ IF SYMBOL('cmdout.0') = 'LIT' /* Make sure cmdout.0 is valid */ THEN cmdout.0 = 0 IF SYMBOL('max_rc') = 'LIT' /* Set the RC variable to return */ THEN rc = 0 ELSE rc = max_rc IF SYMBOL('prefix') = 'LIT' THEN prefix = 'CMDOUT' /*--------------------------------------------------------------------*/ /* If the caller wants the data returned in a different PREFIX, we */ /* copy the CMDOUT. stem variable to the caller's desired stem, then */ /* pass that stem to RETVAR to build the string of data to return. */ /*--------------------------------------------------------------------*/ IF prefix <> 'CMDOUT' THEN DO expose = 'CMDOUT. 'prefix'.' CALL STEMCOPY 'cmdout.', prefix'.' END retdata = RETVAR('RC 'prefix'.') /* Build string of data to return */ /*--------------------------------------------------------------------*/ /* If caller wants CMDRESP(CLIST), remove the dots from the variables.*/ /*--------------------------------------------------------------------*/ IF SYMBOL('cmdresp') <> 'LIT' THEN IF cmdresp = 'CLIST' THEN DO prefixdot = prefix'.' /* Used below to search for CMDOUT.*/ DO UNTIL right = '' PARSE VAR retdata left (prefixdot) right IF LEFT(right,1) = '0' /* Is this CMDOUT.0=n;? */ THEN PARSE VAR right 2 right /* Yes, change to CMDOUT=n; */ IF right <> '' THEN retdata = left''prefix''right ELSE retdata = left END END PARSE SOURCE . calltype . IF calltype <> 'COMMAND' THEN EXIT retdata EXIT rc /*--------------------------------------------------------------------*/ /*:CHKTIMEOUT function - see if the command queue hasn't been updated */ /* for awhile, and if so, just unlock it. */ /*--------------------------------------------------------------------*/ CHKTIMEOUT: PROCEDURE EXPOSE sigl gbl. glvname the_environment TRACE N PARSE VALUE REVERSE(glvname) WITH . '.' vname vname = REVERSE(vname) /* Remove last node from varname */ IF GETENV() = 'OPSTSO' THEN DO /*------------------------------------------------------------------*/ /* We need the statistics for when the lock was last updated, but */ /* we are running in TSO/E REXX, so we can't call OPSVALUE(). */ /* Instead, fire a GLV rule that will call OPSVALUE() for us, and */ /* place it in a variable. */ /*------------------------------------------------------------------*/ CALL OPSSETV 'GLVJOBID.DATETIME ('glvname')' PARSE VALUE OPSGETV('GLVJOBID.DATETIME') WITH vdate vtime pgm jobname IF vdate = glvname THEN /* If value didn't change, then the */ DO /* rule didn't fire. */ SAY 'WARNING, DATETIME rule is not enabled, unable to UNLOCK...' RETURN END END ELSE DO CALL OPSCLEDQ CALL OPSVALUE vname,'I' /* Extract statistics for IMS vars */ DO i = 1 TO QUEUED() PULL name IF name <> 'Q' THEN /* Is this the command queue? */ DO /* No. */ PULL . /* Ignore these statistics */ ITERATE i /* and increment to next variable */ END PULL . . . . . vdate vtime pgm jobname . /* yyyy/mm/dd hh:mm:ss */ CALL OPSCLEDQ /* Ignore any leftovers. */ LEAVE i END i END date = LEFT(DATE('S'),2)DATE('O') /* Current date as yyyy/mm/dd */ time = ABS(TIME('S') - HMS2SEC(vtime)) IF date = vdate & time < 240 /* Locked out for over 4 minutes? */ THEN RETURN /* No, not yet, keep waiting... */ wtodata = "MSGID(IMSCMDE)", "TEXT('Lock hung since "vdate vtime" by "pgm jobname" redriving')" ADDRESS TSO "OPSWTO "wtodata DO i = 1 BY 1 UNTIL updated = 1 /* Yes, remove it. */ current = OPSGETV(glvname" TOKEN(cookie)") PARSE VAR current replyid firstcmd '$EOT$' nextcmd IF replyid < 0 /* Is the queue locked? */ THEN replyid = -replyid /* Yes, shouldn't be, so unlock it.*/ new = replyid' 'nextcmd updated = OPSSETV(glvname "("new") TOKEN("cookie")") IF updated = 1 & firstcmd <> '' THEN ADDRESS TSO "OPSCMD "firstcmd END i RETURN /*--------------------------------------------------------------------*/ /*:OPBMPACT function - determines if the OPS/MVS BMP is active for */ /* a given IMS region. */ /* Parameters: imsid */ /* Returns: 1=BMP active; 0=IMS active but not BMP; -1=IMS down */ /* Example: */ /* IF OPBMPACT('IMST') = 1 */ /* THEN ADDRESS OPER "COMMAND('/DIS A') IMSID(IMST)" */ /*--------------------------------------------------------------------*/ OPBMPACT: PROCEDURE EXPOSE GBL. SIGL TRACE N IF ARG() < 1 THEN DO; SAY 'OPBMPACT() ERROR, missing required parm - IMSID, called from', 'line 'sigl IF SOURCELINE() >= sigl THEN SAY SOURCELINE(sigl) RETURN; END SELECT WHEN RIGHT(GETENV(),3) = 'TSO' THEN /* Running TSO/E REXX? */ DO /* Find the OPS/MVS IMS index number for this IMSID.*/ DO i = 1 TO 32 CALL OUTTRAP "CMDOUT." ADDRESS TSO 'OPSPARM SHOW(IMS'i'ID)' CALL OUTTRAP "OFF" PARSE VAR cmdout.1 "'" prmimsid "'" IF prmimsid <> ARG(1) THEN ITERATE i /* "i" is now pointing at the correct set of IMS parms */ CALL OUTTRAP "CMDOUT." ADDRESS TSO 'OPSPARM SHOW(IMS'i'AS)' /* Find IMS regions ASID */ CALL OUTTRAP "OFF" PARSE VAR cmdout.1 "'" prmimsasid "'" IF prmimsasid == '0000' THEN RETURN -1 /* ASID=0, region is down*/ CALL OUTTRAP "CMDOUT." ADDRESS TSO 'OPSPARM SHOW(IMS'i'BMPATCB)' /* Find BMP TCB addr */ CALL OUTTRAP "OFF" PARSE VAR cmdout.1 "'" prmimsbmpt "'" IF prmimsbmpt == '00000000' /*19-JUL-99*/ THEN RETURN 0 /* TCB n/a, BMP is down. */ RETURN 1 /* TCB Found, BMP is up. */ END i RETURN -1 /* IMS region not defined to OPS */ END WHEN GETENV() = 'OPSREXX' THEN /* Running OPS/REXX? */ DO /* Find the OPS/MVS IMS index number for this IMSID.*/ DO i = 1 TO 32 CALL OPSCLEDQ rc = OPSPRM('SHOW','IMS'i'ID') IF rc <> 0 THEN CALL RXERROR PARSE PULL "'" prmimsid "'" IF prmimsid <> ARG(1) THEN ITERATE i /* "i" is now pointing at the correct set of IMS parms */ CALL OPSCLEDQ rc = OPSPRM('SHOW','IMS'i'AS') /* Look for IMS ASID */ IF rc <> 0 THEN CALL RXERROR PARSE PULL "'" prmimsasid "'" IF prmimsasid == '0000' THEN RETURN -1 /* ASID=0, region is down*/ CALL OPSCLEDQ rc = OPSPRM('SHOW','IMS'i'BMPATCB') /* Look for BMP TCB addr */ IF rc <> 0 THEN CALL RXERROR PARSE PULL "'" prmimsbmpt "'" IF prmimsbmpt == '00000000' /*19-JUL-99*/ THEN RETURN 0 /* TCB n/a, BMP is down. */ RETURN 1 /* TCB Found, BMP is up. */ END i RETURN -1 /* IMS region not defined to OPS */ END OTHERWISE CALL ERRMSGX 'Called from unsupported environment: 'GETENV() END RETURN /*--------------------------------------------------------------------*/ /* RXCOPY routines follow (in alphabetical order) */ /*--------------------------------------------------------------------*/ /*RXCOPY ERRMSGX NODUP 27 LINES COPIED ON 11-17-06 AT 09:11************/ /*-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 GETENV NODUP 169 LINES COPIED ON 11-17-06 AT 09:11************/ /*-Start of GETENV subroutine---------------------------Version-01.13-*/ /*:GETENV Function: Determines current REXX / AO product environment. */ /* Returns: ATMCMS CMDCMS ATMREXX ATMTSO MVSTSO OPSREXX OPSTSO */ /* CMDRULE DOMRULE EOMRULE GLVRULE MSGRULE OMGRULE REQRULE SCRRULE */ /* SECRULE TODRULE NETVMVS IMF AFOPER MVSUSS */ /* AXCOS2 CMDOS2 AXCONT CMDONT AXCWNT CMDWNT AXCW95 CMDW95 */ /* SPFWNT CMDDOS AXCUNIX CMDUNIX RAWUNIX CMDR98 CMDRNT UNKNOWN */ /* Note: All variables used in this routine should be _hidden. */ /* Copyright (C) 1995,2003 ProTech. All rights reserved. */ /*--------------------------------------------------------------------*/ GETENV: TRACE N /* Turn off rexx tracing */ IF SYMBOL('the_environment')='VAR' /* If we were already called, */ THEN RETURN the_environment /* then just return the same answer*/ the_environment = 'UNKNOWN' /* Initialize - assume unknown */ PARSE UPPER SOURCE _src +3 1 . . . . . . . . _token . PARSE UPPER VERSION _version . 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 IF ABBREV(_version,'REXX-REGINA') = 1 THEN DO /* Regina REXX, tack on OS */ INTERPRET "the_environment='CMDR'RIGHT(UNAME('S'),2)"/*WIN98,WINNT*/ SIGNAL GETENV_EXIT END 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 IF TRANSLATE(ADDRESS()) = 'ISREDIT' /* SPF/Professional on WindowsNT*/ THEN DO; the_environment = 'SPFWNT'; SIGNAL GETENV_EXIT; END END IF _src = 'TSO' THEN DO /* Setup OUTTRAP if possible. */ IF SYMBOL('IMFENAME') SYMBOL('IMFORGN') = 'VAR VAR' THEN DO; the_environment = 'IMF'; SIGNAL GETENV_EXIT; END IF _token = 'OPENMVS' /* Running inside UNIX Sys Serv? */ THEN DO; the_environment = 'MVSUSS'; SIGNAL GETENV_EXIT; END IF ADDRESS() = 'AFHOST' /* Running inside AFOPER? */ THEN DO; the_environment = 'AFOPER'; SIGNAL GETENV_EXIT; END IF ADDRESS() = 'NETVIEW' /* Running inside NetView? */ THEN DO; the_environment = 'NETVMVS'; SIGNAL GETENV_EXIT; END INTERPRET "CALL OFF ERROR" /* Turn off error handler (n/a SPF)*/ INTERPRET "CALL OFF FAILURE" /* Turn off error handler (n/a SPF)*/ ADDRESS MVS "SUBCOM AFHOST" /* Running inside AFOPER? */ IF rc=0 THEN DO; the_environment = 'AFOPER'; SIGNAL GETENV_EXIT; END ADDRESS MVS "SUBCOM NETVIEW" /* Running inside NETVIEW? */ IF rc=0 THEN DO; the_environment = 'NETVMVS'; SIGNAL GETENV_EXIT; END IF ADDRESS() = 'MVS' /* Running MVS native rexx? */ THEN DO; the_environment = 'ATMREXX'; SIGNAL GETENV_EXIT; END ADDRESS MVS "SUBCOM TSO" /* Make sure TSO available */ IF rc=0 THEN /* Is it? */ DO /* Yes, now safe to call OUTTRAP() */ _fndops = 0 /* Haven't found OPS/MVS (yet) */ _fndatm = 0 /* Haven't found AutoMate (yet) */ NUMERIC DIGITS 9 /* Reset to default precision */ INTERPRET "_cvt = STORAGE(10,4)" /* -> CVT */ INTERPRET "_jesct = STORAGE(D2X(C2D(_cvt)+C2D('128'x)),4)" INTERPRET "_ssct = STORAGE(D2X(C2D(_jesct)+C2D('18'X)),4)" DO _i = 1 BY 1 WHILE _ssct <> '00000000'x /* Scan SSCT chain */ INTERPRET "PARSE VALUE STORAGE(C2X(_ssct),20) WITH", "1 _ssctid +4 5 _ssct +4 9 _ssctsnam +4 17 _ssctssvt +4" IF _ssctid <> 'SSCT' THEN SAY 'GETENV error, bad ssct @ 'C2X(ssct) IF _ssctssvt <> '00000000'x THEN /* Is subsys active? */ DO /* Yes, check subsys name */ IF ABBREV(_ssctsnam,'OPS') THEN _fndops = 1 IF ABBREV(_ssctsnam,'ATM') THEN _fndatm = 1 END END _i IF _fndops = 0 & _fndatm = 0 THEN DO; the_environment = 'MVSTSO'; SIGNAL GETENV_EXIT; END IF _fndops = 1 & _fndatm = 0 THEN DO; the_environment = 'OPSTSO'; SIGNAL GETENV_EXIT; END IF _fndops = 0 & _fndatm = 1 THEN DO; the_environment = 'ATMTSO'; SIGNAL GETENV_EXIT; END /*----------------------------------------------------------------*/ /* OUTTRAP() is used to quietly issue TSO cmds. If OUTTRAP() is */ /* already active, and we're nested too deeply to see vars needed */ /* to restore caller's outtrap, then don't run (avoid side-effect)*/ /*----------------------------------------------------------------*/ INTERPRET "_savtrap = OUTTRAP()" /* Is outtrap active? */ IF _savtrap = 'OFF' THEN _savtrap = "x=OUTTRAP('OFF')" /* No,Build outtrap shutoffcmd */ 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 (hide from OPS/REXX)*/ INTERPRET "x = OUTTRAP('_outtrap.',1,'NOCONCAT')" /* OUTTRAP is on*/ ADDRESS TSO 'OPSMODE SHOW' /*OPS7950I COMMAND MODE IS ATM|OPS|NONE*/ IF rc<0 THEN DO; the_environment = 'ATMTSO'; SIGNAL GETENV_EXIT; END IF _outtrap.0 = 1 THEN the_environment = WORD(_outtrap.1,WORDS(_outtrap.1))'TSO' IF WORDPOS(the_environment,'OPSTSO ATMTSO') > 0 THEN SIGNAL GETENV_EXIT ADDRESS TSO 'GETVAR ATMJOBNAME _atmjobname' INTERPRET "_sysuid = SYSVAR('SYSUID')" IF _sysuid = _atmjobname THEN DO; the_environment = 'ATMTSO'; SIGNAL GETENV_EXIT; END ELSE DO; the_environment = 'OPSTSO'; SIGNAL GETENV_EXIT; END END /* SUBCOM TSO */ END /* IF _src = 'TSO' THEN */ 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 /* IF _src = 'CMS' THEN */ 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. _version _token RETURN the_environment /*-End of GETENV subroutine-----------------------------------------*/ /*RXCOPY HMS2SEC NODUP 19 LINES COPIED ON 11-17-06 AT 09:11************/ /*-Start of HMS2SEC function---------------------------Version-01.01-*/ /*:HMS2SEC Function: Convert "hh:mm:ss" time to seconds past midnight.*/ /* Parms: Display time, hh:mm:ss */ /* Returns: Seconds past midnight, ssss */ /* Example: time = HMS2SEC('03:14:30') */ /* Copyright (C) 1996,2003 ProTech. All rights reserved. */ /*--------------------------------------------------------------------*/ HMS2SEC: PROCEDURE EXPOSE gbl. TRACE N PARSE ARG hh ':' +0 delim1 +1 mm ':' +0 delim2 +1 ss IF delim1 = '' /* If no ':', assume nn is minutes */ THEN DO; mm = hh; hh = 0; END IF delim2 = '' /* If no ':', assume nn is seconds */ THEN DO; ss = mm; mm = 0; END IF hh = '' THEN hh = 0 /* Allow hms2sec(':nn') */ IF mm = '' THEN mm = 0 /* Allow hms2sec('hh:') */ IF ss = '' THEN ss = 0 /* Allow hms2sec('hh:mm:') */ RETURN ((hh*60 + mm) * 60) + ss /*-End of HMS2SEC function--------------------------------------------*/ /*RXCOPY KWPARSE NODUP 130 LINES COPIED ON 11-17-06 AT 09:11***********/ /*Start of KWPARSE Function-----------------------------Version-01.04-*/ /*: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 3 /* 3 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 +2 _value "')" _parmr When _i = 3 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 3 */ /* 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 KWVALID NODUP 272 LINES COPIED ON 11-17-06 AT 09:11***********/ /*-Start of KWVALID function----------------------------Version-01.05-*/ /*:KWVALID Function: Validates that a keyword is set validly. Useful */ /* in subroutines that support a lot of keywords. */ /* Parms: name, validtypes, exitlabel */ /* where: name is the name of a REXX variable. */ /* validtypes List of one or more parm types, as follows: */ /* DATE(mm/dd/yyyy) DSNAME MEMBER LIST(a,b) */ /* NONBLANK RANGE(min,max) REXXVAR */ /* TIME(hh:mm:ss) TIME(hh:mm) TIME(hhmm) */ /* NONBLANK RANGE(min,max) */ /* exitlabel is optional - if provided, KWVALID will */ /* SIGNAL to that label if parm is invalid. */ /* If not provided, KWVALID returns 0 or error text*/ /* Returns: 0 if valid, error message if not. */ /* Example: rc = KWVALID('OPTION','LIST(CREATE,UPDATE)','EXIT'); */ /* Copyright (C) 2002 ProTechPTS.com. All rights reserved. */ /*--------------------------------------------------------------------*/ KWVALID: TRACE Normal _kwname = ARG(1) IF ARG() < 2 THEN DO _kwerrmsg = 'Must pass 2 or more arguments to KWVALID' SIGNAL KWNVALID END IF SYMBOL(ARG(1)) <> 'VAR' THEN DO _kwerrmsg = ARG(1)' parm not initialized' SIGNAL KWNVALID END ELSE _kwvalue = VALUE(_kwname) _kwtypes = ARG(2) DO WHILE _kwtypes <> '' PARSE VAR _kwtypes _kwtype _kwtypes PARSE VAR _kwtype _kwdatatype '(' _kwdataval ')' . SELECT WHEN TRANSLATE(_kwdatatype) = 'TIME' THEN SELECT WHEN TRANSLATE(_kwdataval) = 'HH:MM:SS' THEN DO PARSE VAR _kwvalue _kwhh ':' _kwmm ':' _kwss IF _kwhh < 0 | _kwhh > 23 | _kwmm < 0 | _kwmm > 59 | , _kwss < 0 | _kwss > 59 | DATATYPE(_kwhh,'W') <> 1 |, DATATYPE(_kwmm,'W') <> 1 | DATATYPE(_kwss,'W') <> 1 THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'invalid TIME(hh:mm:ss)' SIGNAL KWNVALID END END WHEN POS(TRANSLATE(_kwdataval), 'HH:MM HHMM') > 0 THEN DO IF POS(':',_kwdataval) > 0 THEN PARSE VAR _kwvalue _kwhh ':' _kwmm ELSE PARSE VAR _kwvalue 1 _kwhh 3 _kwmm IF _kwhh < 0 | _kwhh > 23 | _kwmm < 0 | _kwmm > 59 |, DATATYPE(_kwhh,'W') <> 1 | DATATYPE(_kwmm,'W') <> 1 THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'invalid TIME(hh:mm)' SIGNAL KWNVALID END END OTHERWISE _kwerrmsg = _kwname'('_kwvalue') validation error -', 'TIME('_kwdataval') invalid' SIGNAL KWNVALID END WHEN _kwdatatype = 'DATE' THEN DO IF TRANSLATE(_kwdataval) = 'MM/DD/YYYY' THEN DO PARSE VAR _kwvalue _kwmm '/' _kwdd '/' _kwyy IF _kwmm < 1 | _kwmm > 12 | _kwdd < 1 | _kwmm > 31 | , _kwyy < 0 | _kwyy > 9999 THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'invalid DATE(mm/dd/yyyy)' SIGNAL KWNVALID END END END WHEN _kwdatatype = 'DSNAME' THEN DO _kwvalue = TRANSLATE(STRIP(_kwvalue)) IF _kwvalue = '' THEN DO _kwerrmsg = _kwname'() parm invalid -', 'value must be a non-blank dataset name' SIGNAL KWNVALID END IF LENGTH(_kwvalue) > 44 THEN DO _kwerrmsg = 'Error, '_kwname'() parm invalid -', 'value is too long to be a valid dataset name' SIGNAL KWNVALID END _kwvrng1 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ@#$' /*Valid for 1st char */ _kwvrng2 = VALUE('_KWVRNG1')'0123456789.' /*Valid for rest of */ _kwvtemp = TRANSLATE(_kwvalue) DO WHILE _kwvtemp <> '' PARSE VAR _kwvtemp _kwvnode '.' _kwvtemp IF LENGTH(_kwvnode) > 8 | LENGTH(_kwvnode) < 1 THEN DO _kwerrmsg = _kwname'() parm invalid -', 'invalid characters in dataset name' SIGNAL KWNVALID END IF POS(LEFT(_kwvnode,1),_kwvrng1) = 0 THEN DO _kwerrmsg = _kwname'() parm invalid -', 'invalid character to start dataset name' SIGNAL KWNVALID END /* Translate all valid characters into dots, and if result is */ /* all dots, then it is valid. */ IF TRANSLATE(SUBSTR(_kwvnode, 2, LENGTH(_kwvnode)-1), '',, _kwvrng2,'.')<>COPIES('.',LENGTH(_kwvnode)-1) THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid', ' - invalid character in dataset name' SIGNAL KWNVALID END END /* DO WHILE _kwvtemp <> '' */ END /* WHEN _kwdatatype = 'DSNAME' THEN */ WHEN _kwdatatype = 'LIST' THEN DO _kwdataval = TRANSLATE(_kwdataval,'',',',' ') IF WORDPOS(_kwvalue,_kwdataval) = 0 THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'must be one of: '_kwdataval SIGNAL KWNVALID END END WHEN _kwdatatype = 'LISTABBR' THEN DO _kwdataval = TRANSLATE(TRANSLATE(_kwdataval,'',',',' ')) _kwvtemp = '' DO _kwvrng1 = 1 TO WORDS(_kwdataval) IF ABBREV(WORD(_kwdataval,_kwvrng1),_kwvalue) = 1 THEN _kwvtemp = SPACE(_kwvtemp' 'WORD(_kwdataval,_kwvrng1)) END _kwvrng1 IF WORDS(_kwvtemp) = 0 THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'must be one of: '_kwdataval SIGNAL KWNVALID END IF WORDS(_kwvtemp) > 1 THEN DO _kwerrmsg = _kwname'('_kwvalue') parm value is ambiguous -', 'is one of: '_kwvtemp SIGNAL KWNVALID END CALL VALUE _kwname,_kwvtemp /* Replace abbrev value w/ full */ END WHEN _kwdatatype = 'MEMBER' THEN DO _kwvalue = TRANSLATE(_kwvalue) IF WORDS(_kwvalue) <> 1 | LENGTH(_kwvalue) > 8 THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'must be a valid PDS member name' SIGNAL KWNVALID END _kwvrng1 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ@#$' /*Valid for 1st char */ _kwvrng2 = VALUE('_KWVRNG1')'0123456789.' /*Valid for rest of */ IF POS(TRANSLATE(LEFT(_kwvalue,1)),_kwvrng1) = 0 THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'invalid characters in member name' SIGNAL KWNVALID END /* Tricky... Translate all the valid characters into dots, and */ /* if result is all dots, then it is valid. */ IF TRANSLATE(SUBSTR(_kwvalue,2,LENGTH(_kwvalue)-1),, '',_kwvrng2,'.'), <> COPIES('.',LENGTH(_kwvalue)-1) THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'invalid characters in member name' SIGNAL KWNVALID END END WHEN _kwdatatype = 'NONBLANK' THEN DO IF WORDS(_kwvalue) = 0 THEN DO _kwerrmsg = _kwname'() parm invalid -', 'value must be non-blank' SIGNAL KWNVALID END END WHEN _kwdatatype = 'RANGE' THEN DO PARSE VAR _kwdataval _kwlower ',' _kwupper . IF _kwvalue < _kwlower | _kwvalue > _kwupper THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'range must be: '_kwlower' <= '_kwname' <= '_kwupper SIGNAL KWNVALID END END WHEN _kwdatatype = 'REXXVAR' THEN DO _kwvalue = TRANSLATE(_kwvalue) IF WORDS(_kwvalue) <> 1 THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'must be a valid REXX variable name without blanks' SIGNAL KWNVALID END _kwvrng1 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ?!_' /*Valid for 1st char */ _kwvrng2 = VALUE('_KWVRNG1')'0123456789.' /*Valid for rest of */ IF POS(TRANSLATE(LEFT(_kwvalue,1)),_kwvrng1) = 0 THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'invalid characters in variable name' SIGNAL KWNVALID END /* Tricky... Translate all the valid characters into dots, and */ /* if result is all dots, then it is valid. */ IF TRANSLATE(SUBSTR(_kwvalue,2,LENGTH(_kwvalue)-1),, '',_kwvrng2,'.'), <> COPIES('.',LENGTH(_kwvalue)-1) THEN DO _kwerrmsg = _kwname'('_kwvalue') parm invalid -', 'invalid characters in variable name' SIGNAL KWNVALID END END /* WHEN _kwdatatype = 'REXXVAR' THEN */ OTHERWISE _kwerrmsg = _kwdatatype' is an invalid KWVALID()', 'datatype' SIGNAL KWNVALID END /* SELECT */ END /* DO WHILE */ /* Cleanup our variables before we exit... */ DROP _kwdatatype _kwdataval _kwlower _kwname _kwtype _kwtypes, _kwupper _kwvalue _kwvnode _kwvrng1 _kwvrng2 _kwvtemp RETURN 0 /* All tests passed, keyword valid */ KWNVALID: PARSE SOURCE . . _kwnfilename . PARSE VALUE REVERSE(_kwnfilename) WITH _kwnfilename '\' _kwnfilename = REVERSE(_kwnfilename) IF ARG() >= 3 THEN DO SAY 'Error calling '_kwnfilename': '_kwerrmsg rc = _kwerrmsg SIGNAL VALUE ARG(3) INTERPRET "SIGNAL "ARG(3) /* For platforms w/o SIGNAL VALUE */ END RETURN _kwerrmsg /*-End of KWVALID function-------------------------------------------*/ /*RXCOPY RETVAR NODUP 59 LINES COPIED ON 11-17-06 AT 09:11*************/ /*-Start of RETVAR function---------------------------Version-01.02-*/ /*:RETVAR SUBROUTINE: Builds a return string that, when INTERPRETed */ /* by the calling program, will assign all of the data to the proper */ /* simple or stemmed variables. This is most useful for returning */ /* sets of stemmed variables from external subroutines. */ /* Input: list of VALID variable names, including stems. Example: */ /* INTERPRET subrt(); SAY 'a='a' b.1='b.1' b.2='b.2; EXIT */ /* SUBRT: PROCEDURE */ /* a='Hello'; b.0=2; b.1='Good'; b.2='Morning' */ /* RETURN RETVAR('a b.') */ /* Copyright (C) 1996,2003 ProTech. All rights reserved. */ /*--------------------------------------------------------------------*/ RETVAR: TRACE N _ret = '' DO _i = 1 to WORDS(ARG(1)) /* Process each variable in list */ _vars = WORD(ARG(1),_i) /* Get name of i'th variable */ IF RIGHT(_vars,1) == '.' THEN /* Is it a stemmed variable? */ DO /* Yes, it's a stem. */ IF SYMBOL(_vars''0) <> 'VAR' /* Is the 'var.0' value set? */ THEN DO; SAY 'RETVAR error, '_vars'0 undefined'; ITERATE; END IF DATATYPE(VALUE(_vars''0)) <> 'NUM' /* Is 'var.0' numeric? */ THEN DO; SAY 'RETVAR error, '_vars'0 not numeric'; ITERATE; END DO _j = 0 TO VALUE(_vars""0) /* Process each value in stem */ CALL RETVAR1 _vars""_j END _j END ELSE CALL RETVAR1 _vars /* Not a stem, handle it directly */ END _i return _ret RETVAR1: /* RETVAR subroutine to process a single variable */ _var = ARG(1) /* Copy variable name */ _val = VALUE(_var) /* and variable value */ IF VERIFY(_val,"';",'M') = 0 THEN /* Any embedded quotes or ; ? */ DO /* No, return data in char form */ /* Note! REXX literal strings must be 250 bytes or less. */ PARSE VAR _val _left 251 _val /* Get 1st 250 bytes */ _ret = SUBWORD(_ret""_var"='"_left"';",1) /* Append to return data */ DO WHILE LENGTH(_val) > 250 /* > 250 bytes left? */ PARSE VAR _val _left 251 _val /* Get next 250 bytes */ _ret = SUBWORD(_ret""_var"="_var"'"_left"';",1) END IF LENGTH(_val) > 0 /* If any data left, append it, too*/ THEN _ret = SUBWORD(_ret""_var"="_var"'"_val"';",1) END ELSE /* Data has embedded quotes, must */ DO /* return in hex form. */ PARSE VAR _val _left 126 _val /* Get 1st 125 bytes */ _ret = SUBWORD(_ret""_var"=X2C('"C2X(_left)"');",1) DO WHILE LENGTH(_val) > 125 /* > 125 bytes left? */ PARSE VAR _val _left 126 _val /* Get next 125 bytes */ _ret = SUBWORD(_ret""_var"="_var"''X2C('"C2X(_left)"');",1) END IF LENGTH(_val) > 0 /* If any data left, append it, too*/ THEN _ret = SUBWORD(_ret""_var"="_var"''X2C('"C2X(_val)"');",1) END RETURN /*-End of RETVAR function-------------------------------------------*/ /*RXCOPY RXERROR NODUP 129 LINES COPIED ON 11-17-06 AT 09: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,2005 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 STEMCOPY: PROCEDURE EXPOSE (expose) /*RXCOPY STEMCOPY NODUP 56 LINES COPIED ON 11-17-06 AT 09:11***********/ /*-Start of STEMCOPY Subroutine-------------------------Version-01.01-*/ /*:STEMCOPY subroutine: Copies one entire stem to another. The source */ /* stem must be correctly formatted with .0 variables. Additional */ /* subnodes are supported as long as they also have .0 variables. */ /* NOTE! You have to code your own PROCEDURE statement immediately */ /* prior to the RXCOPY for this subroutine, in order to expose the */ /* stem names that you will be passing to it! This is unusual, but */ /* it is the only way to provide general purpose stem access that */ /* works in all rexx versions and doesn't require you to use a */ /* fixed stem name. In OS/2, you can set it up to expose a well */ /* known variable prior to each call (example shown below) to make */ /* it pretty general purpose. In other environments, declare all */ /* the stems to be copied on the PROCEDURE statement. */ /* */ /* Parameters: Source-stem Destination-stem */ /* Return Codes: 0 if sucessful, 8 if invalid data in .0 stem */ /* For example: */ /* a.0 = 2; a.1 = smith; a.2 = jones; a.1.0 = 2; a.1.1 = mary; */ /* a.1.2 = john; a.2.0 = 1; a.2.1 = tom */ /* expose = 'a. b.' */ /* CALL STEMCOPY 'a.', 'b.' */ /* */ /* STEMCOPY: PROCEDURE EXPOSE (expose) */ /* RXCOPY STEMCOPY *** 72 LINES COPIED ON 04-15-97 AT 06:17 */ /* Copyright (C) 1996,2003 ProTech. All rights reserved. */ /*--------------------------------------------------------------------*/ TRACE N ARG source,destination IF RIGHT(source,1) <> '.' /* Add a trailing '.' to source */ THEN source = source'.' /* stem if omitted by caller */ IF RIGHT(destination,1) <> '.' /* Add trailing '.' to the dest. */ THEN destination = destination'.' /* stem if omitted by caller */ maxrc = 0 /* Initialize highest return code */ IF DATATYPE(VALUE(source'0')) <> 'NUM' THEN DO SAY 'STEMCOPY error: Missing or invalid 'source'0 variable' RETURN 8 END 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. */ DO i = 0 to VALUE(source'0') /* Copy variable using INTERPRET if diadic VALUE() if not available */ IF _dvalue = 0 THEN INTERPRET 'PARSE VAR 'source''i' 'destination''i ELSE x = VALUE(destination''i,VALUE(source''i)) IF SYMBOL(source''i'.0') = 'VAR' THEN /* Is there a subnode? */ DO /* Yes. */ rc = STEMCOPY(source''i,destination''i) /* recurse to process */ IF rc > maxrc THEN maxrc = rc /* Set maximum ret code */ END END i RETURN maxrc /*-End of STEMCOPY subroutine-----------------------------------------*/ /*RXCOPY WARNMSG NODUP 21 LINES COPIED ON 11-17-06 AT 09:11************/ /*-Start of WARNMSG function----------------------------Version-01.03-*/ /*:WARNMSG SUBROUTINE: Issues a formatted warning message and returns */ /* Parameters: Message text */ /* For example: */ /* IF missing <> '' */ /* then call WARNMSG('Missing required parameter(s):'missing) */ /* Copyright (C) 1996,2003 ProTech. All rights reserved. */ /*--------------------------------------------------------------------*/ WARNMSG: PROCEDURE EXPOSE gbl. TRACE N PARSE ARG msgtext parse source . . filename . errtext = 'REXX Warning: 'filename' 'msgtext SAY errtext IF ADDRESS() = 'AXC' THEN DO ADDRESS AXC "WTXC '"errtext"'" ADDRESS AXC "WTOH '"errtext"'" END RETURN /*-End of WARNMSG subroutine-----------------------------------------*/ /*RXCOPY XREPLACE NODUP 21 LINES COPIED ON 11-17-06 AT 09:11***********/ /*-Start of XREPLACE function---------------------------Version-01.01-*/ /*:XREPLACE Function: Returns new version of target, after replacing */ /* all occurrances of string "old" with string "new". */ /* Parms: target, old, new */ /* Example: */ /* str = XREPLACE('START &JOBNAME','&JOBNAME','MYJOB') */ /* Copyright (C) 1999,2003 ProTech. All rights reserved. */ /*--------------------------------------------------------------------*/ XREPLACE: PROCEDURE EXPOSE gbl. sigl Trace N PARSE ARG target, old, new result = '' tempx = 1 DO i = 1 BY 1 tempy = POS(old, target, tempx) IF tempy = 0 THEN LEAVE i result = result''SUBSTR(target,tempx,tempy-tempx)''new tempx = tempy + LENGTH(old) END i RETURN result''SUBSTR(target,tempx) /*-End of XREPLACE Function-------------------------------------------*/