/* REXX RUNDATA Keeps otherwise-undefined data about executions of REXX routines in an ISPF table. The table, also called RUNDATA, has a key of RTNNAME and a data field, SETBY, to identify the last userid to do an update; all other fields are extension variables; that is: they are potentially unique for each row. RUNDATA is meant to be used by other REXX code exclusively. CLIST calls are not supported due to the fact that data transfer is via the stack. WARNING ! Maintainers beware: if you are unfamiliar with the handling characteristics of extension variables in ISPF tables, do NOT attempt to maintain this code. Above all, do not TBOPEN table RUNDATA in WRITE-mode with any other program. Use '(routine name) ?' for HELP-text. Written by Frank Clarke rexxhead@yahoo.com 19991217 Impact Analysis . SYSEXEC DFLTTLIB . SYSEXEC STRSORT . SYSEXEC TRAPOUT Modification History 20230417 fxc adjust HELP; 20230627 fxc better diagnostics 20230723 fxc modernize logging; 20230730 fxc nicer KEYLIST display; 20230803 fxc use hhmm for log file name; 20230908 fxc set log lrecl to 255; 20230916 fxc eliminate msgpref for logpref; correct usage of logpref; alloc logdsn MOD; 20231102 fxc eliminate unnecessary CLEAR; remove error on key-not-found; 20231103 fxc adjust display for READ; correct errors and omissions in HELP; 20231107 fxc implement SETBY; 20231120 fxc better HELP-text; 20240202 fxc better HELP-text; 20240209 fxc use DFLTTLIB to locate RUNDATA; 20240220 fxc better comments; 20240309 fxc change dollar-sign to @ everywhere; 20240412 fxc DUMP_QUEUE quiet; enable TBLKEY; deprecate PROGRAM; 20240414 fxc implement SAFE to retain all xvars; 20240422 fxc correct HELP text; 20240508 fxc CLEAR if not nested; 20240517 fxc better HELP text; enable SYSUMON; 20240527 fxc strip input tagval; 20240529 fxc cosmetics; 20240612 fxc sort taglist; 20240701 fxc make restartable from READY; 20240728 fxc TBGET NOREAD in BDW; 20240913 fxc implement TAGLIST; housekeeping; 20240913 fxc disable SYSUMON; if RUNDATA calls SYSUMON which calls RUNDATA: KA-BOOM; 20241228 fxc use @tn@ as parm to DFLTTLIB; 20250123 fxc if SAFE, hide all starting values in CACHE.; 20250221 fxc pretty-up KEYLIST display; 20250322 fxc reorganize and correct HELP-text; 20250418 fxc align READ output data for readability; 20250426 fxc add headers for READ; 20250429 fxc only align for readability if NOT nested; */ arg argline address ISPEXEC /* REXXSKEL ver.20040227 */ arg parms "((" opts signal on syntax signal on novalue call TOOLKIT_INIT /* conventional start-up -*/ if sw.0inispf = "0" then do arg line line = line "(( RESTARTED " /* tell the next invocation */ address TSO "ISPSTART CMD( "exec_name line" )" /* Invoke ISPF if nec. */ exit 2 /* bail out */ end rc = Trace( 'O' ); rc = trace(tv) info = parms /* to enable parsing */ "CONTROL ERRORS RETURN" /* I'll handle my own */ call A_INIT /* set up environment -*/ if sw.0error_found then nop ; else, call B_TABLE_OPS /* read and write table rows -*/ if sw.0errlog + sw.0error_found > 0 then, call ZB_SAVELOG /* -*/ if \sw.0nested then call DUMP_QUEUE 'quiet' /* -*/ if sw.0restarted then do /* at end of mainline */ rc = OutTrap( "ll." ) exit 4 end exit /*@ RUNDATA */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO if sw.0nested = 0 then "CLEAR" parse value "" with taglist tag tagval , keylist tags. cache. call AA_SETUP_LOG /* -*/ logpref = exec_name "("BRANCH( "ID" )")" call ZL_LOGMSG( logpref "Running from" FIND_ORIGIN() ) call ZL_LOGMSG( logpref "Arg:" argline) call AK_KEYWDS /* parse parameters -*/ if sw.0error_found then return /* has been set. There may be other material in the queue. */ noupdt = ( sw.0Taglist + sw.0Keylist + sw.0Read + noupdt ) > 0 /* any of these forces NOUPDT */ logpref = exec_name "("BRANCH( "ID" )")" call ZL_LOGMSG( logpref "ISPTLIB is" isptlib ) do queued() /* every stack item remaining */ pull tag tagval /* TAGVAL may be multiple */ tagval = Space( tagval,1 ) zerrlm = Left( tag,8 ) tagval call ZL_LOGMSG( logpref zerrlm) @z@ = Value( tag,tagval ) /* load tagval */ taglist = taglist tag /* add to xvar list */ end /* queued */ openmode.0 = "WRITE" /* based on NOUPDT */ openmode.1 = "NOWRITE" return /*@ A_INIT */ /* . ----------------------------------------------------------------- */ AA_SETUP_LOG: /*@ */ if branch then call BRANCH address TSO msglim = SYSVAR( "SYSWTERM" ) - 12 parse value "0 0 0 0 0" with, log# log. . parse value Date( "S" ) Time( "S" ) Time( "N" ) with, yyyymmdd sssss hhmmss . hhmmss = Space( Translate( hhmmss,' ',':' ) ,0 ) parse var yyyymmdd 4 yrdigit 5 mm 7 dd /* 9 12 14 maybe */ if Pos( yrdigit,"13579" ) > 0 then mm = mm + 12 /* mm=24 */ logtag = Substr( "ABCDEFGHIJKLMNOPQRSTUVWX",mm,1 ) /* logtag=X */ subid = logtag""dd""Left( hhmmss,4 ) /* X141743 ? */ vb255.0 = "NEW CATALOG UNIT( SYSDA ) SPACE( 1 5 ) TRACKS", "RECFM( V B ) LRECL( 255 ) BLKSIZE( 0 )" vb255.1 = "MOD" /* if it already exists... */ logdsn = "@LOG."exec_name"."subid".LIST" tempstat = Sysdsn( logdsn ) = "OK" /* 1=exists, 0=missing */ /* Because RUNDATA is called from REXX code, it's possible that the calls will happen so fast that more than one will be issued within the same minute, and be placed on the same logfile as previous iterations. Therefore, the logfile is allocated 'MOD' if it already exists, and a separator line of hyphens is written as the first line of a subsequent use. */ if tempstat = 1 then , call ZL_LOGMSG( "-------------------" ) return /*@ AA_SETUP_LOG */ /* For WRITE operations, the necessary parms can be specified in the queue. The first item must be "TBLKEY ..." if TBLKEY is not specified as a Keyword. . ----------------------------------------------------------------- */ AK_KEYWDS: /*@ */ if branch then call BRANCH address TSO logpref = exec_name "("BRANCH( "ID" )")" sw.0Safe = SWITCH( " SAFE ") /* Keep all xvars */ sw.0Errlog = SWITCH( " LOG ") /* OFF by default */ /* turned ON by error */ /* ON if LOG or error */ parse var info w1 info if WordPos( w1,"READ WRITE DROP KEYLIST TAGLIST" ) = 0 then do sw.0error_found = 1 helpmsg = "" "Action verb specified incorrectly.", "Must be the first token in the parm." call HELP /* -*/ end sw.0Keylist = w1 = "KEYLIST" if sw.0Keylist then return /* robot-mode */ sw.0Taglist = w1 = "TAGLIST" if sw.0Taglist then return /* robot-mode */ sw.0READ = w1 = "READ" sw.0WRITE = w1 = "WRITE" sw.0DROP = w1 = "DROP" program = KEYWD( "PROGRAM" ) tblkey = KEYWD( "TBLKEY" ) parse value tblkey program with rtnname . if rtnname = "" then, /* not specified... */ if queued() = 0 then do /* ...and no place to get it */ sw.0error_found = 1 push "" "No table key" return end else do /* queue has lines */ pull tag tagval rest /* must be TBLKEY xxxxx */ if tag <> "TBLKEY" |, tagval = "" then do sw.0error_found = 1 push tag tagval rest push "" "No table key on stack" return end rtnname = tagval zerrlm = "RTNNAME ( "tagval" ) was on the stack" call ZL_LOGMSG( logpref zerrlm) end loadstr = CLKWD( "DATA" ) /* only applicable to WRITE */ if loadstr <> "" then, if Pos( ":",loadstr ) = 0 then do /* no colons? */ helpmsg = "DATA value has no punctuation" call HELP /* ...and don't come back */ end return /*@ AK_KEYWDS */ /* . ----------------------------------------------------------------- */ B_TABLE_OPS: /*@ */ if branch then call BRANCH address ISPEXEC call BA_OPEN /* -*/ if sw.0error_found then nop ; else , call BD_GET /* -*/ call BZ_CLOSE /* -*/ return /*@ B_TABLE_OPS */ /* . ----------------------------------------------------------------- */ BA_OPEN: /*@ */ if branch then call BRANCH address ISPEXEC logpref = exec_name "("BRANCH( "ID" )")" "LIBDEF ISPTLIB DATASET ID( "isptlib" ) STACK" if rc > 0 then do zerrlm = zerrlm "LIBDEF RC="rc call ZL_LOGMSG( logpref zerrlm) sw.0error_found = 1 return end "TBSTATS" @tn@ "STATUS1( s1 ) STATUS2( s2 )" if rc > 0 then do zerrlm = zerrlm "TBSTATS RC="rc call ZL_LOGMSG( logpref zerrlm) sw.0error_found = 1 return end if s1 > 1 then do "TBCREATE" @tn@ "KEYS( RTNNAME ) NAMES( SETBY )", openmode.noupdt end; else, if s2 = 1 then do "TBOPEN " @tn@ openmode.noupdt end else "TBTOP" @tn@ if rc > 0 then do zerrlm = zerrlm "cre/open/top RC="rc " S1="s1 " S2="s2 call ZL_LOGMSG( logpref zerrlm) sw.0error_found = 1 end "LIBDEF ISPTLIB" "TBSORT " @tn@ "FIELDS( RTNNAME,C,A )" if sw.0Safe then , call BAC_CACHE_VALUES /* -*/ return /*@ BA_OPEN */ /* If SAFE was ordered, get all existing tags and tagvalues and store them in a safe place (CACHE.) for later use by BDW. Expose only values needed for minimal operation. Do not use taglist from outer routines. . ----------------------------------------------------------------- */ BAC_CACHE_VALUES: Procedure expose, /*@ */ ( tk_globalvars ) cache. @tn@ rtnname if branch then call BRANCH address ISPEXEC address TSO "NEWSTACK" "TBGET" @tn@ "SAVENAME( TAGLIST )" /* populates all xvars */ parse var taglist "(" taglist ")" /* yes, we want no bananas */ do Words( taglist ) /* every xvar */ parse var taglist tag taglist /* isolate */ t1 = tag cache.t1 = Value( tag ) cache.0taglist = cache.0taglist tag end /* taglist */ address TSO "DELSTACK" return /*@ BAC_CACHE_VALUES */ /* Which action verb? READ, WRITE, DROP, TAGLIST, or KEYLIST? . ----------------------------------------------------------------- */ BD_GET: /*@ */ if branch then call BRANCH address ISPEXEC if sw.0DROP then, /* Drop */ call BDD_DROP /* -*/ else, if sw.0Keylist then, /* Keylist */ call BDL_KEYLIST /* -*/ else, if sw.0READ then, /* READ */ call BDR_READ /* -*/ else, if sw.0Taglist then, /* Taglist */ call BDT_TAGLIST /* -*/ else, /* WRITE */ call BDW_WRITE /* -*/ return /*@ BD_GET */ /* TBDELETE the row for . ----------------------------------------------------------------- */ BDD_DROP: /*@ */ if branch then call BRANCH address ISPEXEC logpref = exec_name "("BRANCH( "ID" )")" "TBGET" @tn@ if rc > 0 then do zerrsm = "RTNNAME" rtnname "not found." zerrlm = zerrsm "Not deleted." call ZL_LOGMSG( logpref zerrlm) sw.0error_found = 1 push "" "TBGET RC="rc ";"zerrsm";"zerrlm return end "TBDELETE" @tn@ if rc = 8 then do zerrsm = "RTNNAME" rtnname "not found." zerrlm = zerrsm "Not deleted." call ZL_LOGMSG( logpref zerrlm) sw.0error_found = 1 push "" "TBDELETE RC="rc ";"zerrsm";"zerrlm return end else, if rc > 8 then do zerrsm = "Severe error." zerrlm = zerrsm call ZL_LOGMSG( logpref zerrlm) sw.0error_found = 1 push "" "TBDELETE RC="rc ";"zerrsm";"zerrlm return end return /*@ BDD_DROP */ /* . ----------------------------------------------------------------- */ BDL_KEYLIST: /*@ */ if branch then call BRANCH address ISPEXEC address TSO "CLEAR" logpref = exec_name "("BRANCH( "ID" )")" keylist = "" /* init */ zerrlm = "KEYLIST was set" call ZL_LOGMSG( logpref zerrlm) text. = '' tagtxt = '' do forever "TBSKIP" @tn@ "SAVENAME( TAGLIST )" /* populates all xvars */ if rc > 0 then leave keylist = keylist rtnname parse var taglist "(" tags.rtnname ")" /* no bananas */ do Words( tags.rtnname ) parse var tags.rtnname tag tags.rtnname tagtxt = tagtxt Left( tag,8 ) /* evenly spaced */ end text.rtnname = Left( rtnname,8 ) "references" tagtxt msgtext = text.rtnname do while Length( msgtext ) > msglim pt = LastPos( " ",msgtext,msglim ) slug = Left( msgtext,pt ) say slug msgtext = Copies( ' ',20 )Substr(msgtext,pt) end /* while msglim */ say msgtext call ZL_LOGMSG( logpref text.rtnname ) tagtxt = '' end /* forever */ if keylist = "" then say, @tn@ "table in" isptlib "is empty" return /*@ BDL_KEYLIST */ /* RTNNAME is set. Get the row and populate the queue from the row's extension variables by 'queue tag tagval'. . ----------------------------------------------------------------- */ BDR_READ: /*@ */ if branch then call BRANCH address ISPEXEC logpref = exec_name "("BRANCH( "ID" )")" zerrlm = "READ was set" call ZL_LOGMSG( logpref zerrlm) parse value "" with zerrsm zerrlm "TBGET" @tn@ "SAVENAME( TAGLIST )" /* populates all xvars */ if rc > 0 then return parse var taglist "(" taglist ")" /* yes, we want no bananas */ zerrlm = "TAGLIST:" taglist call ZL_LOGMSG( logpref zerrlm) do Words( taglist ) /* every xvar */ parse var taglist tag taglist /* isolate */ msgtext = Left( tag,20 ) Value(tag) if sw.0nested = 0 then, do while Length( msgtext ) > msglim pt = LastPos( " ",msgtext,msglim ) slug = Left( msgtext,pt ) msgtext = " "Substr( msgtext,pt ) queue slug call ZL_LOGMSG( logpref slug ) end /* msglim */ queue msgtext end /* taglist */ if sw.0nested = 0 then do /* add headers */ queue ' ' push Left( '--- Tags ---',20 ) '-- Value(s) --' push ' Information for READ TBLKEY' rtnname end /* not nested */ return /*@ BDR_READ */ /* TAGLIST is empty. TBSKIP through the entire table acquiring unique tags and associating them with their keys. Display (via 'say') the unique tags. . ----------------------------------------------------------------- */ BDT_TAGLIST: /*@ */ if branch then call BRANCH address ISPEXEC address TSO "CLEAR" logpref = exec_name "("BRANCH( "ID" )")" zerrlm = "TAGLIST was set" call ZL_LOGMSG( logpref zerrlm) keys. = '' do forever "TBSKIP" @tn@ "SAVENAME( TAGS ) " parse var tags "(" tags ")" /* no bananas */ if rc > 0 then leave do Words( tags ) parse var tags tag tags /* isolate */ if WordPos( tag,taglist ) = 0 then , taglist = taglist tag /* add it */ keys.tag = keys.tag rtnname end /* tags */ end /* forever */ if taglist = "" then do say @tn@ "table in" isptlib "is empty" return end taglist = STRSORT( taglist ) do Words( taglist ) /* each tag */ parse var taglist tag taglist /* isolate */ text = '' do Words( keys.tag ) parse var keys.tag key keys.tag text = text Left( key,9 ) /* evenly spaced */ end /* keys */ line = Left( tag,8 ) "is referenced by" Strip( text ) say line call ZL_LOGMSG( logpref line ) end /* taglist */ return /*@ BDT_TAGLIST */ /* TAGLIST was developed and populated in A_INIT from data found on the queue and/or it will be populated here from a DATA specification. If there is no 'taglist' there is no data to write, which is an error. Otherwise position to the proper row and reload with new data. . If SAFE was specified, stem array CACHE. has been populated with values needed to restore any missing tags and tagvals. . ----------------------------------------------------------------- */ BDW_WRITE: /*@ */ if branch then call BRANCH address ISPEXEC if sw.0Safe then do /* Preserve all xvars */ "TBGET" @tn@ "SAVENAME( xvars ) NOREAD " parse var xvars "(" xvars ")" /* peel bananas */ end /* Safe */ do while loadstr <> "" /* build taglist */ parse var loadstr slug ";" loadstr parse var slug tag ":" tagval tag = Strip( tag ) /* a variable may not have */ tagval = Strip( tagval ) /* leading blanks */ zerrlm = Left( tag,8 ) tagval call ZL_LOGMSG( logpref zerrlm) @z@ = Value( tag,tagval ) /* load tagval */ taglist = taglist tag /* add to xvar list */ end /* loadstr */ logpref = exec_name "("BRANCH( "ID" )")" if taglist = "" then do sw.0error_found = 1 zerrlm = logpref "TAGLIST was empty" address ISPEXEC "SETMSG MSG( ISRZ002 )" return end /* no taglist */ setby = Userid() zerrlm = "WRITE was set" call ZL_LOGMSG( logpref zerrlm) if sw.0Safe then do /* add back any missing tags */ do Words( xvars ) parse var xvars w1 xvars if WordPos( w1,taglist ) = 0 then do /* not there */ taglist = taglist w1 /* it is now... */ $z = Value( w1,cache.w1 ) end /* not there */ end /* Words */ end /* Safe */ taglist = STRSORT( taglist ) zerrlm = "TAGLIST:" taglist call ZL_LOGMSG( logpref zerrlm) "TBMOD" @tn@ "SAVE( "taglist" )" /* load xvars to table */ return /*@ BDW_WRITE */ /* . ----------------------------------------------------------------- */ BZ_CLOSE: /*@ */ if branch then call BRANCH address ISPEXEC logpref = exec_name "("BRANCH( "ID" )")" if noupdt + sw.0error_found > 0 then do "TBEND" @tn@ return end zerrlm = "" "LIBDEF ISPTABL DATASET ID( "isptabl" ) STACK" if rc > 0 then do zerrlm = zerrlm "LIBDEF RC="rc call ZL_LOGMSG( logpref zerrlm) sw.0error_found = 1 end "TBSORT " @tn@ "FIELDS( RTNNAME,C,A )" "TBCLOSE" @tn@ /* write to ISPTABL */ if rc > 0 then do zerrsm = "TBCLOSE failed" if Symbol( "zerrlm" ) = "LIT" then, zerrlm = "No additional diagnostics produced." call ZL_LOGMSG( logpref zerrlm) push "" zerrlm address ISPEXEC "SETMSG MSG( ISRZ002 )" sw.0error_found = 1 end "LIBDEF ISPTABL" return /*@ BZ_CLOSE */ /* . ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ address TSO sw.0restarted = SWITCH( "RESTARTED" ) /* in LOCAL_PREINIT */ parse value KEYWD( "USETBL" ) "RUNDATA" with, @tn@ . parse value KEYWD("ISPTLIB") "'"DFLTTLIB( @tn@ )"'" with, isptlib . parse value KEYWD( "ISPTABL" ) isptlib with, isptabl . return /*@ LOCAL_PREINIT */ /* . ----------------------------------------------------------------- */ ZB_SAVELOG: /*@ */ if branch then call BRANCH address TSO if Symbol( "LOG#" ) = "LIT" then return /* not yet set */ "ALLOC FI( @LOG ) DA( "logdsn" ) REU" vb255.tempstat "EXECIO" log# "DISKW @LOG ( STEM LOG. FINIS" "FREE FI( @LOG )" return /*@ ZB_SAVELOG */ /* . ----------------------------------------------------------------- */ ZL_LOGMSG: Procedure expose, /*@ */ (tk_globalvars) log. log# msglim rc = Trace( "O" ) address TSO parse arg msgtext /* for making the msgline always reasonably short: */ do while Length( msgtext ) > msglim pt = LastPos( " ",msgtext,msglim ) slug = Left( msgtext,pt ) if monitor then say, slug parse value log#+1 slug with, zz log.zz 1 log# . msgtext = " "Substr( msgtext,pt ) end /* while msglim */ parse value log#+1 msgtext with, zz log.zz 1 log# . if monitor then say, msgtext return /*@ ZL_LOGMSG */ /* Find where code was run from. It assumes cataloged data sets. Original by Doug Nadel With SWA code lifted from Gilbert Saint-flour's SWAREQ exec . ----------------------------------------------------------------- */ FIND_ORIGIN: Procedure /*@ */ answer="* UNKNOWN *" /* assume disaster */ Parse Source . . name dd ds . /* get known info */ Call listdsi( dd "FILE" ) /* get 1st ddname from file */ Numeric digits 10 /* allow up to 7FFFFFFF */ If name = "?" Then /* if sequential exec */ answer="'"ds"'" /* use info from parse source */ Else /* now test for members */ If sysdsn("'"sysdsname"("name")'")="OK" Then /* if in 1st ds */ answer="'"sysdsname"("name")'" /* go no further */ Else /* hooboy! Lets have some fun!*/ Do /* scan tiot for the ddname */ tiotptr=24+ptr(12+ptr(ptr(ptr(16)))) /* get ddname array */ tioelngh=c2d(stg(tiotptr,1)) /* nength of 1st entry */ Do Until tioelngh=0 | tioeddnm = dd /* scan until dd found */ tioeddnm=strip(stg(tiotptr+4,8)) /* get ddname from tiot */ If tioeddnm <> dd Then /* if not a match */ tiotptr=tiotptr+tioelngh /* advance to next entry */ tioelngh=c2d(stg(tiotptr,1)) /* length of next entry */ End If dd=tioeddnm Then, /* if we found it, loop through the data sets doing an swareq for each one to get the dsname */ Do Until tioelngh=0 | stg(4+tiotptr,1)<> " " tioejfcb=stg(tiotptr+12,3) jfcb=swareq(tioejfcb) /* convert SVA to 31-bit addr */ dsn=strip(stg(jfcb,44)) /* dsname JFCBDSNM */ vol=storage(d2x(jfcb+118),6) /* volser JFCBVOLS (not used) */ If sysdsn("'"dsn"("name")'")='OK' Then, /* found it? */ Leave /* we is some happy campers! */ tiotptr=tiotptr+tioelngh /* get next entry */ tioelngh=c2d(stg(tiotptr,1)) /* get entry length */ End answer="'"dsn"("name")'" /* assume we found it */ End Return answer /*@ FIND_ORIGIN */ /* . ----------------------------------------------------------------- */ ptr: Return c2d(storage(d2x(Arg(1)),4)) /*@ */ /* . ----------------------------------------------------------------- */ stg: Return storage(d2x(Arg(1)),Arg(2)) /*@ */ /* . ----------------------------------------------------------------- */ SWAREQ: Procedure /*@ */ If right(c2x(Arg(1)),1) \= 'F' Then /* SWA=BELOW ? */ Return c2d(Arg(1))+16 /* yes, return sva+16 */ sva = c2d(Arg(1)) /* convert to decimal */ tcb = c2d(storage(21c,4)) /* TCB PSATOLD */ tcb = ptr(540) /* TCB PSATOLD */ jscb = ptr(tcb+180) /* JSCB TCBJSCB */ qmpl = ptr(jscb+244) /* QMPL JSCBQMPI */ qmat = ptr(qmpl+24) /* QMAT QMADD */ Do While sva>65536 qmat = ptr(qmat+12) /* next QMAT QMAT+12 */ sva=sva-65536 /* 010006F -> 000006F */ End return ptr(qmat+sva+1)+16 /*@ SWAREQ */ /* . ----------------------------------------------------------------- */ HELP: /*@ */ address TSO;"CLEAR" ; say "" if helpmsg <> "" then say helpmsg; say "" ex_nam = Left( exec_name,8 ) /* predictable size */ say " "ex_nam" Maintain execution-time data for REXX routines. " say " " say " Syntax: "ex_nam" READ | WRITE | DROP | KEYLIST | TAGLIST (One Only)" say " TBLKEY key (if READ, WRITE, or DROP)" say " DATA( datastring ) (WRITE only)" say " LOG " say " SAFE (WRITE only)" say " (( USETBL tblnm (Defaults)" say " ISPTLIB tbllibi (Defaults)" say " ISPTABL tbllibo (Defaults)" say " " say " For WRITE operations, any necessary data can be specified on the stack. " say " The first item on the stack must be 'TBLKEY ' if was not " say " specified as a command-line parameter. Other tag+tagvalue pairs may be " say " specified on subsequent lines. " say " " say " For READ operations, "exec_name" should always be invoked inside a " say " NEWSTACK/DELSTACK block in which the queue can be examined line by line." say " " say " more..... " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " READ commands that the output stack is to be populated " say " for the use of the calling routine. " say " " say " WRITE commands that table is to be loaded with " say " data from the input stack and/or from a DATA() " say " specification. " say " " say " DROP requests the key be deleted from the table. " say " " say " KEYLIST requests a report of the keys present on table " say " . " say " " say " TAGLIST requests a report of the tags present on table " say " . " say " " say " =====> READ, WRITE, DROP, KEYLIST, and TAGLIST are mutually" say " exclusive. One and only one must be specified as " say " the FIRST parameter to "exec_name". " say " " say " more..... " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " LOG (switch in parms) causes the log to be written at " say " task end. Normally, the log is not written. If an " say " error is detected the log will be produced " say " regardless. " say " " say " 'Key not found' is NOT an error. " say " " say " SAFE (switch in parms) causes tags not specified in this " say " iteration to be retained. Normally, unspecified " say " tags or tags not paired with a value are dropped " say " from the row. " say " " say " key identifies the key for table . If is " say " not specified as a parameter, the first line of the " say " input stack must be 'TBLKEY '. This may also " say " be specified as 'PROGRAM' , but this usage is " say " deprecated. " say " " say " more..... " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " datastring specifies, in string-form, the data for a WRITE " say " operation. DATA is only valid for WRITE and is " say " ignored otherwise. The string must be composed of " say " paired tags+tagvalues with each pair separated from " say " the next by a semicolon <;> and the tag separated " say " from the tagvalue by a colon <:>. For example, " say " " say " date : 20040914 ; dataset : old.data ; " say " " say " (spaces not required) will cause two tags (DATE and " say " DATASET) to be written to the RUNDATA table. Any " say " existing tags not specified will be dropped unless " say " SAFE was specified. " say " " say " must be enclosed in parentheses and may" say " not contain parentheses, semicolons, or colons other" say " than as required separators. " say " " say " more..... " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " The following special parameters are specified following a pair of " say " open-parentheses <((>. They all have default values and are " say " to be specified only when overriding the default(s). " say " " say " " say " tblnm names the table to be used for input and output " say " operations. If not specified, it defaults to " say " 'RUNDATA'. " say " " say " tbllibi names the ISPTLIB library from which to obtain the " say " table. If not specified, DFLTTLIB will be " say " called to supply a value. The first table library " say " found to contain a table will be returned. " say " " say " tbllibo names the ISPTABL library to which the table" say " will be saved. If not specified, it defaults to the" say " current value for . " say " " say " more..... " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " If an error is detected for any reason, "exec_name" pushes a line onto " say " the queue. The first token will be '' and it will be " say " followed by any available diagnostic information. The calling " say " program is responsible for handling such messages. The table will " say " NOT have been updated and the log file WILL be written. " say " " say " All communication to and from "exec_name" is via the stack or the " say " available parameters specified on the call. " say " " say " more..... " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " Debugging tools provided include: " say " " say " MONITOR displays key information throughout processing. " say " Displays most paragraph names upon entry. " say " " say " NOUPDT by-pass all update logic. " say " " say " BRANCH show all paragraph entries. " say " " say " TRACE tv will use value following TRACE to place the " say " execution in REXX TRACE Mode. " say " " say " " say " Debugging tools can be accessed in the following manner: " say " " say " TSO "ex_nam" parameters (( debug-options " say " " say " For example " say " " say " TSO "ex_nam" (( MONITOR TRACE ?R " if sysvar( "SYSISPF" ) = "ACTIVE" then, address ISPEXEC "CONTROL DISPLAY REFRESH" exit /*@ HELP */ /* . ----------------------------------------------------------------- */ BRANCH: Procedure expose, /*@ */ sigl exec_name rc = trace( "O" ) /* we do not want to see this */ arg brparm . origin = sigl /* where was I called from ? */ do currln = origin to 1 by -1 /* inch backward to label */ if Right(Word(Sourceline(currln),1),1) = ":" then do parse value sourceline(currln) with pgfname ":" . /* Label */ leave ; end /* name */ end /* currln */ select when brparm = "NAME" then return(pgfname) /* Return full name */ when brparm = "ID" then do /* wants the prefix */ parse var pgfname pgfpref "_" . /* get the prefix */ return(pgfpref) end /* brparm = "ID" */ otherwise say left(sigl,6) left(pgfname,40) exec_name "Time:" time("L") end /* select */ return /*@ BRANCH */ /* . ----------------------------------------------------------------- */ DUMP_QUEUE: /*@ Take whatever is in stack */ rc = trace("O") /* and write to the screen */ address TSO arg mode . "QSTACK" /* how many stacks? */ stk2dump = rc - tk_init_stacks /* remaining stacks */ if stk2dump = 0 & queued() = 0 then return if mode <> "QUIET" then, say "Total Stacks" rc , /* rc = #of stacks */ " Begin Stacks" tk_init_stacks , /* Stacks present at start */ " Excess Stacks to dump" stk2dump do dd = rc to tk_init_stacks by -1 /* empty each one. */ if mode <> "QUIET" then, say "Processing Stack #" dd " Total Lines:" queued() do queued();parse pull line;say line;end /* pump to the screen */ "DELSTACK" /* remove stack */ end /* dd = 1 to rc */ return /*@ DUMP_QUEUE */ /* Handle CLIST-form keywords added 20020513 . ----------------------------------------------------------------- */ CLKWD: Procedure expose info /*@ hide all except info */ arg kw kw = kw"(" /* form is 'KEY(DATA)' */ kw_pos = Pos(kw,info) /* find where it is, maybe */ if kw_pos = 0 then return "" /* send back a null, not found*/ rtpt = Pos(") ",info" ",kw_pos) /* locate end-paren */ slug = Substr(info,kw_pos,rtpt-kw_pos+1) /* isolate */ info = Delstr(info,kw_pos,rtpt-kw_pos+1) /* excise */ parse var slug ( kw ) slug /* drop kw */ slug = Reverse( Substr( Reverse( Strip( slug ) ),2 ) ) return slug /*@CLKWD */ /* Handle multi-word keys 20020513 . ----------------------------------------------------------------- */ KEYWD: Procedure expose info /*@ hide all vars, except info*/ arg kw /* form is 'KEY DATA' */ kw_pos = wordpos( kw,info ) /* find where it is, maybe */ if kw_pos = 0 then return "" /* send back a null, not found*/ kw_val = word( info,kw_pos+Words( kw ) ) /* get the next word */ info = Delword( info,kw_pos,2 ) /* remove both */ return kw_val /*@ KEYWD */ /* . ----------------------------------------------------------------- */ KEYPHRS: Procedure expose, /*@ */ info helpmsg exec_name /* except these three */ arg kp /* form is 'KEY ;: DATA ;:' */ wp = wordpos( kp,info ) /* where is it? */ if wp = 0 then return "" /* not found */ front = subword( info,1,wp-1 ) /* everything before kp */ back = subword( info,wp+1 ) /* everything after kp */ parse var back dlm back /* 1st token must be 2 bytes */ if length( dlm ) <> 2 then /* Must be two bytes */ helpmsg = helpmsg, "Invalid length for delimiter( "dlm" ) with KEYPHRS( "kp" )" if wordpos( dlm,back ) = 0 then /* search for ending delimiter*/ helpmsg = helpmsg, "No matching second delimiter( "dlm" ) with KEYPHRS( "kp" )" if helpmsg <> "" then call HELP /* Something is wrong */ parse var back kpval ( dlm ) back /* get everything b/w delim */ info = front back /* restore remainder */ return Strip( kpval ) /*@ KEYPHRS */ /* . ----------------------------------------------------------------- */ NOVALUE: /*@ */ say exec_name "raised NOVALUE at line" sigl say " " say "The referenced variable is" condition( "D" ) say " " zsigl = sigl signal SHOW_SOURCE /*@ NOVALUE */ /* . ----------------------------------------------------------------- */ SHOW_SOURCE: /*@ */ call DUMP_QUEUE /* Spill contents of stacks -*/ if sourceline() <> "0" then /* to screen */ say sourceline( zsigl ) rc = trace( "?R" ) nop exit /*@ SHOW_SOURCE */ /* . ----------------------------------------------------------------- */ SS: Procedure /*@ Show Source */ arg ssbeg ssct . /* 'call ss 122 6' maybe */ if ssct = "" then ssct = 10 if \datatype( ssbeg,"W" ) | \datatype( ssct,"W" ) then return ssend = ssbeg + ssct do ssii = ssbeg to ssend say Strip( sourceline( ssii ),'T' ) end return /*@ SS */ /* . ----------------------------------------------------------------- */ SWITCH: Procedure expose info /*@ */ arg kw /* form is 'KEY' */ sw_val = Wordpos( kw,info ) > 0 /* exists = 1; not found = 0 */ if sw_val then /* exists */ info = Delword( info,Wordpos( kw,info ),1 ) /* remove it */ return sw_val /*@ SWITCH */ /* . ----------------------------------------------------------------- */ SYNTAX: /*@ */ errormsg = exec_name "encountered REXX error" rc "in line" sigl":", errortext( rc ) say errormsg zsigl = sigl signal SHOW_SOURCE /*@ SYNTAX */ /* Can call TRAPOUT. . ----------------------------------------------------------------- */ TOOLKIT_INIT: /*@ */ address TSO info = Strip( opts,'T', '5d'x ) /* clip trailing paren */ parse source sys_id how_invokt exec_name DD_nm DS_nm, as_invokt cmd_env addr_spc usr_tokn parse value "" with tv helpmsg . parse value 0 "ISR00000 YES" "Error-Press PF1" with, sw. zerrhm zerralrm zerrsm if SWITCH( "TRAPOUT" ) then do "TRAPOUT" exec_name parms "(( TRACE R" info exit end /* trapout */ sw.0nested = sysvar( "SYSNEST" ) = "YES" sw.0batch = sysvar( "SYSENV" ) = "BACK" sw.0inispf = sysvar( "SYSISPF" ) = "ACTIVE" if Word( parms,1 ) = "?" then call HELP /* I won't be back */ "QSTACK" ; tk_init_stacks = rc /* How many stacks? */ parse value SWITCH("BRANCH") SWITCH("MONITOR") SWITCH("NOUPDT") with, branch monitor noupdt . parse value mvsvar( "SYSNAME" ) sysvar( "SYSNODE" ) with, #tk_cpu node . parse value KEYWD( "TRACE" ) "N" with tv . tk_globalvars = "exec_name tv helpmsg sw. zerrhm zerralrm ", "zerrsm zerrlm tk_init_stacks branch monitor ", "noupdt" call LOCAL_PREINIT /* for more opts -*/ return /*@ TOOLKIT_INIT */