/*---------Language: REXX-------------------------------------$$PROLOG*/
/*     Program Name: UNIXCMD                                          */
/*      Description: Issue a UNIX command, and return the response    */
/*    Customization: None                                             */
/* Input Parameters: UNIX shell cmd, options                          */
/*          options: SU - Issue cmd as superuser if permitted.        */
/*                   DEBUG - Standard debugging parm                  */
/*                   CMDRESP(TERMINAL | STACK | NOWHERE)  output dest.*/
/*    Statvars Used: None                                             */
/*    Example calls: rc=UNIXCMD('ls -l','CMDRESP(STACK)')             */
/*                   rc=UNIXCMD('ps -eAf','CMDRESP(STACK) SU')        */
/*          Invokes: None                                             */
/*     Return Codes: 0  - Successful Completion                       */
/* Related Routines:                                                  */
/*     Base Release: CA-OPS/MVS 4.2, CA-Automation Point 3.2          */
/*     Restrictions: None                                             */
/*     Dependencies: None                                             */
/*       Change log: Add new entries to the top                       */
/*-----------------Changed 15-JAN-2001 by: Bob Stark -----------------*/
/* 1. Initial coding                                                  */
/*--------------------------------------------------------------------*/
/* Copyright (C) 2001 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
TRACE N

PARSE SOURCE env calltype .
IF calltype = 'COMMAND' THEN
  DO
  PARSE ARG shellcmd ',' parms
  cmdresp = 'TERMINAL'          /* Set default based on calling env.  */
  END
ELSE
  DO
  PARSE ARG shellcmd, parms
  cmdresp = 'STACK'             /* Set default based on calling env.  */
  END

  DO WHILE shellcmd = ''
  SAY 'No UNIX shell cmd entered.  Enter desired cmd or Q to quit'
  PARSE PULL shellcmd
  IF TRANSLATE(shellcmd) = 'Q' THEN SIGNAL EXIT
  END

debug   = ''
su      = ''                    /* Non-blank if user can be superuser */
rc = KWPARSE(parms)
IF rc <> 0
THEN CALL ERRMSGX 'KWPARSE Failed, rc='rc

cmdresp = TRANSLATE(cmdresp)
rc = KWVALID('CMDRESP','LIST(TERMINAL,STACK,NOWHERE)','PARMERR')
IF debug <> '' THEN TRACE I

SIGNAL PARMSOK

PARMERR:
CALL ERRMSGX _kwerrmsg
PARMSOK:

username = TRANSLATE(userid(),'abcdefghijklmnopqrstuvwxyz',
                             ,'ABCDEFGHIJKLMNOPQRSTUVWXYZ')
pathname = "/tmp/"username"."TIME('L')".UNIXCMD"
/*--------------------------------------------------------------------*/
/* Free STDERR just in case it was left allocated                     */
/*--------------------------------------------------------------------*/
ok = 'ALL'
msgs = msg('OFF')
ADDRESS TSO "FREE DDNAME(STDERR)"
/*--------------------------------------------------------------------*/
/* Create temporary STDOUT file "/tmp/"user_id".UNIXCMD"              */
/*--------------------------------------------------------------------*/
  DO i = 1 TO 2
  ADDRESS TSO "ALLOCATE PATH('"pathname"')",
              "FILE(STDOUT) PATHDISP(DELETE,DELETE)",
              "PATHOPTS(OWRONLY,OCREAT,OEXCL,OTRUNC) PATHMODE(SIRWXU)"
  IF RC = 0 THEN LEAVE i
  IF i = 2
  THEN CALL ERRMSGX "Unable to allocate STDOUT"
  ADDRESS TSO "FREE DDNAME(STDOUT)"
  END i
CALL MSG msgs
DROP ok

IF su <> '' THEN
  DO
  ok = 'ALL'
  rc = SYSCALL('geteuid')               /* see if already UID=0 */
  IF rc = 0 & _retval <> 0 THEN
    DO
    ouruid = _retval
    rc = SYSCALL('seteuid 0')           /* Try to get to UID 0        */
    IF _retval = 0 THEN                 /* It worked. Now try to      */
    shellcmd = 'echo "'shellcmd'" | su' /* pipe the cmd thru su       */
    END
  DROP ok
  END


/*--------------------------------------------------------------------*/
/* Invoke shell by calling BPXBATCH                                   */
/*--------------------------------------------------------------------*/
"BPXBATCH SH "shellcmd
saverc = rc                        /* Save return code for EXIT       */

