/* 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 SYSUMON . 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; */ arg argline address ISPEXEC /* REXXSKEL ver.20040227 */ arg parms "((" opts signal on syntax signal on novalue call TOOLKIT_INIT /* conventional start-up -*/ 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 tv = 'N' then, /* only if not testing */ "SYSUMON USER" Userid() "TOOL" exec_name if \sw.nested then call DUMP_QUEUE 'quiet' /* -*/ exit /*@ RUNDATA */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO if sw.nested = 0 then "CLEAR" parse value "" with taglist tag tagval , keylist tags. call AA_SETUP_LOG /* -*/ logpref = exec_name "("BRANCH("ID")")" call ZL_LOGMSG( logpref "Log started by" Userid() yyyymmdd hhmmss) 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.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 = Strip( tagval ) 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 PROGRAM 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") = 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.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") 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 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 */ 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 )" return /*@ BA_OPEN */ /* Which action verb? READ, WRITE, DROP, 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, /* 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@ "SAVENAME(TAGLIST)" 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 say text.rtnname 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 do return end 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 */ msg = Left( tag,20 ) Value(tag) queue msg call ZL_LOGMSG( logpref msg ) end /* taglist */ return /*@ BDR_READ */ /* TAGLIST was developed and populated in A_INIT from data found on the queue and/or it was populated in AA_KEYWDS 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, preserve any existing tags that were not specified in this session. Do not permit them to be expunged. . ----------------------------------------------------------------- */ BDW_WRITE: /*@ */ if branch then call BRANCH address ISPEXEC if sw.0Safe then do /* Preserve all xvars */ "TBGET" @tn@ "SAVENAME( xvars )" parse var xvars "(" xvars ")" /* peel bananas */ end /* Safe */ 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, /* not there */ taglist = taglist w1 /* it is now... */ 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 parse value KEYWD("ISPTLIB") "'"DFLTTLIB( 'RUNDATA' )"'" with, isptlib . parse value KEYWD("ISPTABL") isptlib with, isptabl . parse value KEYWD("USETBL") "RUNDATA" with, @tn@ . 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 | KEYLIST | DROP (One Required)" say " TBLKEY pgm (if READ, WRITE, or DROP)" say " DATA(datastring) (WRITE only)" say " LOG " say " SAFE (WRITE only)" say " (( ISPTLIB tbllibi (Defaults)" say " ISPTABL tbllibo (Defaults)" say " USETBL tblnm (Defaults)" say " " say " For WRITE operations, the necessary data can be specified on the stack. " say " The first item on the stack must be 'TBLKEY ' if neither TBLKEY nor" say " PROGRAM have been specified as a parameter. Other tag+tagvalue pairs " say " may be 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 caller's use. " 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 " KEYLIST requests a report of the keys present on table " say " . " say " " say " DROP requests the key be deleted from the table. " say " " say " =====> READ, WRITE, DROP, and KEYLIST are mutually " say " exclusive. One and only one must be specified. " say " " say " pgm identifies the key for table . This will " say " normally be the name of the calling program. If " say " pgm is not specified as a parameter, the first " say " line of the input stack must be 'TBLKEY '. " say " This may also be specified as 'PROGRAM' , but " say " this usage is 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. The " say " string must be composed of paired tags+tagvalues " say " with each pair separated from the next by a " say " semicolon (;) and the tag separated from the " say " tagvalue by a colon (:). For example, " say " date : 20040914 ; dataset : old.data ; " 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. " say " " say " 'datastring' must be enclosed in parentheses and may" say " not contain parentheses, semicolons, or colons other" say " than as required separators. " say " " say " LOG causes the log to be written at task end. Normally," say " the log is not written. If an error is detected the" say " log will be produced regardless. " say " " say " 'Key not found' is NOT an error. " say " " say " more..... " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " SAFE (switch in parms) causes tags not specified in this " say " iteration to be retained. Normally, a tag not " say " paired with a value is dropped from the row. " say " " say " tbllibi names the ISPTLIB library from which to obtain the " say " RUNDATA table. If not specified, DFLTTLIB will be " say " called to supply a value. The first table library " say " found to contain a RUNDATA table will be returned. " say " " say " tbllibo names the ISPTLIB library to which the RUNDATA table" say " will be saved. If not specified, it defaults to the" say " current value for . " 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 " 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 RUNDATA 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",")") /* 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.nested = sysvar("SYSNEST") = "YES" sw.batch = sysvar("SYSENV") = "BACK" sw.inispf = 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 */