/*---------Language: REXX-------------------------------------$$PROLOG*/ /* Program Name: SIMULATE.CMD */ /* Description: Read the AutoMate host message log, and issue */ /* messages you find there. Pause after each msg. */ /* Customization: None */ /* Input Parameters: DEBUG Standard debugging parm... */ /* MODE(INTERACTIVE | BATCH) Used to specify */ /* BATCH: every msg in the logfile is issued */ /* INTERACTIVE: You are prompted for each msg. */ /* This is the default. */ /* LOGFILE(filename) Automation Point host msg log */ /* to be read. You may want to use an editor */ /* to create a file with the msgs you want. */ /* This parm is required. */ /* PARMFILE(filename) Automation Point parmfile. */ /* Use this to point to a different one than */ /* Automation Point is actually using. */ /* Invocation: Operator command */ /* Invokes: XPROMPT.CMD External subroutine used to prompt */ /* for invalid or missing parameters. */ /* CMDRESP.CMD External subroutine used to issue */ /* Windows NT commands and return the */ /* response on the stack. */ /* Return Codes: 0 - Successful Completion */ /* Related Routines: None. */ /* Base Release: CA-Automation Point 3.2 or above. */ /* Restrictions: 1. The entire hostlog must have been produced */ /* with the same Automation Point DISKPREFIX parm*/ /* value - if not, create a new logfile w/ Edit. */ /* 2. Assumed that the AP parmfile has valid syntax.*/ /* Dependencies: 1. Automation Point must be running! */ /* Change log: Add new entries to the top */ /*-----------------Changed 14-JUL-1999 by: Bob Stark -----------------*/ /* 1. Added XPROMPT calls for missing parameters. */ /* 2. Added logic to dynamically determine the PREFIX used to create */ /* the logfile and build a parse template to extract the data from */ /* it, so that different sites can run this without modification. */ /* 3. General doc cleanup for distribution from ProTech web site. */ /*-----------------Changed 15-NOV-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 */ /*--------------------------------------------------------------------*/ CALL ON ERROR NAME RXERROR SIGNAL ON SYNTAX NAME RXERROR SIGNAL ON NOVALUE NAME RXERROR TRACE N debug = '' mode = 'INTERACTIVE' logfile = '' parmfile = '' rc = KWPARSE(ARG(1)) IF rc <> 0 THEN CALL ERRMSGX 'KWPARSE Failed, rc='rc IF debug <> '' THEN TRACE I /*--------------------------------------------------------------------*/ /* Determine the Automation Point parmfile to be read. */ /*--------------------------------------------------------------------*/ parmfile = GETPARMFILE(parmfile) SAY 'Using Automation Point parmfile: 'parmfile /*--------------------------------------------------------------------*/ /* Read the AP parmfile and extract the diskprefix & session list. */ /*--------------------------------------------------------------------*/ diskprefix = GETPREFIX(parmfile) SAY 'Using Automation Point DISKPREFIX='diskprefix /*--------------------------------------------------------------------*/ /* Build a parse template to be used to extract the data from the */ /* logfile. The order of the data in the logfile is controlled by */ /* the DISKPREFIX parameter, so there's no generic way to do this. */ /*--------------------------------------------------------------------*/ CALL PREFIX2PARSE diskprefix /*--------------------------------------------------------------------*/ /* Validate and/or prompt for the host msglog filename, and read it. */ /*--------------------------------------------------------------------*/ logfile = GETLOGFILE(logfile) rc = IOREAD('FILENAME('logfile') STEM(LINE.)') /*--------------------------------------------------------------------*/ /* Copy a few variables created earlier by subroutine calls. */ /*--------------------------------------------------------------------*/ template = VALUE('GBL.0TEMPLATE') statement = VALUE('GBL.0INTERPRET') sessions = VALUE('GBL.0SESSIONS') SAY DO i = 1 TO line.0 /*------------------------------------------------------------------*/ /* Process a line from the hostmsg log, e.g.: */ /* 18:10:33 18:11 R IEF450I LATA207M ABENDED S000 U000 */ /* This uses the dynamic parse template and optional follow-on */ /* statement created earlier to create a set of variables. */ /*------------------------------------------------------------------*/ INTERPRET "PARSE VAR line.i line 1 pctime 9 "template" msgtext" IF statement <> '' THEN INTERPRET statement /*------------------------------------------------------------------*/ /* Validate the variable values for this host message, and create */ /* an argument list for calling ADDRESS AXC MSG ... */ /*------------------------------------------------------------------*/ args = '' IF WORDPOS('ACTION',template) > 0 THEN IF action <> '' THEN args = args'ACTION(YES) ' IF WORDPOS('JOBID',template) > 0 THEN args = args'JOBID('jobid') ' IF WORDPOS('MONNAME',template) > 0 THEN args = args'MONNAME('monname') ' IF WORDPOS('MONNUM',template) > 0 THEN args = args'MONNUM('monnum') ' IF WORDPOS('MONPRTY',template) > 0 THEN args = args'MONPRTY('monprty') ' IF WORDPOS('MONTYPE',template) > 0 THEN args = args'MONTYPE('montype') ' IF WORDPOS('REPLYID',template) > 0 THEN IF replyid <> '' THEN args = args'REPLYID('replyid') ' /*------------------------------------------------------------------*/ /* SESSION is required, and must map to a valid AP session name. */ /* If not available, or not valid, map to 1st session in parm file */ /*------------------------------------------------------------------*/ IF WORDPOS('SESSION',template) = 0 THEN session = WORD(sessions,1) IF WORDPOS(session,sessions) > 0 THEN session = WORD(sessions,1) args = args'SESSION('session') ' IF WORDPOS('SYSNAME',template) > 0 THEN args = args'SYSNAME('sysname') ' IF WORDPOS('TIME',template) > 0 THEN DO time = LEFT(time,6,'0') args = args'TIME('time') ' END msgtext = TRANSLATE(msgtext,'"',"'") /* Single quotes -> doubles */ /*------------------------------------------------------------------*/ /* Pass the simulated message to Automation Point. */ /*------------------------------------------------------------------*/ IF mode = 'INTERACTIVE' THEN DO SAY "Issue MSG '"msgtext"' "args" ?" PULL ans IF LEFT(ans,1) = 'Q' THEN LEAVE i /* Request to Quit? */ IF LEFT(ans,1) = 'Y' THEN ADDRESS AXC "MSG '"msgtext"' "args END ELSE DO SAY "Issuing MSG '"msgtext"' "args ADDRESS AXC "MSG '"msgtext"' "args END END i IF mode = 'BATCH' THEN SAY "Issued "line.0" messages" EXIT: IF SYMBOL('max_rc') = 'LIT' THEN max_rc = 0 EXIT max_rc /*-Start of FILEXIST function-----------------------------------------*/ /*:FILEXIST Function - Determines if a file exists or not. */ /* Parameters: filename */ /* Returns: 1 or 0. 1 means that it exists. */ /* For example: */ /* IF FILEXIST('C:\AUTOEXEC.BAT') = 1 THEN SAY "Okay, it's there" */ /*--------------------------------------------------------------------*/ FILEXIST: PROCEDURE EXPOSE gbl. DO QUEUED(); PULL .; END rc = CMDRESP('@DIR 'ARG(1)' /B') IF QUEUED() < 1 THEN RETURN 0 /* no STDOUT returned, error msg */ PULL output DO QUEUED(); PULL .; END IF output <> 'FILE NOT FOUND' THEN RETURN 1 RETURN 0 /*-Start of GETLOGFILE function---------------------------------------*/ /*:GETLOGFILE Function - Validate of prompt for the name of the AP */ /* host msg logfile to be used in the simulation. */ /* Parameters: user-provided logfile name, or null. */ /* Returns: Fully qualified filename. */ /* For example: */ /* logfile = GETLOGFILE(logfile) */ /*--------------------------------------------------------------------*/ GETLOGFILE: PROCEDURE EXPOSE gbl. logfile = ARG(1) axc_path = XGETENV('AXC_PATH') IF logfile <> '' THEN /* Did caller provide a filename? */ DO /* Yes, see if it exists. */ IF FILEXIST(logfile) = 1 THEN RETURN logfile IF POS('\',logfile) = 0 & axc_path <> '' THEN IF FILEXIST(axc_path'\'logfile) = 1 THEN RETURN axc_path'\'logfile logfile = '' /* User-specified file not found */ END /*--------------------------------------------------------------------*/ /* We're now out of tricks, so we'll break down and prompt the user */ /* for the logfile name. */ /*--------------------------------------------------------------------*/ DO i = 1 BY 1 logfile = XPROMPT(, "PROMPT(Enter Automation Point logfile name or 'CANCEL')", "DEFAULT(CANCEL)") IF logfile = 'CANCEL' THEN CALL ERRMSGX 'Aborted by user request' IF FILEXIST(logfile) = 1 THEN RETURN logfile IF FILEXIST(axc_path'\'logfile) = 1 THEN RETURN axc_path'\'logfile SAY logfile 'File not found' END i RETURN '' /* We should never take this RETURN*/ /*-Start of GETPARMFILE function--------------------------------------*/ /*:GETPARMFILE Function - Determines the name of the current */ /* Automation Point parmfile, or prompts for it. */ /* Parameters: user-provided parmfile name, or null. */ /* Returns: Fully qualified filename. */ /* For example: */ /* parmfile = GETPARMFILE(parmfile) */ /*--------------------------------------------------------------------*/ GETPARMFILE: PROCEDURE EXPOSE gbl. parmfile = ARG(1) axc_path = XGETENV('AXC_PATH') axc_sw = XGETENV('AXC_SW') IF parmfile <> '' THEN /* Did caller provide a filename? */ DO /* Yes, see if it exists. */ IF FILEXIST(parmfile) = 1 THEN RETURN parmfile IF POS('\',parmfile) = 0 & axc_path <> '' THEN IF FILEXIST(axc_path'\'parmfile) = 1 THEN RETURN axc_path'\'parmfile parmfile = '' /* User-specified file not found */ END /*--------------------------------------------------------------------*/ /* If AXC_SW exists, it might contain the parmfile name. Take a look.*/ /*--------------------------------------------------------------------*/ IF axc_path <> '' & axc_sw <> '' THEN DO DO i = 1 TO WORDS(axc_sw) IF LEFT(WORD(axc_sw,i),1) = '/' /* Is it a switch? */ THEN ITERATE i /* Yes, skip over it. */ parmfile = WORD(axc_sw,i) /* Else, it's a parmfile */ END i IF parmfile <> '' THEN IF FILEXIST(axc_path'\'parmfile) = 1 THEN RETURN axc_path'\'parmfile parmfile = '' /* parmfile not found (yet) */ END IF axc_path <> '' THEN DO i = 1 TO 1 /* Loop so we can use LEAVE i */ /*------------------------------------------------------------------*/ /* Determine the filename of the currently running copy of */ /* Automation Point. This involves: */ /* 1. Copying the current "saved desktop" file, AUTOMATE.SAV */ /* 2. Saving the Automation Point desktop. */ /* 3. Reading the newly updated "saved desktop" file, which */ /* contains the parmfile name. */ /* 4. Restoring the original "saved desktop" file, if it existed. */ /*------------------------------------------------------------------*/ origdesk.0 = 0 /* Assume desktop never saved yet */ rc = IOREAD('FILENAME('axc_path'\AUTOMATE.SAV) STEM(ORIGDESK.)') IF rc <> 0 THEN IF TRANSLATE(rc) <> 'FILE NOT FOUND' THEN CALL ERRMSGX 'Unable to read AUTOMATE.SAV, rc='rc ok = 'ALL' ADDRESS AXC "SESSCMD '"'@"SCREEN_SAVE"'"' SESSION(AXC)" IF rc <> 0 THEN DO SAY 'Unable to communicate with Automation Point, SESSCMD rc='rc LEAVE i END ADDRESS AXC "WAIT 5" rc = IOREAD('FILENAME('axc_path'\AUTOMATE.SAV) STEM(NEWDESK.)', 'RECORDS(1)') IF rc <> 0 THEN CALL ERRMSGX 'Unable to read new AUTOMATE.SAV, rc='rc PARSE VAR NEWDESK.1 parmfile . parmfile = axc_path'\'parmfile IF ORIGDESK.0 > 0 THEN DO rc = IOWRITE('FILENAME('axc_path'\AUTOMATE.SAV) STEM(ORIGDESK.)') IF rc <> 0 THEN CALL ERRMSGX 'Unable to rewrite orig AUTOMATE.SAV, rc='rc END RETURN parmfile END i /*--------------------------------------------------------------------*/ /* We're now out of tricks, so we'll break down and prompt the user */ /* for the parmfile name. */ /*--------------------------------------------------------------------*/ DO i = 1 BY 1 parmfile = XPROMPT(, "PROMPT(Enter Automation Point parmfile name or 'CANCEL')", "DEFAULT(CANCEL)") IF parmfile = 'CANCEL' THEN CALL ERRMSGX 'Aborted by user request' IF FILEXIST(parmfile) = 1 THEN RETURN parmfile IF FILEXIST(axc_path'\'parmfile) = 1 THEN RETURN axc_path'\'parmfile SAY parmfile 'File not found' END i RETURN '' /* We should never take this RETURN*/ /*-Start of GETPREFIX function----------------------------------------*/ /*:GETPREFIX Function - Determines the value for the hostlog prefix */ /* that will be used in a given Automation Point parmfile. */ /* Parameters: parmfile name */ /* Returns: prefix value. */ /* Creates: GBL.0SESSIONS <-- List of sessions used in parmfile */ /*--------------------------------------------------------------------*/ GETPREFIX: PROCEDURE EXPOSE GBL. parmfile = ARG(1) /*--------------------------------------------------------------------*/ /* Now we read the parm file itself. */ /*--------------------------------------------------------------------*/ rc = IOREAD('FILENAME('parmfile') STEM(line.)') IF rc <> 0 THEN CALL ERRMSGX 'Unable to read new parmfile 'parmfile', rc='rc /*--------------------------------------------------------------------*/ /* Collapse comments and blank lines out of the file. */ /*--------------------------------------------------------------------*/ j = 0 DO i = 1 TO line.0 IF LEFT(STRIP(LINE.i),1) = '*' THEN ITERATE /*------------------------------------------------------------------*/ /* Collapse any embedded comments out of this line, before saving it*/ /*------------------------------------------------------------------*/ line = line.i DO WHILE POS('/*',line) > 0 PARSE VAR line left '/*' comment '*/' right LINE = left''right END IF STRIP(line) = '' THEN ITERATE j = j + 1 IF i > j THEN line.j = line END DO k = j+1 TO line.0 DROP line.k END line.0 = j /*--------------------------------------------------------------------*/ /* Set default values for the keywords we're searching for (if N/A) */ /*--------------------------------------------------------------------*/ prefix = "SSSSSSSS TTTTTT JJJJJJJJ RRA" diskprefix = "" disklog = "NO" sessions = "" /*--------------------------------------------------------------------*/ /* Now run through the reduced parmfile and parse out the data. */ /*--------------------------------------------------------------------*/ DO i = 1 TO line.0 /* SAY line.i */ line = line.i DO WHILE line <> '' PARSE VAR line kw '=' value kw = TRANSLATE(STRIP(kw)) value = STRIP(value) SELECT WHEN LEFT(value,2) = "('" THEN PARSE VAR value "('" value "')" ',' line WHEN LEFT(value,1) = "'" THEN PARSE VAR value "'" value "'" ',' line WHEN LEFT(value,1) = "(" THEN PARSE VAR value "(" value ")" ',' line OTHERWISE PARSE VAR value value ',' line END /* SELECT */ IF kw = 'PREFIX' THEN prefix = value IF kw = 'DISKPREFIX' THEN diskprefix = value IF kw = 'DISKLOG' THEN disklog = value IF kw = 'SESSION' THEN sessions = SPACE(sessions' 'value,1) END /* DO WHILE line <> '' */ END IF disklog = 'NO' THEN SAY 'Warning, host log not enabled in AP parmfile 'parmfile IF diskprefix = '' THEN diskprefix = prefix CALL VALUE 'GBL.0SESSIONS',sessions RETURN diskprefix /*-Start of XGETENV Function -----------------------------------------*/ /*:XGETENV Function - Returns the value of an environment variable. */ /* Parameters: environment variable name */ /* Returns: Value of variable, or null if error or not/found */ /* For example: */ /* value = XGETENV('TMP') */ /*--------------------------------------------------------------------*/ XGETENV: PROCEDURE EXPOSE gbl. the_environment SELECT WHEN RIGHT(GETENV(),3) = 'ONT' THEN /* Automation Point REXX */ DO result = VALUE(ARG(1),,'DOSENVIRONMENT') END WHEN WORDPOS(RIGHT(GETENV(),3),'WNT OS2') > 0 THEN DO /* IBM Object REXX or OS/2 REXX */ result = VALUE(ARG(1),,'ENVIRONMENT') END OTHERWISE SAY 'ERROR: XGETENV() called from unsupported environment:' GETENV() result = '' END RETURN result /*-Start of PREFIX2PARSE Subroutine ----------------------------------*/ /*:PREFIX2PARSE Subroutine - Converts an Automation Point PREFIX parm */ /* into a parse template that can be used to extract information from */ /* any messages logged using that PREFIX. */ /* Parameters: prefix */ /* Returns: 0 */ /* Creates: GBL.0TEMPLATE */ /* GBL.0INTERPRET */ /* For example: */ /* CALL PREFIX2PARSE 'TT:TT:TT PPPP JJJJJJJJARR' */ /*--------------------------------------------------------------------*/ PREFIX2PARSE: PROCEDURE EXPOSE gbl. TRACE N prefix = 'ZZZZZZZZZ'ARG(1) /* Account for HH:MM:SS on front */ template = '' vars = '' start = 1 end = LENGTH(prefix) /*------------------------------------------------------------------*/ /* Scan across the prefix to find the discontinuous breaks in it. */ /*------------------------------------------------------------------*/ DO i = 1 TO end this = SUBSTR(prefix,i,1) /* Get current PREFIX character */ IF i < end THEN /* Note that last char IS a break */ DO next = SUBSTR(prefix,i+1,1) IF this = next THEN ITERATE i /* Not a break, skip to next char */ END var = PREFIX2VAR(this) /* Get associated varname for char */ IF var = '' THEN /* Is there a variable? */ DO /* No, this is a noise character, */ start = i+1 /* like ':', so update the start */ ITERATE i /* point and skip over it. */ END IF SYMBOL(var) = 'LIT' THEN /* Was this variable seen earlier? */ DO /* No. Append to PARSE template */ template = template start var i+1 CALL VALUE var,1 /* Remember that we've seen it once*/ END ELSE DO /* Yes. Parse to an auxiliary var */ n = VALUE(var)+1 /* Get next aux varname */ CALL VALUE var,n /* Update count for next time */ IF WORDPOS(var,vars) = 0 /* Is this var in aux var list? */ THEN vars = vars' 'var /* No, add it to list and */ template = template start var''n i+1 /* append to PARSE template */ END start = i+1 /* Update with new start position */ END i CALL VALUE 'GBL.0TEMPLATE',template /* Save parse template */ /*--------------------------------------------------------------------*/ /* If we used any auxiliary variables, then build a set of statements */ /* to be executed AFTER the parse; This will "glue" all of the aux */ /* variables back onto the primary variable. */ /*--------------------------------------------------------------------*/ statement = '' DO i = 1 TO WORDS(vars) var = WORD(vars,i) statement = statement''var'='var DO j = 2 TO VALUE(var) statement = statement"''"var""j END j statement = statement";" END i CALL VALUE 'GBL.0INTERPRET',statement RETURN 0 /*-Start of PREFIX2VAR function --------------------------------------*/ /*:PREFIX2VAR Function - Return the assocated variable name for a */ /* given PREFIX character. */ /*--------------------------------------------------------------------*/ PREFIX2VAR: PROCEDURE TRACE N IF LENGTH(ARG(1)) > 1 THEN DO SAY 'ERROR, > 1 char passed to PREFIX2VAR' RETURN '' END needle = ARG(1)'=' PARSE VALUE '3=SYSNAME A=ACTION C=MONTYPE E=MONPRTY H=MONNAME', 'J=JOBID N=MONNUM P=SYSNAME R=REPLYID S=SESSION', 'T=TIME', WITH (needle) varname . RETURN varname /*--------------------------------------------------------------------*/ /* RXCOPY routines follow (in alphabetical order) */ /*--------------------------------------------------------------------*/ /*RXCOPY ERRMSGX **** 22 LINES COPIED ON 07-11-99 AT 05:52*************/ /*-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 **** 158 LINES COPIED ON 07-11-99 AT 05:52*************/ /*-Start of GETENV subroutine---------------------------Version-01.09-*/ /*: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 */ /* 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: 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 . _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 SYMBOL('IMFENAME') SYMBOL('IMFORGN') = 'VAR VAR' THEN DO; the_environment = 'IMF'; 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 CALL OFF ERROR /* Turn off error handler */ CALL OFF FAILURE /* Turn off error handler */ 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 AFOPER? */ 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) */ 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 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. RETURN the_environment /*-End of GETENV subroutine-----------------------------------------*/ /*RXCOPY ISPFLMF **** 28 LINES COPIED ON 07-11-99 AT 05:52*************/ /*-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 07-11-99 AT 05:52************/ /*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 RXERROR **** 122 LINES COPIED ON 07-11-99 AT 05:52************/ /*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 /*RXCOPY IOSUBS **** 1052 LINES COPIED ON 07-11-99 AT 05:52************/ /*Start of IOSUBS Routines------------------------------Version-01.10-*/ /* IOSUBS is a collection of multi-platform REXX I/O routines, */ /* supporting TSO/E REXX, OPS/REXX, MVS ISPF, NetView, OS/2, WinNT/95,*/ /* and DOS. */ /* IOREAD Reads data into a REXX stemmed variable. */ /* IOWRITE Writes data from a REXX stemmed variable to a dataset. */ /* Note 1: This routine calls GETENV() and ISPFLMF(), so you must */ /* RXCOPY them into your routine. */ /* Copyright (C) 1996,1998 Washington Systems. All rights reserved. */ /*--------------------------------------------------------------------*/ OPTIONS 'OPSWXTRN=OPSSVC99' /*:IOREAD Function - reads a sequential file or PDS member into a */ /* stem variable. */ /* Parms: */ /* DDNAME('ddname') MVS only. Mutually exclusive w/ FILENAME()*/ /* If under ISPF, must be true sequential. */ /* FILENAME('fully qualified name of a partitioned dataset') */ /* ' relative or full path name of a file.' */ /* LEAVEOPEN(YES | NO) If yes, file is kept open so that */ /* additional records can be read. */ /* Default: LEAVEOPEN(NO). */ /* LEAVEALLOC(YES | NO) If yes, file is kept allocated to speed up */ /* future access to same file. */ /* Default: LEAVEALLOC(NO). */ /* RECORDS(ALL | n) Number of records to read. Use RECORDS(0) */ /* to close file w/o read. */ /* Default: RECORDS(ALL). */ /* STEM(line.) Stem variable name to contain data. */ /* Default: STEM(LINE.). */ /* TOKENVAR('rexx variable name') A token is required when you will*/ /* make several related IOREAD() calls for */ /* the same file, using LEAVEOPEN(YES) or */ /* LEAVEALLOC(YES). Default: no token. */ /* USE(SHR | EXCL) Controls serialization of the file. */ /* USE(EXCL) LEAVEOPEN(YES) can be used when */ /* you want to update a file with IOWRITE(). */ /* Ignored if running outside of MVS. */ /* Default: USE(SHR). */ /* Example: rc=IOREAD('FILENAME(SYS1.PARMLIB(CONSOL00)) STEM(LINE.) */ /* Returns: 0: Data read okay. */ /* text: Error occured, text gives the details. */ /* Note 1: All variables used in this routine should be _hidden. */ /*--------------------------------------------------------------------*/ IOREAD: TRACE N PARSE UPPER ARG 1 ' DEBUG' +0 _debug . , 1 'DDNAME(' _ddname ')' 1 'FILENAME(' _filename ')', 1 'LEAVEALLOC(' _leavealloc ')' 1 'LEAVEOPEN(' _leaveopen ')', 1 'RECORDS(' _records ')' 1 'STEM(' _stem ')', 1 'TOKENVAR(' _tokenvar ')' 1 'USE(' _use ')' IF _debug <> '' THEN TRACE I IF _filename = '' & _ddname = '' THEN RETURN 'Missing FILENAME() or DDNAME() parm' /* See if filename is an MVS PDS name. If so, isolate member name */ PARSE VAR _filename _dsname '(' _member ')' /* If dataset is a PDS, add trailing paren to terminate member name */ IF _member <> '' THEN _filename = _filename')' IF _leaveopen = '' THEN _leaveopen = 'NO' /* Default LEAVEOPEN(NO) */ IF WORDPOS(_leaveopen,'YES NO') = 0 THEN RETURN 'Invalid LEAVEOPEN() parm value' IF _leavealloc = '' THEN _leavealloc = _leaveopen /*set LEAVEALLOC(NO)*/ IF WORDPOS(_leavealloc,'YES NO') = 0 THEN RETURN 'Invalid LEAVEALLOC() parm value' IF _records = '' THEN _records = 'ALL' /* Default RECORDS(ALL) */ IF _records <> 'ALL' THEN IF DATATYPE(_records) <> 'NUM' THEN RETURN 'Invalid RECORDS() parm value' IF _stem = '' THEN _stem = 'line.' /* Default STEM(LINE.) */ IF RIGHT(_stem,1) <> '.' THEN _stem = _stem'.' IF _tokenvar = '' THEN IF _leaveopen = 'YES' | _leavealloc = 'YES' THEN RETURN 'Missing TOKENVAR() parm, required if LEAVEALLOC(YES) or', 'LEAVEOPEN(YES) specified' CALL IOSUBS_GETTOKEN /* Initialize _status */ _ddnm = _ddname /* Copy caller-passed DDNAME */ IF _ddname = '' THEN /* DDNAME(xx) passed or saved?*/ IF _tokenvar <> '' /* No. Was token passed? */ THEN _ddnm = LEFT(_tokenvar,8) /* Yes, use as DDNAME */ ELSE _ddnm = 'IORD'RANDOM(9999) /* No, Generate random DDNAME*/ IF _use = '' THEN _use = 'SHR' /* Default USE(SHR) */ IF WORDPOS(_use,'SHR EXCL') = 0 THEN RETURN 'Invalid USE() parm value' _ioread_rc = 0 /* Initialize return code */ CALL VALUE _stem'0',0 /* Initialize stem.0 */ /*--------------------------------------------------------------------*/ /* P C - B A S E D R E X X S E G M E N T (O S / 2, D O S, E T C)*/ /*--------------------------------------------------------------------*/ IF WORDPOS(RIGHT(GETENV(),3),'OS2 DOS WNT W95 ONT') = 0 THEN SIGNAL IOREAD_NOTOS2 IF _status = 'OPEN' /* Was file left open? */ THEN SIGNAL IOREAD_OS2_READIT /* Yes, start reading it. */ /* Warning, calling QUERY EXISTS in NT on open file resets read ptr! */ IF STREAM(_filename,'C','QUERY EXISTS') = '' /* Does file exist? */ THEN RETURN 'File not found' /* No, can't read it. */ IF _use = 'SHR' THEN _o = STREAM(_filename,'C','OPEN READ') IF _use = 'EXCL' THEN _o = STREAM(_filename,'C','OPEN') IF _o = 'NOTREADY:32' /* File in use by another pgm? */ THEN RETURN 'File in use' /* Yes, return error text */ IF ABBREV(_o,'READY') <> 1 /* Is file ready? */ THEN RETURN 'File not ready:'_o /* No, return error text */ CALL LINEIN _filename,1,0 /* Position file to line 1 */ IOREAD_OS2_READIT: DO _i = 1 BY 1 WHILE LINES(_filename) > 0 /* Don't read past EOF */ IF _records <> 'ALL' THEN /* Do we have RECORDS(n) limit?*/ IF _i > _records /* Yes, are we about to exceed?*/ THEN SIGNAL IOREAD_OS2_SET0 /* Exit if exceeds record count*/ _data = LINEIN(_filename) /* Read a line from the file. */ CALL VALUE _stem''_i,_data /* Store the data in stem var */ END _i /* DO _i = 1 BY 1 */ IF _records <> 'ALL' THEN _ioread_rc = 'EOF' /*Only EOF if RECORDS(n) */ IOREAD_OS2_SET0: CALL VALUE _stem'0',_i-1 /* Save lines read in stem.0 */ IF _leaveopen <> 'YES' THEN /* Are we to leave file open? */ DO CALL STREAM _dsname,'C','CLOSE' /* No, close the file */ CALL IOSUBS_PUTTOKEN '' /* Remove STATUS from token */ END ELSE /* If we are leaving file open,*/ CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)' /* add STATUS(OPEN) to token. */ DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records, _data _filename _o _leavealloc _leaveopen _stem _use RETURN _ioread_rc IOREAD_NOTOS2: /*--------------------------------------------------------------------*/ /* I S P F c o d e s e g m e n t f o r I O R E A D. */ /*--------------------------------------------------------------------*/ IF ISPFLMF() <> 'YES' THEN SIGNAL IOREAD_NOTISPF ADDRESS ISPEXEC 'CONTROL ERRORS RETURN' IF SYMBOL('ZDATAIDZ') = 'LIT' THEN DO ok = '8' IF _ddname <> '' /* Was DDNAME() passed in? */ THEN ADDRESS ISPEXEC 'LMINIT DATAID(ZDATAIDZ) DDNAME('_ddname')' ELSE ADDRESS ISPEXEC 'LMINIT DATAID(ZDATAIDZ) ENQ(SHR)', "DATASET('"_dsname"')" IF rc > 0 THEN RETURN STRIP(ZERRSM) /* LMINIT failed, return error */ CALL IOSUBS_PUTTOKEN 'DATAID('VALUE(ZDATAIDZ)')' /* Save dataid */ END /* Extract the LRECL of the dataset we are reading */ ok = 4 /* rc=4 if some vars are blank */ ADDRESS ISPEXEC 'LMQUERY DATAID('ZDATAIDZ') OPEN(ZOPENZ)' IF rc > 4 THEN RETURN STRIP(ZERRSM) IF _status = 'OPEN' /* Was file left open? */ THEN SIGNAL IOREAD_SPF_READIT /* Yes, start reading it. */ ADDRESS ISPEXEC 'LMOPEN DATAID('ZDATAIDZ') OPTION(INPUT) LRECL(ZLRECLZ)' IF rc > 0 THEN RETURN STRIP(ZERRLM) IF _member <> '' THEN DO IF _tokenvar <> '' /* If token was passed, */ THEN _stats = 'YES' /* then copy stats to token */ ELSE _stats = 'NO' /* Else don't bother. */ /*------------------------------------------------------------------*/ /* Position to desired member. */ /*------------------------------------------------------------------*/ OK='8 12';ADDRESS ISPEXEC 'LMMFIND DATAID('ZDATAIDZ')', 'MEMBER('_member')', 'STATS('_stats')'; DROP OK IF rc >= 8 THEN DO IF rc > 8 THEN IF SYMBOL('ZERRLM') = 'VAR' THEN _ioread_rc = STRIP(ZERRLM) ELSE _ioread_rc = 'LMMFIND FAILED RC='rc ELSE _ioread_rc = 'Member not found' _i = 1 SIGNAL IOREAD_SPF_SET0 /* Exit if exceeds record count */ END IF _stats = 'YES' THEN DO _statlist = 'zlvers zlmod zlcdate zlmdate zlmtime', 'zlmsec zlcnorc zlinorc zlmnorc zluser' DO _i = 1 TO WORDS(_statlist) _stat = WORD(_statlist,_i) IF SYMBOL(_stat) = 'VAR' THEN CALL IOSUBS_PUTTOKEN _stat'('VALUE(_stat)')' END _i END END IOREAD_SPF_READIT: DO _i = 1 BY 1 /* Read each record from the file */ IF _records <> 'ALL' THEN /* Do we have RECORDS(n) limit? */ IF _i > _records /* Yes, are we about to exceed? */ THEN SIGNAL IOREAD_SPF_SET0 /* Exit if exceeds record count */ ok = 8 ADDRESS ISPEXEC 'LMGET DATAID('ZDATAIDZ') MODE(INVAR)', 'DATALOC(ZDATAZ) DATALEN(ZDATALNZ) MAXLEN('ZLRECLZ')' ok = 0 IF RC = 8 THEN /* End of file... */ DO IF _records <> 'ALL' /* Was RECORDS(n) specified? */ THEN _ioread_rc = 'EOF' /* Yes, return 'EOF'. */ LEAVE END CALL VALUE _stem''_i,ZDATAZ END _i /* DO _i = 1 BY 1 */ IOREAD_SPF_SET0: CALL VALUE _stem'0',_i-1 IF _leaveopen <> 'YES' THEN /* Are we to leave file open? */ DO /* No, close it. */ ADDRESS ISPEXEC 'LMCLOSE DATAID('ZDATAIDZ')' CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)' /* Change to STATUS(ALLOC) */ END ELSE /* If we are leaving file open,*/ CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)' /* add STATUS(OPEN) to token. */ IF _leavealloc <> 'YES' THEN DO ADDRESS ISPEXEC 'LMFREE DATAID('ZDATAIDZ')' CALL IOSUBS_PUTTOKEN '' /* Remove all data from token */ END DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records, _data _filename _o _leavealloc _leaveopen _stem _use zdataidz, _tokenvar _tempid RETURN _ioread_rc IOREAD_NOTISPF: /*--------------------------------------------------------------------*/ /* T S O c o d e s e g m e n t f o r I O R E A D. */ /*--------------------------------------------------------------------*/ IF RIGHT(GETENV(),3) <> 'TSO' & POS(GETENV(),'OPSREXX') = 0 THEN SIGNAL IOREAD_NOTTSO IF WORDPOS(_status,'ALLOC OPEN') > 0 THEN /* File already ALLOCd? */ SIGNAL IOREAD_TSO_ALLOCD /* Yes, skip validation. */ IF _ddname <> '' THEN /* Was DDNAME() passed in? */ DO /* Yes. Is it allocated? */ IF RIGHT(GETENV(),3) = 'TSO' THEN /* Running in TSO/E? */ DO /* Use TSO/E LISTDSI() function*/ INTERPRET "rc = LISTDSI('"_ddname" FILE NODIRECTORY NORECALL')" IF rc > 4 THEN RETURN LISTDSIREASON(sysreason) END IF POS(GETENV(),'OPSREXX') > 0 THEN IF LEFT(OPSINFO('VERSION'),5) >= '04.01' THEN INTERPRET "IF OPSDD2DS(_ddname) = ''", "THEN RETURN 'DDNAME('_ddname') not allocated'" ELSE DO CALL OPSCLEDQ ok = '12' ADDRESS TSO "LISTALC STATUS" _ddfound = 0 _search4 = ' 'LEFT(_ddname,8,' ')' ' DO WHILE QUEUED() > 0 PARSE UPPER PULL (_search4) _msg IF _msg <> '' THEN _ddfound = 1 END IF _ddfound <> 1 THEN RETURN 'DDNAME('_ddname') not allocated' END SIGNAL IOREAD_TSO_ALLOCD /* Start reading it... */ END _disp = _use IF _use = 'EXCL' THEN _disp = 'OLD' IF RIGHT(GETENV(),3) = 'TSO' THEN /* Running in TSO/E? */ DO /* Use TSO/E SYSDSN() function */ INTERPRET "_msg_status=MSG('OFF')"/*Interpret to hide from OPS/REXX */ INTERPRET "rc = SYSDSN('''"_filename"''')" IF rc <> 'OK' THEN IF rc = 'UNAVAILABLE DATASET' THEN RETURN 'File in use' ELSE RETURN rc 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*/ RETURN 'IOREAD error: OUTTRAP() Active and cannot be used' END END INTERPRET "x = OUTTRAP('_outtrap.','*','NOCONCAT')" INTERPRET "CALL MSG('ON')" ok = '12' ADDRESS TSO "ALLOC FILE("_ddnm") DSNAME('"_filename"')", "REUSE "_disp END IF POS(GETENV(),'OPSREXX') > 0 THEN DO IF _member <> '' THEN /* Is this a PDS? */ DO /* Yes */ _rc = OPSPDS('EXISTS', _dsname, _member) IF _rc <> 0 THEN RETURN 'Member not found' END IF LEFT(OPSINFO('VERSION'),5) >= '04.01' THEN DO rc = OPSSVC99('ALLOC',_ddnm,_filename,_disp) IF rc <> 0 THEN DO; _ioread_rc = 'Allocate failed'; SIGNAL IOREAD_TSO_EXIT; END END ELSE DO CALL OPSCLEDQ ok = '12' ADDRESS TSO "ALLOC FILE("_ddnm") DSNAME('"_filename"')", "REUSE "_disp DO _i = 1 BY 1 WHILE QUEUED() > 0 PARSE UPPER PULL _msg _outtrap._i = _msg END _i _outtrap.0 = _i-1 END END IF rc <> 0 THEN DO _i = _outtrap.0 _ioread_rc = _outtrap._i IF _ioread_rc = 'DATA SET IS ALLOCATED TO ANOTHER JOB OR USER' THEN _ioread_rc = 'File in use' IF _i = 0 THEN _ioread_rc = 'Allocate failed' SIGNAL IOREAD_TSO_EXIT END IOREAD_TSO_ALLOCD: _howmany = _records IF _records = 'ALL' THEN _howmany = '*' _options = '' IF _leaveopen <> 'YES' THEN _options = _options'FINIS ' ok = '2' ADDRESS TSO 'EXECIO '_howmany' DISKR '_ddnm, ' ('_options' STEM '_stem')' IF rc = 2 THEN ioread_rc = 'EOF' IF _leavealloc <> 'YES' THEN DO IF POS(GETENV(),'OPSREXX') > 0 THEN IF LEFT(OPSINFO('VERSION'),5) >= '04.01' THEN INTERPRET "CALL OPSSVC99 'FREE',_ddnm" ELSE ADDRESS TSO 'FREE FILE('_ddnm')' ELSE ADDRESS TSO 'FREE FILE('_ddnm')' CALL IOSUBS_PUTTOKEN '' /* Remove all data from token */ END ELSE /* Leaving file OPEN or ALLOC? */ IF _leaveopen = 'YES' /* Yes, update the TOKEN */ THEN DO CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')' CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)' END ELSE DO CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')' CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)' END IOREAD_TSO_EXIT: IF SYMBOL('_savtrap') = 'VAR' THEN INTERPRET _savtrap /* Restore caller's OUTTRAP status */ IF SYMBOL('_msg_status') = 'VAR' THEN INTERPRET "CALL MSG _msg_status" /* Restore caller's MSG() status*/ DROP _msg_status _savtrap _tokenvar _tempid _ddfound _search4 DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records, _data _filename _o _leavealloc _leaveopen _stem _use RETURN _ioread_rc IOREAD_NOTTSO: /*--------------------------------------------------------------------*/ /* N E T V I E W c o d e s e g m e n t f o r I O R E A D. */ /*--------------------------------------------------------------------*/ IF GETENV() <> 'NETVMVS' THEN SIGNAL IOREAD_NOTNETV IF WORDPOS(_status,'ALLOC OPEN') <> 0 /* File already ALLOCd? */ THEN SIGNAL IOREAD_NETV_ALLOCD /* Yes, skip validation. */ IF _ddname <> '' THEN /* Was DDNAME() passed in? */ DO /* Yes. Is it allocated? */ /*------------------------------------------------------------------*/ /* CNM271I FOOBAR DD STATEMENT MISSING */ /* -or- */ /* CNM299I */ /* DDNAME DATA SET NAME DISP*/ /* -------- --------------------------------------------------- --- */ /* DSIPARM DC2P.NETVIEW.V3R1.NETOG.DSIPARM SHR */ /*------------------------------------------------------------------*/ ADDRESS NETVIEW 'PIPE NETVIEW LISTA '_ddname, ' | SEPARATE ', /* Convert multi-line to single */ ' | STEM _ioreadout.' /* Place results into global vars */ IF ABBREV(_ioreadout.1,'CNM271I') = 1 THEN RETURN 'DDNAME('_ddname') not allocated' IF ABBREV(_ioreadout.1,'CNM299I') <> 1 THEN RETURN 'DDNAME('_ddname') not allocated' SIGNAL IOREAD_NETV_ALLOCD /* Start reading it... */ END _disp = _use IF _use = 'EXCL' THEN _disp = 'OLD' /*--------------------------------------------------------------------*/ /* CNM272I TEST IS NOW ALLOCATED */ /* DSI370I ALLOCATE COMMAND FAILED, 'IORD2941' IS ALREADY IN USE */ /* CNM277I DATA SET DKZB2CC.FLA NOT FOUND */ /* CNM278I DATA SET DKZB2CC.CLIST UNAVAILABLE */ /*--------------------------------------------------------------------*/ DO _ioreadi = 1 TO 2 'PIPE NETVIEW ALLOC FILE('_ddnm') DS('_filename') '_disp, ' | SEPARATE ', /* Convert multi-line to single */ ' | STEM _ioreadout.' /* Place results into global vars */ IF ABBREV(_ioreadout.1,'DSI370I') <> 1 THEN LEAVE _ioreadi IF _ioreadi = 1 THEN DO ADDRESS NETVIEW 'PIPE NETVIEW FREE FILE('_ddnm')' ITERATE _ioreadi END _ioread_rc = 'Unable to REUSE File('_ddnm')' SIGNAL IOREAD_NETV_EXIT END _ioreadi _i = _ioreadout.0 /* -> last line of ALLOC output */ SELECT WHEN ABBREV(_ioreadout._i,'CNM272I') = 1 THEN SIGNAL IOREAD_NETV_ALLOCD WHEN ABBREV(_ioreadout._i,'CNM278I') = 1 THEN _ioread_rc = 'File in use' WHEN _i = 0 THEN _ioread_rc = 'Allocate failed' OTHERWISE _ioread_rc = SUBWORD(_ioreadout._i,2) END SIGNAL IOREAD_NETV_EXIT IOREAD_NETV_ALLOCD: _howmany = _records IF _records = 'ALL' THEN _howmany = '*' _options = '' IF _leaveopen <> 'YES' THEN _options = _options'FINIS ' ok = '2' ADDRESS MVS 'EXECIO '_howmany' DISKR '_ddnm, ' ('_options' STEM '_stem')' IF rc = 2 THEN ioread_rc = 'EOF' IF _leavealloc <> 'YES' THEN DO ADDRESS NETVIEW 'PIPE NETVIEW FREE FILE('_ddnm')' CALL IOSUBS_PUTTOKEN '' /* Remove all data from token */ END ELSE /* If we are leaving file around, save data in token */ IF _leaveopen = 'YES' THEN DO CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')' CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)' END ELSE DO CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')' CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)' END IOREAD_NETV_EXIT: IF SYMBOL('_savtrap') = 'VAR' THEN INTERPRET _savtrap /* Restore caller's OUTTRAP status */ IF SYMBOL('_msg_status') = 'VAR' THEN INTERPRET "CALL MSG _msg_status" /* Restore caller's MSG() status*/ DROP _msg_status _savtrap _tokenvar _tempid _ddfound _search4 DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records, _data _filename _o _leavealloc _leaveopen _stem _use RETURN _ioread_rc IOREAD_NOTNETV: RETURN 'Unsupported environment 'GETENV() /*--------------------------------------------------------------------*/ /*:IOWRITE Function - writes to a sequential file or MVS PDS member */ /* from a stem variable. This function is cross-platform, supporting:*/ /* TSO/E REXX, OPS/REXX, MVS ISPF, and OS/2. */ /* Parms: */ /* DDNAME('ddname') MVS only. Mutually exclusive w/ FILENAME()*/ /* If under ISPF, must be true sequential. */ /* FILENAME('fully qualified name of a partitioned dataset') */ /* ' relative or full path name of a file.' */ /* LEAVEOPEN(YES | NO) If yes, file is kept open so that */ /* additional records can be added. */ /* Default: LEAVEOPEN(NO). */ /* LEAVEALLOC(YES | NO) If yes, file is kept allocated to speed up */ /* future access to same file. */ /* Default: LEAVEALLOC(NO). */ /* MODE(REPLACE | APPEND) Controls whether file is overwritten or */ /* data is added to end. Default:MODE(REPLACE)*/ /* STEM(line.) Stem variable name with data to be written.*/ /* Default: STEM(LINE.). */ /* TOKENVAR('rexx variable name') A token is required when you will*/ /* make several related IOREAD() or IOWRITE() */ /* calls for the same file, using */ /* LEAVEOPEN(YES) or LEAVEALLOC(YES). */ /* Default: no token. */ /* USE(SHR | EXCL) Controls serialization of the file. Ignored*/ /* if running outside of MVS. */ /* Default: USE(EXCL). */ /* Example: rc=IOWRITE('FILENAME(SYS1.PARMLIB(CONSOL00)) */ /* Returns: 0: Data written okay. */ /* text: Error occured, text gives the details. */ /* Note 1: All variables used in this routine should be _hidden. */ /*--------------------------------------------------------------------*/ IOWRITE: TRACE N PARSE UPPER ARG 1 ' DEBUG' +0 _debug . , 1 'DDNAME(' _ddname ')' 1 'FILENAME(' _filename ')', 1 'LEAVEALLOC(' _leavealloc ')' 1 'LEAVEOPEN(' _leaveopen ')', 1 'MODE(' _mode ')' 1 'STEM(' _stem ')', 1 'TOKENVAR(' _tokenvar ')' 1 'USE(' _use ')' IF _debug <> '' THEN TRACE I IF _filename = '' & _ddname = '' THEN RETURN 'Missing FILENAME() or DDNAME() parm' /* See if filename is an MVS PDS name. If so, isolate member name */ PARSE VAR _filename _dsname '(' _member ')' /* If dataset is a PDS, add trailing paren to terminate member name */ IF _member <> '' THEN _filename = _filename')' IF _leavealloc = '' THEN _leavealloc = 'NO' /* Default LEAVEALLOC(NO) */ IF WORDPOS(_leavealloc,'YES NO') = 0 THEN RETURN 'Invalid LEAVEALLOC() parm value' IF _leaveopen = '' THEN _leaveopen = 'NO' /* Default LEAVEOPEN(NO) */ IF WORDPOS(_leaveopen,'YES NO') = 0 THEN RETURN 'Invalid LEAVEOPEN() parm value' IF _leaveopen = 'YES' THEN _leavealloc = 'YES' /* Set LEAVEALLOC() */ IF _mode = '' THEN _mode = 'REPLACE' /* Default MODE(REPLACE) */ IF WORDPOS(_mode,'REPLACE APPEND') = 0 THEN RETURN 'Invalid MODE() parm value' IF _stem = '' THEN _stem = 'line.' /* Default STEM(LINE.) */ IF RIGHT(_stem,1) <> '.' THEN _stem = _stem'.' IF SYMBOL(_stem'0') <> 'VAR' THEN RETURN 'INVALID STEM() parm value, '_stem'0 not numeric' IF _tokenvar = '' THEN IF _leaveopen = 'YES' | _leavealloc = 'YES' THEN RETURN 'Missing TOKENVAR() parm, required if LEAVEALLOC(YES) or', 'LEAVEOPEN(YES) specified' CALL IOSUBS_GETTOKEN /* Initialize _status */ _ddnm = _ddname /* Copy DDNAME() parm value */ IF _ddname = '' THEN /* DDNAME(xx) passed or saved?*/ IF _tokenvar <> '' /* No. Was token passed? */ THEN _ddnm = LEFT(_tokenvar,8) /* Yes, use as DDNAME */ ELSE _ddnm = 'IOWR'RANDOM(9999) /* No, Generate random DDNAME*/ IF _use = '' THEN _use = 'EXCL' /* Default USE(EXCL) */ IF WORDPOS(_use,'SHR EXCL') = 0 THEN RETURN 'Invalid USE() parm value' _iowrite_rc = 0 /* Initialize return code */ /*--------------------------------------------------------------------*/ /* P C - B A S E D R E X X S E G M E N T (O S / 2, D O S, E T C)*/ /*--------------------------------------------------------------------*/ IF WORDPOS(RIGHT(GETENV(),3),'OS2 DOS WNT W95 ONT') = 0 THEN SIGNAL IOWRITE_NOTOS2 IF SYMBOL('_SysFileDelete') <> 'VAR' THEN /* Is utility registered? */ DO /* No. See if we need it. */ IF WORDPOS(RIGHT(GETENV(),3),'OS2 WNT W95') <> 0 THEN INTERPRET "CALL RxFuncAdd", "'SysFileDelete','RexxUtil','SysFileDelete'" _SysFileDelete = 1 END IF _status = 'OPEN' /* Was file left open? */ THEN SIGNAL IOREAD_OS2_WRITEIT /* Yes, start writing it. */ IF _mode = 'REPLACE' THEN /* Replace mode? */ IF STREAM(_filename,'C','QUERY EXISTS')<>'' THEN /* Does file exist?*/ DO IF RIGHT(GETENV(),3) = 'ONT' THEN ADDRESS CMD "del "_filename /* Delete file to clear (AP/NT)*/ IF WORDPOS(RIGHT(GETENV(),3),'OS2 WNT W95') <> 0 THEN INTERPRET "rc=SysFileDelete(_filename)" /* Delete file to clr*/ IF RIGHT(GETENV(),3) = 'DOS' THEN INTERPRET "rc=RXDELETE(_filename)" /* Delete file to clr*/ IF rc > 3 THEN RETURN 'SysFileDelete/RXDELETE error rc='rc END _o = STREAM(_filename,'C','OPEN WRITE') IF _o = 'NOTREADY:32' /* File in use by another pgm? */ THEN RETURN 'File in use' /* Yes, return error text */ IF ABBREV(_o,'READY') <> 1 /* Is file ready? */ THEN RETURN 'File not ready:'_o /* No, return error text */ IF _mode = 'APPEND' THEN /* Are we in append mode? */ IF STREAM(_filename,'C','QUERY SIZE')>0 THEN /* Any data in file? */ DO PARSE VERSION _iov1 . IF _iov1 = 'OBJREXX' THEN DO /* Use OPEN APPEND if available*/ CALL STREAM _filename,'C','CLOSE' CALL STREAM _filename,'C','OPEN APPEND' END ELSE CALL STREAM _filename,'C','SEEK <0' /* Yes, seek to end */ END IOREAD_OS2_WRITEIT: DO _i = 1 TO VALUE(_stem'0') rc = LINEOUT(_filename, VALUE(_stem''_i)) IF rc > 0 THEN RETURN 'Error 'rc /* I/O failed, return w/error */ END IF _leaveopen <> 'YES' THEN /* Are we to leave file open? */ DO CALL STREAM _dsname,'C','CLOSE' /* No, close the file */ CALL IOSUBS_PUTTOKEN '' /* and clean out the token. */ END ELSE /* If we are leaving file open,*/ CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)' /* add STATUS(OPEN) to token. */ DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records, _data _filename _o _leavealloc _leaveopen _stem _use RETURN _iowrite_rc IOWRITE_NOTOS2: /*--------------------------------------------------------------------*/ /* I S P F c o d e s e g m e n t f o r I O W R I T E. */ /*--------------------------------------------------------------------*/ IF ISPFLMF() <> 'YES' THEN SIGNAL IOWRITE_NOTISPF ADDRESS ISPEXEC 'CONTROL ERRORS RETURN' DROP ZDATAIDZ IF _status = 'OPEN' /* Was file left open? */ THEN SIGNAL IOWRITE_ISPF_NOAPPEND /* Yes, resume writing it */ IF SYMBOL('ZDATAIDZ') = 'LIT' THEN DO _disp = _use IF _use = 'EXCL' THEN _disp = 'EXCLU' ok = '8' IF _ddname <> '' /* Was DDNAME() passed in? */ THEN ADDRESS ISPEXEC 'LMINIT DATAID(ZDATAIDZ) DDNAME('_ddname')' ELSE ADDRESS ISPEXEC 'LMINIT DATAID(ZDATAIDZ) ENQ('_disp')', "DATASET('"_dsname"')" IF rc > 0 THEN RETURN STRIP(ZERRSM) /* Save value of dataid for future calls */ CALL IOSUBS_PUTTOKEN 'DATAID('VALUE(ZDATAIDZ)') ' END /* Extract information about the dataset that we are writing... */ ok = 4 /* rc=4 if some vars are blank */ ADDRESS ISPEXEC 'LMQUERY DATAID('zdataidz') LRECL(ZLRECLZ)', 'OPEN(ZOPENZ) DSORG(ZDSORGZ)' IF rc > 4 THEN RETURN STRIP(zerrsm) /* Experience shows that ZOPENZ isn't valid for new members... */ IF SYMBOL('ZOPENZ') <> 'VAR' /* Do we have open status? */ THEN ZOPENZ = '' /* No, must be closed. */ IF ZOPENZ = 'INPUT' THEN /* File left open for input? */ DO /* Yes, close it before reopen */ ADDRESS ISPEXEC 'LMCLOSE DATAID('ZDATAIDZ')' ZOPENZ = '' /* Indicate file not open */ END IF ZOPENZ = '' THEN /* File needs opened? */ DO ADDRESS ISPEXEC 'LMOPEN DATAID('ZDATAIDZ') OPTION(OUTPUT)', 'LRECL(ZLRECLZ)' IF rc > 0 THEN RETURN 'LMOPEN FAILED' IF _mode <> 'APPEND' /* Are we in append mode? */ THEN SIGNAL IOWRITE_ISPF_NOAPPEND /* No, skip around append code. */ ok = '8' /* Get temporary dataid */ ADDRESS ISPEXEC 'LMINIT DATAID(ZTEMPIDZ) ENQ(SHR)', "DATASET('"_dsname"')" IF rc > 0 THEN RETURN STRIP(ZERRSM) ADDRESS ISPEXEC 'LMOPEN DATAID('ZTEMPIDZ') OPTION(INPUT)' IF rc > 0 THEN RETURN STRIP(ZERRLM) _done = 0 IF _member <> '' THEN DO OK='8 12';ADDRESS ISPEXEC 'LMMFIND DATAID('ZTEMPIDZ')', 'MEMBER('_member')', 'STATS(YES)'; DROP OK IF rc >= 8 THEN _done = 1 END DO _i = 1 BY 1 WHILE _done=0 /* Read each record from the file */ ok = 8 ADDRESS ISPEXEC 'LMGET DATAID('ZTEMPIDZ') MODE(INVAR)', 'DATALOC(ZDATAZ)', 'DATALEN(ZDATALNZ) MAXLEN('ZLRECLZ')' IF rc = 8 THEN LEAVE /* End of file... */ ok = 0 ADDRESS ISPEXEC 'LMPUT DATAID('ZDATAIDZ') MODE(INVAR)', 'DATALOC(ZDATAZ) DATALEN('ZLRECLZ')' END _i /* DO _i = 1 BY 1 */ ADDRESS ISPEXEC 'LMCLOSE DATAID('ZTEMPIDZ')' ADDRESS ISPEXEC 'LMFREE DATAID('ZTEMPIDZ')' END IOWRITE_ISPF_NOAPPEND: DO _i = 1 TO VALUE(_stem'0') /* Loop thru each record to write */ ZDATAZ = VALUE(_stem''_i) ADDRESS ISPEXEC 'LMPUT DATAID('ZDATAIDZ') MODE(INVAR)', 'DATALOC(ZDATAZ) DATALEN('ZLRECLZ')' END _i /* _i = 1 TO VALUE(_stem'0') */ IF _leaveopen <> 'YES' THEN /* Are we to leave file open? */ DO /* No, write it, close it, exit */ IF _member <> '' THEN DO IF SYMBOL('zlvers') = 'LIT' THEN zlvers = '' /* Init stats if */ IF SYMBOL('zlmod') = 'LIT' THEN zlmod = '' /* not read in */ IF SYMBOL('zlcdate') = 'LIT' THEN zlcdate = '' /* from the */ IF SYMBOL('zlmsec') = 'LIT' THEN zlmsec = '' /* TOKENVAR() */ IF SYMBOL('zlinorc') = 'LIT' THEN zlinorc = '' zlmdate = DATE("O") /* Last changed date */ zlmtime = SUBSTR(TIME("N"),1,5) /* Last changed time */ IF RIGHT(GETENV(),3) = 'TSO' THEN INTERPRET "zluser = SYSVAR('SYSUID')" IF POS(GETENV(),'OPSREXX') > 0 THEN zluser = OPSINFO('JOBNAME') zlmnorc = 1 /* Dummy number of changed recs */ zlcnorc = MIN(VALUE(_stem'0'),65535) /* Current or max # records*/ IF zlinorc = '' THEN zlinorc = zlcnorc /* Set initial size */ IF zlvers = '' THEN zlvers = 1 /* Set initial version */ IF zlmod = '' THEN zlmod = 0 /* Set initial change level */ ELSE IF zlmod < 99 THEN zlmod = zlmod + 1 /* Increment chanage level */ IF zlcdate = '' THEN zlcdate = zlmdate /* Set creation date */ /*----------------------------------------------------------------*/ /* Replace or create the desired member... */ /*----------------------------------------------------------------*/ OK='8 12' ADDRESS ISPEXEC 'LMMREP DATAID('ZDATAIDZ') MEMBER('_member')', 'STATS(YES)'; DROP OK IF rc > 8 THEN IF SYMBOL('ZERRSM') = 'VAR' THEN _iowrite_rc = STRIP(ZERRSM) ELSE _iowrite_rc = 'LMMREP FAILED' END /* IF _member <> '' THEN */ ADDRESS ISPEXEC 'LMCLOSE DATAID('ZDATAIDZ')' CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)' /* Downgrade to STATUS(ALLOC) */ END ELSE /* LEAVEOPEN(YES) */ CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)' /* Set STATUS(OPEN) */ IF _leavealloc <> 'YES' THEN DO ADDRESS ISPEXEC 'LMFREE DATAID('ZDATAIDZ')' CALL IOSUBS_PUTTOKEN '' /* Clear out the TOKENVAR() */ END DROP _status _tokenvar _t1 _t2 _dsname _leaveopen _stem _i _records, _data _filename _o _leavealloc _leaveopen _stem _use zdataidz, _tokenvar _tempid RETURN _iowrite_rc IOWRITE_NOTISPF: /*--------------------------------------------------------------------*/ /* T S O c o d e s e g m e n t f o r I O W R I T E. */ /*--------------------------------------------------------------------*/ IF RIGHT(GETENV(),3) <> 'TSO' & POS(GETENV(),'OPSREXX') = 0 THEN SIGNAL IOWRITE_NOTTSO IF WORDPOS(_status,'ALLOC OPEN') > 0 /* File already allocated? */ THEN SIGNAL IOWRITE_TSO_ALLOCD /* Yes, skip validation. */ IF _ddname <> '' THEN /* Was DDNAME() passed in? */ DO /* Yes. Is it allocated? */ IF RIGHT(GETENV(),3) = 'TSO' THEN /* Running in TSO/E? */ DO /* Use TSO/E LISTDSI() function*/ INTERPRET "rc = LISTDSI('"_ddname" FILE NODIRECTORY NORECALL')" IF rc > 4 THEN RETURN LISTDSIREASON(sysreason) END IF POS(GETENV(),'OPSREXX') > 0 THEN IF LEFT(OPSINFO('VERSION'),5) >= '04.01' THEN INTERPRET "IF OPSDD2DS(_ddname) = ''", "THEN RETURN 'DDNAME('_ddname') not allocated'" ELSE DO CALL OPSCLEDQ ok = '12' ADDRESS TSO "LISTALC STATUS" _ddfound = 0 _search4 = ' 'LEFT(_ddname,8,' ')' ' DO WHILE QUEUED() > 0 PARSE UPPER PULL (_search4) _msg IF _msg <> '' THEN _ddfound = 1 END IF _ddfound <> 1 THEN RETURN 'DDNAME('_ddname') not allocated' END SIGNAL IOWRITE_TSO_ALLOCD /* Start writing it... */ END _disp = _use IF _use = 'EXCL' THEN _disp = 'OLD' IF RIGHT(GETENV(),3) = 'TSO' THEN /* Running in TSO/E? */ DO /* Use TSO/E SYSDSN() function */ INTERPRET "_msg_status=MSG('OFF')"/*Interpret to hide from OPS/REXX */ INTERPRET "rc = SYSDSN('''"_filename"''')" IF rc <> 'OK' THEN IF rc = 'UNAVAILABLE DATASET' THEN RETURN 'File in use' ELSE IF rc = 'MEMBER NOT FOUND' /* Don't care if not found on write*/ THEN NOP ELSE RETURN rc 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*/ RETURN 'IOWRITE error: OUTTRAP() Active and cannot be used' END END INTERPRET "x = OUTTRAP('_outtrap.','*','NOCONCAT')" INTERPRET "CALL MSG('ON')" ok = '12' ADDRESS TSO "ALLOC FILE("_ddnm") DSNAME('"_filename"')", "REUSE "_disp END IF POS(GETENV(),'OPSREXX') > 0 THEN DO IF LEFT(OPSINFO('VERSION'),5) >= '04.01' THEN DO INTERPRET "rc = OPSSVC99('ALLOC',_ddnm,_filename,_disp)" IF rc <> 0 THEN DO; _ioread_rc = 'Allocate failed'; SIGNAL IOREAD_TSO_EXIT; END END ELSE DO CALL OPSCLEDQ ok = '12' ADDRESS TSO "ALLOC FILE("_ddnm") DSNAME('"_filename"')", "REUSE "_disp DO _i = 1 BY 1 WHILE QUEUED() > 0 PARSE UPPER PULL _msg _outtrap._i = _msg END _outtrap.0 = _i-1 END END IF rc <> 0 THEN DO _i = _outtrap.0 _iowrite_rc = _outtrap._i IF _iowrite_rc = 'DATA SET IS ALLOCATED TO ANOTHER JOB OR USER' THEN _iowrite_rc = 'File in use' IF _i = 0 THEN _iowrite_rc = 'Allocate failed' SIGNAL IOWRITE_TSO_EXIT END IOWRITE_TSO_ALLOCD: IF _mode = 'APPEND' THEN DO ADDRESS TSO 'EXECIO * DISKRU '_ddnm, ' (FINIS STEM _TEMP.)' ADDRESS TSO 'EXECIO * DISKW '_ddnm, ' (OPEN STEM _TEMP.)' END _options = '' IF _leaveopen <> 'YES' THEN _options = _options'FINIS ' ADDRESS TSO 'EXECIO 'VALUE(_stem'0')' DISKW '_ddnm, ' ('_options' STEM '_stem')' IF _leavealloc <> 'YES' THEN DO IF POS(GETENV(),'OPSREXX') > 0 THEN IF LEFT(OPSINFO('VERSION'),5) >= '04.01' THEN INTERPRET "CALL OPSSVC99 'FREE',_ddnm" ELSE ADDRESS TSO 'FREE FILE('_ddnm')' ELSE ADDRESS TSO 'FREE FILE('_ddnm')' CALL IOSUBS_PUTTOKEN '' /* Clear out the TOKENVAR */ END ELSE /* If leaving file allocated, */ IF _leaveopen = 'YES' THEN DO CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')' CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)' END ELSE DO CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')' CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)' END IOWRITE_TSO_EXIT: IF SYMBOL('_savtrap') = 'VAR' THEN INTERPRET _savtrap /* Restore caller's OUTTRAP status */ IF SYMBOL('_msg_status') = 'VAR' THEN INTERPRET "CALL MSG _msg_status" /* Restore caller's MSG() status*/ DROP _msg_status _savtrap _tokenvar _tempid RETURN _iowrite_rc IOWRITE_NOTTSO: /*--------------------------------------------------------------------*/ /* N E T V I E W c o d e s e g m e n t f o r I O W R I T E. */ /*--------------------------------------------------------------------*/ IF GETENV() <> 'NETVMVS' THEN SIGNAL IOWRITE_NOTNETV IF WORDPOS(_status,'ALLOC OPEN') > 0 /* File already allocated? */ THEN SIGNAL IOWRITE_NETV_ALLOCD /* Yes, skip validation. */ IF _ddname <> '' THEN /* DDNAME passed, is it ALLOCd?*/ DO /*------------------------------------------------------------------*/ /* CNM271I FOOBAR DD STATEMENT MISSING */ /* -or- */ /* CNM299I */ /* DDNAME DATA SET NAME DISP*/ /* -------- --------------------------------------------------- --- */ /* DSIPARM DC2P.NETVIEW.V3R1.NETOG.DSIPARM SHR */ /*------------------------------------------------------------------*/ ADDRESS NETVIEW 'PIPE NETVIEW LISTA '_ddname, ' | SEPARATE ', /* Convert multi-line to single */ ' | STEM _ioreadout.' /* Place results into global vars */ IF ABBREV(_ioreadout.1,'CNM271I') = 1 THEN RETURN 'DDNAME('_ddname') not allocated' IF ABBREV(_ioreadout.1,'CNM299I') <> 1 THEN RETURN 'DDNAME('_ddname') not allocated' SIGNAL IOWRITE_NETV_ALLOCD /* Start writing it... */ END _disp = _use IF _use = 'EXCL' THEN _disp = 'OLD' /*--------------------------------------------------------------------*/ /* CNM272I TEST IS NOW ALLOCATED */ /* DSI370I ALLOCATE COMMAND FAILED, 'TEST' IS ALREADY IN USE */ /* CNM277I DATA SET DKZB2CC.FLA NOT FOUND */ /* CNM278I DATA SET DKZB2CC.CLIST UNAVAILABLE */ /*--------------------------------------------------------------------*/ DO _iowritei = 1 TO 2 'PIPE NETVIEW ALLOC FILE('_ddnm') DS('_filename') '_disp, ' | SEPARATE ', /* Convert multi-line to single */ ' | STEM _iowriteout.' /* Place results into global vars */ IF ABBREV(_iowriteout.1,'DSI370I') <> 1 THEN LEAVE _iowritei IF _iowritei = 1 THEN DO ADDRESS NETVIEW 'PIPE NETVIEW FREE FILE('_ddnm')' ITERATE _iowritei END _iowrite_rc = 'Unable to REUSE File('_ddnm')' SIGNAL IOWRITE_NETV_EXIT END _iowritei _i = _iowriteout.0 /* -> last line of ALLOC output */ SELECT WHEN ABBREV(_iowriteout._i,'CNM272I') = 1 THEN SIGNAL IOWRITE_NETV_ALLOCD WHEN ABBREV(_iowriteout._i,'CNM278I') = 1 THEN _iowrite_rc = 'File in use' WHEN _i = 0 THEN _iowrite_rc = 'Allocate failed' OTHERWISE _iowrite_rc = SUBWORD(_iowriteout._i,2) /* Get 2nd-nth word */ END SIGNAL IOWRITE_NETV_EXIT IOWRITE_NETV_ALLOCD: IF _mode = 'APPEND' THEN DO ADDRESS MVS 'EXECIO * DISKRU '_ddnm, ' (FINIS STEM _TEMP.)' ADDRESS MVS 'EXECIO * DISKW '_ddnm, ' (OPEN STEM _TEMP.)' END _options = '' IF _leaveopen <> 'YES' THEN _options = _options'FINIS ' ADDRESS MVS 'EXECIO 'VALUE(_stem'0')' DISKW '_ddnm, ' ('_options' STEM '_stem')' IF _leavealloc <> 'YES' THEN DO ADDRESS NETVIEW 'PIPE NETVIEW FREE FILE('_ddnm')' CALL IOSUBS_PUTTOKEN '' /* Clean out the TOKENVAR */ END ELSE /* If leaving file allocated, */ IF _leaveopen = 'YES' THEN DO CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')' CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)' END ELSE DO CALL IOSUBS_PUTTOKEN 'DDNAME('_ddnm')' CALL IOSUBS_PUTTOKEN 'STATUS(ALLOC)' END IOWRITE_NETV_EXIT: IF SYMBOL('_savtrap') = 'VAR' THEN INTERPRET _savtrap /* Restore caller's OUTTRAP status */ IF SYMBOL('_msg_status') = 'VAR' THEN INTERPRET "CALL MSG _msg_status" /* Restore caller's MSG() status*/ DROP _msg_status _savtrap _tokenvar _tempid RETURN _iowrite_rc IOWRITE_NOTNETV: RETURN 'Unsupported environment 'GETENV() /*-Start of IOSUBS_GETTOKEN Subroutine--------------------------------*/ /*:IOSUBS_GETTOKEN Subroutine: Extracts variables from the */ /* caller-provided TOKENVAR(xx) parm). Things in the token are: */ /* STATUS(OPEN | ALLOC) DDNAME(DDNAME) DATAID(xxxx) ZLVERS() */ /* ZLMOD() ZLCDATE() ZLMDATE() ZLMTIME() ZLMSEC() */ /* ZLCNORC() ZLINORC() ZLMNORC() ZLUSER() */ /*--------------------------------------------------------------------*/ IOSUBS_GETTOKEN: TRACE N _status = '' /* Initialize _status */ IF _tokenvar <> '' THEN /* Was token passed? */ IF SYMBOL(_tokenvar) <> 'LIT' THEN /* Anything stored in token? */ DO /* Yes, extract existing data */ _tokens = VALUE(_tokenvar) DO WHILE _tokens <> '' PARSE VAR _tokens _tokenkw '(' _tokenvalue ')' _tokens IF WORDPOS(_tokenkw,'STATUS DATAID DDNAME') > 0 THEN _tokenkw = WORD('_STATUS ZDATAIDZ _DDNM',, WORDPOS(_tokenkw,'STATUS DATAID DDNAME')) CALL VALUE _tokenkw,_tokenvalue END IF SYMBOL('ZDATAIDZ') <> 'LIT' THEN /* Does dataid exist? */ IF ZDATAIDZ = '' /* Is dataid valid? */ THEN DROP ZDATAIDZ /* No, drop it like hot potato*/ END DROP _tokens _tokenkw _tokenvalue RETURN /*-Start of IOSUBS_PUTTOKEN Subroutine--------------------------------*/ /*:IOSUBS_PUTTOKEN Subroutine: Stores information in the */ /* caller-provided TOKENVAR(xx) variable. */ /* CALL IOSUBS_PUTTOKEN 'STATUS(OPEN)' Change STATUS() to OPEN */ /* CALL IOSUBS_PUTTOKEN 'STATUS()' Remove STATUS() keyword */ /* CALL IOSUBS_PUTTOKEN '' Remove ALL keywords. */ /*--------------------------------------------------------------------*/ IOSUBS_PUTTOKEN: TRACE N PARSE UPPER ARG _tokenkw '(' _tokenvalue ')' _tokenr IF _tokenr <> '' THEN SAY 'Error: IOSUBS_PUTTOKEN bad args:' ARG(1) _tokenkw = _tokenkw'(' IF _tokenvar <> '' THEN /* Was token passed? */ DO /* Yes. */ IF SYMBOL(_tokenvar) = 'LIT' /* Nothing stored in token? */, | _tokenkw = '(' /* or request to clear all? */ THEN PARSE VALUE '' WITH _tokenl _tokenr ELSE PARSE VALUE VALUE(_tokenvar), WITH _tokenl (_tokenkw) . ')' _tokenr IF _tokenvalue = '' /* If null, just remove kw(xx) */ THEN CALL VALUE _tokenvar,_tokenl''_tokenr ELSE CALL VALUE _tokenvar,_tokenl''_tokenkw''_tokenvalue')'_tokenr END DROP _tokenkw _tokenvalue _tokenl _tokenr RETURN /*-Start of LISTDSIREASON subroutine----------------------------------*/ /*:LISTDSIREASON function: Returns english text equivalent to a */ /* SYSREASON return code returned by the LISTDSI() function. */ /*--------------------------------------------------------------------*/ LISTDSIREASON: PROCEDURE TRACE N txt.1 = 'Error parsing the function' txt.2 = 'Dynamic Allocation processing error' txt.3 = 'Dataset type cannot be processed' txt.4 = 'Error determining UNIT name' txt.5 = 'Dataset not catalogued' txt.6 = 'Error obtaining dataset name' txt.7 = 'Error finding device type' txt.8 = 'Dataset not on DASD' txt.9 = 'Dataset migrated' txt.11 = 'Read access denied' txt.12 = 'VSAM dataset, unsupported' txt.13 = 'Dataset could not be opened' txt.14 = 'Device type not found in UCB' txt.17 = 'Abend occurred' txt.18 = 'Partial information obtained' txt.19 = 'Multi-volume dataset' txt.20 = 'Device type not found in EDT' txt.21 = 'Catalog error' txt.22 = 'Volume not mounted' txt.23 = 'I/O error' txt.24 = 'Dataset not found' txt.25 = 'Dataset migrated off of DASD' txt.27 = 'Dataset has no VOLSER' txt.28 = 'Invalid DDNAME' txt.29 = 'Missing DSNAME or DDNAME' i = STRIP(ARG(1),'LEADING',0) IF SYMBOL('txt.'i) = 'VAR' THEN RETURN txt.i RETURN '' /*-End of IOSUBS routines-------------------------------------------*/