IF WORDPOS(rc,'254 255') = 0 & cmdresp <> 'NOWHERE' THEN
  DO
  ok = 4
  rc = SYSCALL("readfile (pathname) stdout.")
  IF rc <> 0 THEN CALL ERRMSGX "Unable to readfile STDOUT, rc="rc
    DO i = 1 TO stdout.0
    IF cmdresp = 'TERMINAL' THEN SAY stdout.i
    IF cmdresp = 'STACK'    THEN QUEUE stdout.i
    END i
  END
ADDRESS TSO "FREE DDNAME(STDOUT)"

EXIT:
IF SYMBOL('saverc') = 'LIT'
THEN saverc = 0
EXIT saverc


/*--------------------------------------------------------------------*/
/*:SYSCALL() function - Issue ADDRESS SYSCALL and check return codes. */
/* Requires that the user be defined to OS/390 Open Edition           */
/* For example:                                                       */
/* rc = SYSCALL('mkdir /usr/local/logs')                              */
/*--------------------------------------------------------------------*/
SYSCALL:
TRACE N
IF SYMBOL('GBL.SYSCALLS') = 'LIT' THEN
  DO
  rc = SYSCALLS('ON')                /* Setup to call ADDRESS SYSCALL */
  IF rc <> 0 THEN
    DO
    PARSE VALUE '4=signal process mask not set;',
               '7=process was dubbed, but SYSCALL environment not set;',
               '8=process could not be dubbed;',
          WITH (rc) '=' _errtext ';'
    _errtext=' SYSCALLS(ON) rc='rc': '_errtext
    _sigl = sigl
    SIGNAL RXERROR1
    END
  ELSE GBL.SYSCALLS = 'ON'
  END

ADDRESS SYSCALL ARG(1)
_retval  = retval
_errno   = errno
_errnojr = errnojr

IF retval = 0 THEN RETURN 0
IF SYMBOL('ok') = 'VAR' THEN
  IF TRANSLATE(ok) = 'ALL' | WORDPOS(errno,ok) > 0
  THEN RETURN errno
err. = ''
/*--------------------------------------------------------------------*/
/* If we are at a high enough OS/390 version (in 2.7 for sure, not in */
/* 2.4), then we can lookup the error text that accompanies this code.*/
/*--------------------------------------------------------------------*/
ADDRESS SYSCALL "uname v."
IF LEFT(v.u_version'.'v.u_release,5) >= '02.05' THEN
  DO
  ADDRESS SYSCALL "strerror "_errno _errnojr" ERR."
    DO i = 1 TO err.0
    SAY err.i
    END i
  SAY err.SE_ERRNO                /* Text for the error number.       */
  SAY err.SE_REASON               /* Text for the reason code.        */
  SAY err.sE_ACTION               /* Text for corrective action       */
  SAY err.SE_MODID                /* module that detected the error.  */
  END
_errtext=' SYSCALL RETVAL='_retval 'ERRNO='_errno'('err.se_errno')',
         'ERRNOJR='_errnojr'('err.se_reason')' err.se_action
_sigl = sigl
SIGNAL RXERROR1                    /* Drive RXERROR internal entry pnt*/

/*--------------------------------------------------------------------*/
/* RXCOPY routines follow (in alphabetical order)                     */
/*--------------------------------------------------------------------*/

/*RXCOPY ERRMSGX **** 22 LINES COPIED ON 11/19/99 AT 5:43pm ***********/
/*-Start of ERRMSGX function----------------------------Version-01.03-*/
/*: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, 1999 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 "WTOH '"_errmsgx_errtext"'"
  END
SIGNAL EXIT
/*-End of ERRMSGX  function-------------------------------------------*/

/*RXCOPY KWPARSE **** 128 LINES COPIED ON 11/19/99 AT 5:43pm **********/
/*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.    */
/*     <or>                                                           */
/*   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 KWVALID **** 248 LINES COPIED ON 11/19/99 AT 5:43pm **********/
/*-Start of KWVALID function----------------------------Version-01.03-*/
/*: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) 1997 Washington Systems. 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 = TRANSLATE(ARG(2))

  DO WHILE _kwtypes <> ''
  PARSE VAR _kwtypes _kwtype _kwtypes
  PARSE VAR _kwtype _kwdatatype '(' _kwdataval ')' .

    SELECT

    WHEN _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 = _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 = 'MEMBER' THEN
      DO
      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
      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 _kwtypes,
     _kwupper _kwvalue _kwvnode _kwvrng1 _kwvrng2 _kwvtemp _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 RXERROR **** 129 LINES COPIED ON 11/19/99 AT 5:43pm **********/
/*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,1999 Washington Systems. 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------------------------------------------------------*/
/*END OF RXERROR------------------------------------------------------*/
max_rc = 12
SIGNAL EXIT