/* 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. |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| | | | WARNING: EMBEDDED COMPONENTS. | | See text following TOOLKIT_INIT | | | |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| 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; 20240406 fxc Version 3; default to the current location of ; default to ; adjust HELP-text; 20250515 fxc fix DEIMBED; 20250613 fxc add exec_name to logpref; */ 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" swset.0 = "Off" swset.1 = "On" parse value inlib "'"DFLTTLIB( intbl )"'" with , inlib . /* guarantee a value */ parse value outlib inlib with , outlib . /* guarantee a value */ logpref = exec_name "("Branch( "ID" )")" if monitor then do say logpref "TBOPEN will be done" openmode.noupdt say logpref "REPLACE is " swset.replace say logpref "TYPE is" tbltype say logpref "Input table is" intbl if intbl = '' | sw.0GetParms then, say logpref "An ISPF dialog will be started." say logpref "Source table library is" inlib say logpref "Target table library is" outlib end /* monitor */ if intbl = '' | sw.0GetParms then, call AP_GET_PARMS /* -*/ 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 sw.0GetParms = 1 inlib = KEYWD("FROM") /* source ISPTLIB */ outlib = KEYWD("TO") /* target ISPTABL */ return /*@ AA_KEYWDS */ /* Extract all the ISPF assets at the back of the code and LIBDEF into preferential position. . ----------------------------------------------------------------- */ AP_GET_PARMS: /*@ */ if branch then call BRANCH address ISPEXEC "CONTROL ERRORS RETURN" call DEIMBED /* -*/ dd = "" do Words(ddnlist) /* each LIBDEF DD */ parse value ddnlist dd with dd ddnlist @ddn = @ddn.dd /* PLIB322 <- PLIB */ "LIBDEF ISP"dd "LIBRARY ID("@ddn") STACK" end ddnlist = ddnlist dd call APD_DISPLAY /* -*/ logpref = exec_name "("Branch( "ID" )")" if monitor then do say logpref "TYPE is" tbltype say logpref "Input table is" intbl say logpref "Output table is" outtbl say logpref "Source table library is now" inlib say logpref "Target table library is now" outlib end /* monitor */ dd = "" do Words(ddnlist) /* each LIBDEF DD */ parse value ddnlist dd with dd ddnlist @ddn = @ddn.dd /* PLIB322 <- PLIB */ "LIBDEF ISP"dd address TSO "FREE FI("@ddn")" end ddnlist = ddnlist dd return /*@ AP_GET_PARMS */ /* Offer panel PARMS and collect any missing datapoints. . ----------------------------------------------------------------- */ APD_DISPLAY: /*@ */ if branch then call BRANCH address ISPEXEC zerrsm = '' do forever "DISPLAY PANEL( PARMS ) " if rc > 0 then leave if intbl = outtbl then, if intbl <> '' then, if repl = '' then repl = 'Y' parse value intbl outtbl with intbl . parse value outtbl intbl with outtbl . parse value inlib outlib with inlib . parse value outlib inlib with outlib . if Left( inlib,1 ) = "'" then, inlib = Strip( inlib,,"'" ) else, inlib = Userid()"."inlib call APDS_SET_STAT "'"inlib"'" /* -*/ if stat <> 'OK' then do inlib = "'"inlib"'" zerrlm = inlib stat "SETMSG MSG( ISRZ002 ) " iterate end /* stat ne OK */ call APDS_SET_STAT "'"inlib"("intbl")'" /* -*/ if stat <> 'OK' then do inlib = "'"inlib"'" zerrlm = intbl "was not found in "inlib"." "SETMSG MSG( ISRZ002 ) " iterate end /* stat ne OK */ end /* forever */ return /*@ APD_DISPLAY */ /* . ----------------------------------------------------------------- */ APDS_SET_STAT: /*@ */ if branch then call BRANCH address TSO parse arg inparm . stat = Sysdsn( inparm ) return /*@ APDS_SET_STAT */ /* . ----------------------------------------------------------------- */ 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 */ /* This block is called for every row on the input table. Your customization code should be placed here, including any messages to be written for monitoring. . ----------------------------------------------------------------- */ 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 */ /* Parse out the embedded components at the back of the source code. . ----------------------------------------------------------------- */ DEIMBED: Procedure expose, /*@ */ (tk_globalvars) ddnlist @ddn. daid. address TSO dlm = '5d5d5d'x /* three close-parens */ fb80po.0 = "NEW DELETE REU UNIT(SYSDA) SPACE(1 5) TRACKS DIR(40)", "RECFM(F B) LRECL(80) BLKSIZE(0)" fb80po.1 = "SHR REU" parse value "" with ddnlist @ddn. daid. lastln = sourceline() currln = lastln /* */ if Left(sourceline(currln),2) <> "*/" then return currln = currln - 1 /* previous line */ "NEWSTACK" address ISPEXEC do while Left( sourceline( currln ),2 ) <> "/*" text = sourceline(currln) /* save with a short name ! */ if Left( text,3 ) = dlm then do /* package the queue */ parse var text . ddn mbr . /* PLIB PANL001 maybe */ if length(ddn) > 4 then do /* data, not ISPF */ call DESPOOL /* -*/ currln = currln - 1 /* previous line */ iterate end if Pos(ddn,ddnlist) = 0 then do /* doesn't exist */ ddnlist = ddnlist ddn /* keep track */ @ddn = ddn || Random(999) /* PLIB322 maybe */ @ddn.ddn = @ddn /* @ddn.PLIB = PLIB322 */ address TSO "ALLOC FI("@ddn")" fb80po.0 "LMINIT DATAID(DAID) DDNAME("@ddn")" daid.ddn = daid end daid = daid.ddn "LMOPEN DATAID("daid") OPTION(OUTPUT)" do queued() parse pull line "LMPUT DATAID("daid") MODE(INVAR) DATALOC(LINE) DATALEN(80)" end "LMMADD DATAID("daid") MEMBER("mbr")" "LMCLOSE DATAID("daid")" end /* package the queue */ else push text /* onto the top of the stack */ currln = currln - 1 /* previous line */ end /* while */ address TSO "DELSTACK" return /* Subroutine of DEIMBED for non-ISPF data. Given: the stack, ddn, and mbr . ----------------------------------------------------------------- */ DESPOOL: /*@ */ if branch then call BRANCH address TSO if WordPos( ddn,ddnlist ) = 0 then, ddnlist = Space( ddnlist ddn,1 ) if Sysdsn(ddn".DATA") <> "OK" then, "ALLOC FI("ddn") DA("ddn".DATA)" fb80po.0 "ALLOC FI("ddn") DA("ddn".DATA("mbr")) SHR REU" "EXECIO" queued() "DISKW" ddn "(FINIS" "DELSTACK" "NEWSTACK" /* re-establish */ return /*@ DESPOOL */ return /*@ DEIMBED */ /* . -------------------------------------------------------------------*/ HELP: /*@ */ address TSO;"CLEAR" if helpmsg <> "" then say helpmsg; say "" ex_nam = Left(exec_name,8) say " "ex_nam" (v.3) copies one ISPF table to another, potentially " say " replacing the original. This EXEC needs to be customized " say " for each re-use --UNLESS-- all the changes are field-add " say " or 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 " In Version 3, if any required parameters (intbl, type) are " say " missing, an ISPF dialog will be started to collect them. " 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 " " 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','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 */ 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 */ /* ISPF assets follow immediately */ /* ))) PLIB PARMS Get missing parms )ATTR % TYPE( TEXT ) INTENS( HIGH ) SKIP( ON ) + TYPE( TEXT ) INTENS( LOW ) SKIP( ON ) @ TYPE( TEXT ) INTENS( HIGH ) COLOR( YELLOW ) _ TYPE( INPUT ) INTENS( LOW ) CAPS( ON ) ! TYPE( INPUT ) INTENS( HIGH ) )BODY EXPAND(||) @|-|% Fill in any missing parms @|-| %COMMAND ===>_ZCMD %SCROLL ===>_ZAMT+ + + Table type ===>!z + @(Required)+ + + Input table ===>!intbl +in + Input Library ===>!inlib + + + Output table ===>!outtbl +in + OuTput Library ===>!outlib + + + Replace existing? ===>!z+ @( Y or N )+ + )INIT .ZVARS = '( TBLTYPE REPL )' .HELP = PARMSH )PROC &ZERRLM = &Z )END ))) PLIB PARMSH HELP for PARMS )ATTR % TYPE( TEXT ) INTENS( HIGH ) SKIP( ON ) + TYPE( TEXT ) INTENS( LOW ) SKIP( ON ) _ TYPE( INPUT ) INTENS( HIGH ) ! TYPE( OUTPUT ) INTENS( HIGH ) SKIP( ON ) @ TYPE( OUTPUT ) INTENS( LOW ) SKIP( ON ) } AREA( SCRL ) EXTEND( ON ) )BODY EXPAND(||) %TUTORIAL |-| Fill in missing parms |-| TUTORIAL %Next Selection ===>_ZCMD + }hlptxt } )AREA HLPTXT + + Some parm information was missing from the original call. PLease enter any missing values. + + - Table type (two characters) is the key to the table description on the + AAMSTR table-of-tables. This parameter is%required. + + - Enter the%input-table-name.+ This is the existing table that is to be + copied. + + - Enter the%input-library.+ This is an existing table library on which + can be found the%input table.+ + + - Enter the%output-table-name.+ This is either the%input-table-name+if + the table is to be replaced or a%new table name+to be created. + + - Enter the%output-library.+ This is an existing table library onto which + the%output table+will be written. + + At least%three+of%input_table, input-library, output-table,+and % output-library+must be specified. + + If%Replace+is%Y,+the%input-table+on the%input-library+will be rewritten + in place. )PROC &ZUP = PARMSH &ZCONT = PARMSH )END */