/* REXX ADDCMDS Add one command table to the currently-resident copy of ISPCMDS or other specified command table. The user's personal command table may thus be dynamically spliced to ISPCMDS. Changes to the user's personal command table may be implemented at any time by re-running this. Use 'addcmds ?' for HELP-text. Written by Frank Clarke, rexxhead@yahoo.com, in the Dark Ages Impact Analysis . SYSEXEC SYSUMON . SYSEXEC TRAPOUT . (alias) USRCMDS Modification History 19981027 fxc REXXSKEL at last, v.19980225; 19991117 fxc upgrade from v.19980225 to v.19991109; 20230401 fxc SYSUMON only if not testing 20230414 fxc adjust HELP 20230806 fxc chg SYSPROC to SYSEXEC in Impact Analysis; */ arg argline address ISPEXEC /* REXXSKEL ver.19991109 */ 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 errors */ call A_INIT /* -*/ call B_TABLE_OPS /* -*/ if tv = 'N' then, /* only if not testing */ "SYSUMON USER" Userid() "TOOL" exec_name exit /*@ ADDCMDS */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address ISPEXEC parse value KEYWD( "TO" ) "ISPCMDS" with, tgt_tbl . parse value "0 0" with, adds dels del_list parse value info exec_name with, tblname . if tblname = "ADDCMDS" then tblname = "TMPCMDS" if Length( tblname ) < 5 then tblname = tblname"CMDS" if Length( tgt_tbl ) < 5 then tgt_tbl = tgt_tbl"CMDS" if monitor then say, "Using" tblname return /*@ A_INIT */ /* . ----------------------------------------------------------------- */ B_TABLE_OPS: /*@ */ b_tv = trace() /* what setting at entry ? */ if branch then call BRANCH address ISPEXEC "TBQUERY" tblname /* tell me about this table */ if rc > 12 then do /* doesn't exist, maybe ? */ zerrsm = "TBQUERY error" if Symbol("zerrlm") = "LIT" then, zerrlm = "No additional diagnostics produced." zerrlm = exec_name "("BRANCH("ID")")", zerrlm address ISPEXEC "SETMSG MSG(ISRZ002)" sw.0error_found = "1"; return drop zerrlm /* make it a LIT again */ end if rc = 12 then "TBOPEN" tblname "NOWRITE" /* 12 = 'not open' */ "TBSORT" tblname "FIELDS(ZCTVERB,C,D)" do forever /* for every row in the table */ "TBSKIP" tblname /* get next row */ if rc > 0 then leave /* end of table? */ if monitor then say, " Working" zctverb do forever /* found a match on ISPCMDS */ "TBSCAN" tgt_tbl "NOREAD ARGLIST(ZCTVERB) CONDLIST(EQ)" if rc > 0 then leave if monitor then say, " Delete from" tgt_tbl "TBDELETE" tgt_tbl /* get rid of it */ del_list = del_list zctverb /* make note of it */ dels = dels + 1 /* count a deleted row */ end /* forever (inner) */ "TBADD" tgt_tbl /* ... add a new line */ adds = adds + 1 /* count an added row */ "TBTOP" tgt_tbl /* reposition to row 0 */ end /* forever (outer) */ rc = Trace("O"); rc = trace(b_tv) "TBEND " tblname /* close and end */ if sw.0show then do /* user asked for a list */ "TBTOP" tgt_tbl /* reset to top */ do forever "TBSKIP" tgt_tbl /* get another row */ if rc > 0 then leave /* end of table */ say Left(zctverb,8) Right(zcttrunc,2) Left(zctact,66) say " " Left(zctdesc,72) end /* forever */ end /* SHOW */ rc = Trace("O"); rc = trace(b_tv) ZERRSM = "A="adds "D="dels /* short message */ ZERRLM = adds "lines were added;" dels "lines deleted." if dels <> 0 & ABS(adds-dels) > 1 then do ZERRSM = ZERRSM "(!)" ZERRLM = ZERRLM "Deleted verbs:" del_list ZERRALRM = "YES" end else ZERRALRM = "NO" address ISPEXEC "SETMSG MSG(ISRZ002)" return /*@ B_TABLE_OPS */ /* . ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ address TSO sw.0show = SWITCH("SHOW") /* user asked for a list ? */ return /*@ LOCAL_PREINIT */ /* . ----------------------------------------------------------------- */ HELP: /*@ */ address TSO;"CLEAR" if helpmsg <> "" then say helpmsg; say "" ex_nam = Left(exec_name,8) /* predictable size */ say " "ex_nam" adds a user-command-table to the in-storage copy of " say " ISPCMDS or other command table. Any existing " say " command-table entries with matching names are deleted " say " before the new commands are added. " say " " say " Syntax: "ex_nam" tempname (Defaults)" say " TO target (Defaults)" say " (( SHOW " say " " say " If 'tempname' is not specified, the name defaults to 'TMPCMDS'" say " for execname=ADDCMDS, and to the name of the routine" say " for any aliases. " say " " say " If target is not specified, the name defaults to 'ISPCMDS'. " say " " say " For both, 'CMDS' may be omitted. " say " " say " SHOW requests that the final table be echoed to the " say " screen. " "NEWSTACK"; pull; "CLEAR"; "DELSTACK" say " Debugging tools provided include: " say " " say " MONITOR: displays key information throughout processing. " say " Displays most paragraph names upon entry. " say " " say " BRANCH: show all paragraph entries. " say " " say " TRACE tv: will use value following TRACE to place " say " the execution in REXX TRACE Mode. " say " " say " " say " Debugging tools can be accessed in the following manner: " say " " say " TSO" exec_name" parameters (( debug-options " say " " say " For example: " say " " say " TSO" exec_name " (( 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 "QSTACK" /* how many stacks? */ stk2dump = rc - tk_init_stacks /* remaining stacks */ if stk2dump = 0 & queued() = 0 then return 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. */ say "Processing Stack #" dd " Total Lines:" queued() do queued();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 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 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 ssend . if ssend = "" then ssend = 10 if \datatype(ssbeg,"W") | \datatype(ssend,"W") then return ssend = ssbeg + ssend do ssii = ssbeg to ssend ; say Strip(sourceline(ssii),'T') ; end return /*@ SS */ /* . ----------------------------------------------------------------- */ SWITCH: Procedure expose info /*@ */ arg kw 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 */ 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 . sw.nested = sysvar("SYSNEST") = "YES" sw.batch = sysvar("SYSENV") = "BACK" sw.inispf = sysvar("SYSISPF") = "ACTIVE" 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 */