/* REXX DUMPTBL Produce a printable version of any ISPF table. Written by Frank Clarke, Oldsmar, FL Modification History 951016 fxc upgrade REXXSKEL; renamed to DUMPTBL; 970729 fxc upgrade from v.950824 to v.970609; reorg; decomm; drop LRECL=133 limit; */ address TSO /* REXXSKEL ver.970609 */ 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_TABLE_EXAM /* -*/ "NEWSTACK" call C_BUILD_REPORT /* -*/ call D_WRITE_REPORT /* -*/ "DELSTACK" if ^sw.nested then call DUMP_QUEUE /* -*/ exit /*@ DUMPTBL */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO parse value "FF"x with, lines xvars. . parse value KEYWD("LPP") "58" with, /* lines-per-page */ lpp . /* default to 58 */ tblds = KEYWD("IN") parse var info $tn$ . /* table-name required */ if $tn$ = "" then call HELP /* ...and don't come back -*/ if tblds = "" then do "NEWSTACK" "LA ISPTLIB ((STACK" pull liblist "DELSTACK" do while tblds = "" /* for each isptlib */ parse var liblist dsn liblist if Sysdsn("'"dsn"("$tn$")'") = "OK" then tblds = "'"dsn"'" if liblist = "" then leave end /* ax */ if tblds = "" then do helpmsg = $tn$ "not found in ISPTLIB. Specify 'IN' library-name." call HELP /* -*/ end end return /*@ A_INIT */ /* . ----------------------------------------------------------------- */ B_TABLE_EXAM: /*@ */ if branch then call BRANCH address ISPEXEC call BA_OPEN_TBL /* -*/ call BB_FIELD_SIZE /* -*/ call BC_LOAD_TBL /* -*/ call BD_SET_HEADERS /* -*/ "TBEND " $tn$ return /*@ B_TABLE_EXAM */ /* . ----------------------------------------------------------------- */ BA_OPEN_TBL: /*@ */ if branch then call BRANCH address ISPEXEC "LIBDEF ISPTLIB DATASET ID("tblds") STACK" "TBSTATS" $tn$ "STATUS1(s1) STATUS2(s2) ROWCURR(rowct)" if s1 > 1 then do say "Table" $tn$ "not available." exit end; else, if s2 = 1 then, /* not open */ "TBOPEN " $tn$ "NOWRITE" else "TBTOP" $tn$ "LIBDEF ISPTLIB" return /*@ BA_OPEN_TBL */ /* . ----------------------------------------------------------------- */ BB_FIELD_SIZE: /*@ */ if branch then call BRANCH address ISPEXEC "TBQUERY" $tn$ "KEYS(keylist)", "NAMES(nmlist)" parse var keylist "(" keylist ")" parse var nmlist "(" nmlist ")" namelist = keylist nmlist ll. = 0 if monitor then say, "Establishing base lengths..." do bx = 1 to Words(namelist) /* how long are the names ? */ word = Word(namelist,bx) ll.word = Length(word) /* ll.word holds length */ $fv$ = Value(word"." , "") /* zap stem var */ end /* bx */ return /*@ BB_FIELD_SIZE */ /* . ----------------------------------------------------------------- */ BC_LOAD_TBL: /*@ */ if branch then call BRANCH address ISPEXEC pt = 0 /* row index */ if monitor then say, "Reading the" $tn$ "table...." do forever "TBSKIP" $tn$ "SAVENAME(XVARS)" if rc > 0 then leave pt = pt + 1 /* indicate next row */ do bx = 1 to Words(namelist) /* how long is each field ? */ word = Word(namelist,bx) $fv$ = Value(word"."pt , Value(word) ) ll = Length(Value(word)) /* how long is this field ? */ if ll.word < ll then, /* bigger ? */ ll.word = ll /* save it */ end /* bx */ parse var xvars "(" xvars ")" xvars.pt = xvars do bx = 1 to Words(xvars) /* how long is each field ? */ word = Word(xvars,bx) $fv$ = Value(word"."pt , Value(word) ) ll = Length(Value(word)) /* how long is this field ? */ if ll.word < ll then, /* bigger ? */ ll.word = ll /* save it */ end /* bx */ end /* forever */ if monitor then say, pt "rows read from" $tn$ "table." /* LL. now has the maximum length of anything that goes in that row and each field has a matching stem variable indexed by pt containing the value for that field in row=pt. */ return /*@ BC_LOAD_TBL */ /* . ----------------------------------------------------------------- */ BD_SET_HEADERS: /*@ */ if branch then call BRANCH address ISPEXEC hdr1 = "" hdr2 = "" do bx = 1 to Words(namelist) /* format header lines */ word = Word(namelist,bx) hdr1 = hdr1 Left(word,ll.word) /* row of names */ hdr2 = hdr2 Left("-",ll.word,"-") /* row of dashes */ end hdr1 = Overlay(1,hdr1,1,1) /* page eject */ return /*@ BD_SET_HEADERS */ /* . ----------------------------------------------------------------- */ C_BUILD_REPORT: /*@ */ if branch then call BRANCH address TSO line1 = "" if monitor then say, "Formatting" pt "rows." do ii = 1 to pt /* format data lines */ if lines >= lpp then call CA_NEWPAGE /* -*/ do jj = 1 to Words(namelist) /* each name */ word = Word(namelist,jj) line1 = line1 Left( Value(word"."ii),ll.word) end /* ii */ line1 = Overlay(0,line1,1,1) /* double space */ queue line1 lines = lines + 2 if xvars.pt <> "" then do line1 = Right("XVARS: ",15) do jj = 1 to Words(xvars.pt) /* each name */ word = Word(xvars.pt,jj) line1 = line1 word"="Strip(Value(word"."ii)) end /* ii */ queue line1 lines = lines + 1 end /* xvars */ line1 = "" end /* forever */ return /*@ C_BUILD_REPORT */ /* ----------------------------------------------------------------- */ CA_NEWPAGE: /*@ */ if branch then call BRANCH address TSO queue hdr1 queue hdr2 lines = 2 return /*@ CA_NEWPAGE */ /* . ----------------------------------------------------------------- */ D_WRITE_REPORT: /*@ */ if branch then call BRANCH address TSO tot_len = Words(namelist) /* spaces between words */ do dx = 1 to Words(namelist) nm = Word(namelist,dx) /* isolate */ tot_len = tot_len + ll.nm end /* dx */ alloc.0 = "NEW CATALOG UNIT(SYSDA) SPACE(1) TRACKS RECFM(F B A)", "LRECL("tot_len") BLKSIZE(0)" alloc.1 = "SHR" /* if it already exists... */ if monitor then say, "Writing text." outdsn = $tn$".LIST" tempstat = Sysdsn(outdsn) = "OK" /* 1=exists, 0=missing */ "ALLOC FI($TMP) DA("outdsn") REU" alloc.tempstat "EXECIO" queued() "DISKW $TMP (FINIS" "FREE FI($TMP)" address ISPEXEC "VIEW DATASET("outdsn")" return /*@ D_WRITE_REPORT */ /* ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ address TSO return /*@ LOCAL_PREINIT */ /* ----------------------------------------------------------------- */ HELP: /*@ */ address TSO;"CLEAR" if helpmsg ^= "" then do say helpmsg; say ""; end say " DUMPTBL produces a printable list of any specified ISPF " say " table up to 132 characters wide. " say " " say " Syntax: DUMPTBL (Required) " say " " say " (Default = 58) " pull "CLEAR" say " Debugging tools provided include:" say " " say " MONITOR: displays key information throughout processing." say " Displays most paragraph names upon entry." say " " say " USEHLQ: causes dataset prefix to be altered as " say " specified." 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" 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" exit /*@ HELP */ /* ----------------------------------------------------------------- */ BRANCH: Procedure expose, /*@ */ sigl exec_name rc = trace("O") /* we do not want to see this */ arg brparm . $a#y = sigl /* where was I called from ? */ do $b#x = $a#y to 1 by -1 /* inch backward to label */ if Right(Word(Sourceline($b#x),1),1) = ":" then do parse value sourceline($b#x) with $l#n ":" . /* Paragraph */ leave ; end /* name */ end /* $b#x */ select when brparm = "NAME" then return($l#n) /* Return full name */ when brparm = "ID" then do /* Return prefix */ parse var $l#n $l#n "_" . /* get the prefix */ return($l#n) end /* brparm = "ID" */ otherwise say left($l#n,45) exec_name "Time:" time("L") end /* select */ return /*@ BRANCH */ /* ----------------------------------------------------------------- */ DUMP_QUEUE: /*@ Take whatever is in stack */ if branch then call BRANCH /* 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 */ "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 */ /* ----------------------------------------------------------------- */ 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+1) /* 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 address TSO "CLEAR" ssend = ssbeg + ssend do ssii = ssbeg to ssend ; say sourceline(ssii) ; end address TSO "CLEAR" 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 */ /* ----------------------------------------------------------------- */ TOOLKIT_INIT: /*@ */ address TSO info = Strip(opts,"T",")") /* clip trailing paren */ "QSTACK" ; tk_init_stacks = rc /* How many stacks? */ parse value "" with tv helpmsg /* initializing values to null*/ parse source sys_id how_invokt exec_name DD_nm DS_nm as_invokt cmd_env addr_spc usr_tokn if Word(parms,1) = "?" then call HELP /* I won't be back */ if SWITCH("TRAPOUT") then do "TRAPOUT" exec_name parms "(( TRACE R" info exit end /* trapout */ branch = SWITCH("BRANCH") monitor = SWITCH("MONITOR") noupdt = SWITCH("NOUPDT") rc = outtrap("CVTINFO","1") "CVTINFO" rc = outtrap("OFF") parse var cvtinfo1 "NJENODE=" node . "NEWSTACK" "DFLTHLQ" ; pull hlq. hlqdata "DELSTACK" do while hlqdata <> "" parse var hlqdata site hlq.site hlqdata end tk_hlq = KEYWD("USEHLQ") parse value tk_hlq hlq.node with hlq . /*default to prod */ sw. = 0 sw.nested = sysvar("SYSNEST") = "YES" sw.batch = sysvar("SYSENV") = "BACK" sw.inispf = sysvar("SYSISPF") = "ACTIVE" parse value KEYWD("TRACE") "O" with tv . zerrhm = "ISR00000" zerrsm = "Error-Press PF1" zerralrm = "YES" call LOCAL_PREINIT /* for more opts -*/ return /*@ TOOLKIT_INIT */