/* REXX TBCOPY Make a copy of an ISPF table with modifications. This routine is intended to be copied and customized apllication-by-application... UNLESS : this is just for a change to the table's 'shape' as shown in the AAMSTR table. In that case (maybe adding a new field), this routine can be used as-is. Paragraph MA_CUSTOMIZE is the only place application-specific code should be needed. MA_CUSTOMIZE is called for each row retrieved from the input table. A TBADD to the output table is done immediately on return from MA_CUSTOMIZE. Use '(routine name) ?' for HELP-text. Written by Frank Clarke, rexxhead@yahoo.com pre-1998. Impact Analysis . SYSEXEC DFLTTLIB . SYSEXEC TBLGEN . SYSEXEC TRAPOUT Modification History 19980601 fxc upgrade from v.960506 to v.19980225; DECOMM; 20000204 fxc upgrade from v.19980225 to v.19991109; 20210401 fxc moved TBLGEN into A_INIT because it uses (and then closes) the AA table so that the AA table cannot be TBCOPYd. 20230406 fxc adjust HELP 20230806 fxc chg SYSPROC to SYSEXEC in Impact Analysis; 20231107 fxc TBLGEN LEAVE; 20240308 fxc chg dollar-sign to @ everywhere; 20240403 fxc default to the current location of ; default to ; adjust HELP-text; */ 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 */ call A_INIT /* -*/ call B_OPEN_TBL /* -*/ if \sw.0error_found then, call M_MAIN_PROCESS /* -*/ call Z_CLOSE_TBL /* -*/ exit /*@ TBCOPY */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO call AA_KEYWDS /* -*/ parse var info intbl outtbl . /* from- and to-table */ parse value outtbl "@TMP" with, outtbl . parse value "0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0" with, ct . openmode.0 = "WRITE" /* based on NOUPDT */ openmode.1 = "NOWRITE" parse value inlib "'"DFLTTLIB( intbl )"'" with , inlib . /* guarantee a value */ parse value outlib inlib with , outlib . /* guarantee a value */ address TSO "TBLGEN" tbltype "TBLNAME" outtbl, "LEAVE REPLACE" openmode.noupdt return /*@ A_INIT */ /* . ----------------------------------------------------------------- */ AA_KEYWDS: /*@ */ if branch then call BRANCH address TSO replace = SWITCH("REPLACE") tbltype = KEYWD("TYPE") /* AA, maybe */ if tbltype = "" then do helpmsg = "TYPE is required." call HELP end inlib = KEYWD("FROM") /* source ISPTLIB */ outlib = KEYWD("TO") /* target ISPTABL */ return /*@ AA_KEYWDS */ /* . ----------------------------------------------------------------- */ B_OPEN_TBL: /*@ */ if branch then call BRANCH address ISPEXEC "CONTROL ERRORS RETURN" "LIBDEF ISPTLIB DATASET ID("inlib") STACK" "TBSTATS" intbl "STATUS1(s1) STATUS2(s2)" if s1 > 1 then do say "Table" intbl "not available." sw.0error_found = "1" end if s2 = 1 then, /* not open */ "TBOPEN " intbl "NOWRITE" else "TBTOP" intbl "LIBDEF ISPTLIB" return /*@ B_OPEN_TBL */ /* . ----------------------------------------------------------------- */ M_MAIN_PROCESS: /*@ */ if branch then call BRANCH address ISPEXEC do forever "TBSKIP" intbl "SAVENAME(xvars)" /* next row */ if rc <> 0 then leave parse var xvars "(" xvars ")" /* ------------ customized code goes here ------------------ */ call MA_CUSTOMIZE /* -*/ /* ------------ customized code ends here ------------------ */ "TBADD " outtbl "SAVE("xvars")"/* add to output table */ ct = ct + 1 end /* forever */ say "Forever loop ended: "ct "rows transferred." return /*@ M_MAIN_PROCESS */ /* . ----------------------------------------------------------------- */ MA_CUSTOMIZE: /*@ */ if branch then call BRANCH address TSO return /*@ MA_CUSTOMIZE */ /* . ----------------------------------------------------------------- */ Z_CLOSE_TBL: /*@ */ if branch then call BRANCH address ISPEXEC "LIBDEF ISPTABL DATASET ID("outlib") STACK" "TBEND " intbl /* finished with table */ if replace then slug = "NAME("intbl")" /* ready to replace */ else slug = "" if noupdt then, "TBEND" outtbl /* purge */ else, "TBCLOSE" outtbl slug /* save */ "LIBDEF ISPTABL" return /*@ Z_CLOSE_TBL */ /* . ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ if branch then call BRANCH address TSO return /*@ LOCAL_PREINIT */ /* . -------------------------------------------------------------------*/ HELP: /*@ */ address TSO;"CLEAR" if helpmsg <> "" then say helpmsg; say "" ex_nam = Left(exec_name,8) say " "ex_nam" copies one ISPF table to another, potentially replacing " say " the original. This EXEC needs to be customized for each " say " re-use --UNLESS-- all the changes are field-add or " say " field-delete to match the current AAMSTR. " say " " say " Syntax: "ex_nam" intblnm (Required)" say " outtblnm (Defaults)" say " TYPE tblgenid (Required)" say " FROM inlib (Defaults)" say " TO outlib (Defaults)" say " REPLACE " say " " say " If REPLACE, the original table will be overwritten (if it is " say " in a target position) by the regenerated table. " say " " say " .....more " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " intblnm identifies the table to be modified. " say " " say " outtblnm defaults to @TMP unless REPLACE. " say " " say " tblgenid identifies the 2-character key to the AAMSTR table" say " that defines the TBCREATE parameters. TBLGEN will" say " be called to TBCREATE a new table for output. " say " " say " inlib identifies the library which contains . " say " If not specified, DFLTTLIB will be called to " say " supply a value. " say " " say " outlib identifies the library which will receive " say " . Defaults to . " say " " say " .....more " "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 " 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 "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 */