/* REXX TBLOOK Display any ISPF table Use '(routine name) ?' for HELP-text. |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| | | | WARNING: EMBEDDED COMPONENTS. | | See text following TOOLKIT_INIT | | | |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| Written and extended by Frank Clarke, rexxhead@yahoo.com based on a CLIST by Mark Miloslavic Impact Analysis . SYSEXEC LA . SYSEXEC TRAPOUT Modification History 19951016 fxc upgrade REXXSKEL (950824); activate 'IN datasetname'; 19980211 fxc leave table OPEN if it was found that way; enable SORT; 19980602 fxc enable Find/Locate; 19980729 fxc upgrade from v.960119 to v.19980225; RXSKLY2K; DECOMM; 19991101 fxc use VIO for the panel library similar to the method used by DEIMBED; 19991110 fxc handle 'no keys, no names' tables; 19991206 fxc upgrade from v.19980225 to v.19991109; 20020130 fxc add TPRINT capability and ability to select, exclude, and arrange fields to be printed; 20020207 fxc minor corrective adjustments; 20040129 fxc widen fields to use full screen width; 20040722 fxc widescreen version; 20040822 fxc added STATS option for main screen; 20051014 fxc if tblds specified, force table closed; 20230123 fxc increased collen to 9; 20230519 fxc trap table-in-use; trap input 'dsn(mbr)'; 20230524 fxc better comments 20230528 fxc make column width fit the maximum size needed; 20230911 fxc use ZUP/ZCONT in HELP panels; 20240229 fxc remove imbeds from I/A; 20240305 fxc align panel names; 20240308 fxc chg dollar-sign to @ everywhere; */ arg argline address TSO /* 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 /* -*/ if \sw.0error_found then, call B_BUILD_PANELS /* -*/ exit /*@ TBLOOK */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address ISPEXEC "CONTROL ERRORS RETURN" /* I'll handle my own. */ alloc.0 = "NEW CATALOG UNIT(VIO) SPACE(2 2) TRACKS DIR(5)", "RECFM(F B) LRECL(80) BLKSIZE(0)" parse value "8 0 0 0 0 0 0 0 0 0" with, maxlen. lastfnd hdr. ll. . parse value "" with, pfkey thisds keynames varnames allxvars , zerrsm zerrlm call AA_KEYWDS /* -*/ parse var info tblid . if tblid = "ISPSPROF" then do sw.0error_found = 1 /* Ka-boom */ zerrsm = "Forbidden" zerrlm = "Unable to process ISPSPROF. It always blows up." "SETMSG MSG(ISRZ002)" return end /* ISPSPROF */ if tblid = "" then do /* tablename not specified ? */ helpmsg = "Tablename must be specified." call HELP; end if Left( tblid,1 ) = "'" then do /* entire DSN! */ parse var tblid "'" dsn "(" tblid ")" tblds = "'"dsn"'" /* add quotes back */ end if tblds = "" then do "TBSTATS" tblid "STATUS2(s2)" if rc > 0 then do zerrlm = exec_name "("BRANCH("ID")")", zerrlm "SETMSG MSG(ISRZ002)" sw.0error_found = "1" ; return end if s2 > 1 then do sw.0leave_open = "1" return end call AB_LISTA /* loads tblds from ISPTLIB -*/ end else do if Left(tblds,1) <> "'" then, tblds = Userid()"."tblds /* fully-qualified */ else tblds = Strip(tblds,,"'") /* unquoted */ end do ii = 1 to Words(tblds) parse var tblds thisds tblds if Sysdsn("'"thisds"("tblid")'") = "OK" then leave end /* ii */ if Sysdsn("'"thisds"("tblid")'") <> "OK" then do say tblid "not found in ISPTLIB" sw.0error_found = "1" ; return end openmode.0 = "WRITE" /* based on NOUPDT */ openmode.1 = "NOWRITE" noupdt = \sw.4EDIT return /*@ A_INIT */ /* . ----------------------------------------------------------------- */ AA_KEYWDS: /*@ */ if branch then call BRANCH address TSO sw.4EDIT = SWITCH("UPDATE") parse value KEYWD("TBLIB") KEYWD("IN") with, tblds . return /*@ AA_KEYWDS */ /* No was specified. Search area is ISPTLIB. . ----------------------------------------------------------------- */ AB_LISTA: /*@ */ if branch then call BRANCH address TSO "NEWSTACK" "LA ISPTLIB ((STACK" pull tblds "DELSTACK" return /*@ AB_LISTA */ /* . ----------------------------------------------------------------- */ B_BUILD_PANELS: /*@ */ if branch then call BRANCH address ISPEXEC "VGET (ZSCREENW)" maxusable = zscreenw - 2 call BA_PROLOG /* extract and load panels -*/ if \sw.0error_found then, call BB_OPEN /* -*/ if \sw.0error_found then, call BC_LOAD_PANELS /* -*/ if \sw.0error_found then, call BD_SHOW_TABLE /* -*/ call BX_CLOSE_TABLE /* TBSAVE | TBCLOSE | TBEND -*/ call BZ_EPILOG /* drop LIBDEFs -*/ return /*@ B_BUILD_PANELS */ /* DEIMBED and LIBDEF . ----------------------------------------------------------------- */ BA_PROLOG: /*@ */ if branch then call BRANCH address ISPEXEC 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 return /*@ BA_PROLOG */ /* The statistics for a given table are available whether the table is open or closed. The statistics reflect the table as it exists on the input table file, except when the table is open in the logical screen where the TBSTATS service is issued. The statistics then reflect the version of the table that is currently open. This means that if a table is currently open, it doesn't matter whether a dataset name was specified or not. The statistics seen will be those of the open table wherever it came form. status1-name Specifies the name of a variable where the status of the table in the table input library chain is to be stored. Values that can be stored and their meanings are: 1 table exists in the table input library chain 2 table does not exist in the table input library chain 3 table input library is not allocated status2-name Specifies the name of a variable where the status of the table in this logical screen is to be stored. Values that can be stored and their meanings are: 1 table is not open in this logical screen 2 table is open in NOWRITE mode in this logical screen 3 table is open in WRITE mode in this logical screen 4 table is open in SHARED NOWRITE mode in this logical screen 5 table is open in SHARED WRITE mode in this logical screen status3-name Specifies the name of a variable where the availability of the table to be used in WRITE mode is to be stored. Values that can be stored and their meanings are: 1 table is available for WRITE mode 2 table is not available for WRITE mode . ----------------------------------------------------------------- */ BB_OPEN: /*@ */ if branch then call BRANCH address ISPEXEC if sw.0leave_open then return "CONTROL ERRORS RETURN" if thisds <> "" then, "LIBDEF ISPTLIB DATASET ID('"thisds"') STACK" "TBSTATS" tblid " STATUS1(s1) STATUS2(s2) STATUS3(s3) " if rc = 20 then do say tblid "is not a valid ISPF table" sw.0error_found = "1" end ; else, if thisds <> "" & s1 > 1 then do say "Table" tblid "not available." sw.0error_found = "1" end ; else, if s2 > 1 then do /* it's already open!!! */ sw.0leave_open = 1 /* don't mess it up */ return end "TBOPEN" tblid openmode.noupdt if rc > 8 then , sw.0error_found = 1 if thisds <> "" then, "LIBDEF ISPTLIB" return /*@ BB_OPEN */ /* Build the panels for the table display. . ----------------------------------------------------------------- */ BC_LOAD_PANELS: /*@ */ if branch then call BRANCH address TSO call BCA_GETNAMES /* table columns -*/ call BCH_HEADERS /* build panel lines -*/ "NEWSTACK" call BCP_LOADP1 /* load to temp ISPPLIB -*/ call BCQ_LOADP2 /* load to temp ISPPLIB -*/ "DELSTACK" return /*@ BC_LOAD_PANELS */ /* . ----------------------------------------------------------------- */ BCA_GETNAMES: /*@ */ if branch then call BRANCH address ISPEXEC "TBQUERY" tblid "KEYS(keynames) NAMES(varnames)" parse var keynames "(" keynames ")" parse var varnames "(" varnames ")" keynmes = keynames varnmes = varnames allnames = keynames varnames wordct = Words( allnames ) call BCAS_SCAN_TABLE /* get max col width -*/ return /*@ BCA_GETNAMES */ /* How much column width do we actually need? . ----------------------------------------------------------------- */ BCAS_SCAN_TABLE: /*@ */ if branch then call BRANCH address ISPEXEC "TBTOP" tblid do forever "TBSKIP" tblid /* next row */ if rc > 0 then leave /* end of table */ do bx = 1 to wordct /* every name */ name = Word( allnames,bx ) maxlen.name = Max( Length( Value( name )),maxlen.name ) end /* bx */ end /* forever */ if monitor = 0 then return say "Field length report" do bx = 1 to wordct name = Word( allnames,bx ) say Left( name,11 ) maxlen.name end /* bx */ return /*@ BCAS_SCAN_TABLE */ /* . ----------------------------------------------------------------- */ BCH_HEADERS: /*@ */ if branch then call BRANCH address ISPEXEC slug = "+S" /* P1 column header */ dashes = "+-" zees = "14"x"Z" zvarlist = "(ZCMD @S@" cols = slug /* P1 column header */ do bchx = 1 to Words(allnames) var = Word(allnames,bchx) slug = slug Left( var,maxlen.var ) if Length(slug) > maxusable then leave /* too long */ cols = slug dashes = dashes Copies( "-",maxlen.var ) zees = zees || Left( "?Z",maxlen.var+1 ) zvarlist = zvarlist var end /* forever */ zvarlist = zvarlist")" zees = zees"+" if Length(cols) < 4 then cols = cols, "# ....No KEYS.... ....No NAMES...." return /*@ BCH_HEADERS */ /* . ----------------------------------------------------------------- */ BCP_LOADP1: /*@ */ if branch then call BRANCH address ISPEXEC daid = daid.PLIB /* set the proper DATAID */ queue ")ATTR " queue " # TYPE(TEXT) INTENS(HIGH) " queue " 14 TYPE(INPUT) INTENS(LOW) PAD('.') CAPS(ON) " queue " ? TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) " queue ")BODY EXPAND(||) WIDTH(&ZSCREENW) " queue "+|-|-#TABLE" tblid "("thisds")+-|-| " queue "%COMMAND ===>_Z " queue "+ SORT ,, L fld=value / F5=refind " queue cols queue dashes queue ")MODEL " queue zees queue ")INIT " queue " .HELP = P1H " queue " .ZVARS = &ZVARLIST " queue " &ZSCROLLA = 'CSR' " queue " &@S@ = ' ' " queue ")REINIT " queue ")PROC " queue " IF (.PFKEY = 'PF05') " queue " &PFKEY = 'F5' " queue " .RESP = END " queue ")END " "LMOPEN DATAID("daid") OPTION(OUTPUT)" do queued() parse pull line "LMPUT DATAID("daid") MODE(INVAR) DATALOC(LINE)" , "DATALEN("zscreenw")" end "LMMADD DATAID("daid") MEMBER(P1)" "LMCLOSE DATAID("daid")" return /*@ BCP_LOADP1 */ /* . ----------------------------------------------------------------- */ BCQ_LOADP2: /*@ */ if branch then call BRANCH address ISPEXEC if sw.4EDIT then vtypvals = "INPUT" else vtypvals = "OUTPUT SKIP(ON)" parse var vtypvals vtyp vtypskip . daid = daid.PLIB /* set the proper DATAID */ queue ")ATTR " queue " 14 TYPE(INPUT) INTENS(LOW) PAD('.') CAPS(ON) " queue " ! TYPE("vtyp") INTENS(HIGH)" vtypskip queue " ? TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) " queue " # TYPE(TEXT) INTENS(HIGH) " queue ")BODY EXPAND(||) WIDTH(&ZSCREENW) " queue "+|-|-#TABLE" tblid "("thisds")+-|-| " queue "%COMMAND ===>_Z " queue "+ " queue "#VARIABLE T VALUE+ " queue "+ " queue ")MODEL " queue "?Z ?Z !Z " queue ")INIT " queue " .HELP = P2H " queue " .ZVARS='( ZCMD XVAR XTYPE XVALUE )' " queue " &ZSCROLLA = 'CSR' " queue ")END " "LMOPEN DATAID("daid") OPTION(OUTPUT)" do queued() parse pull line "LMPUT DATAID("daid") MODE(INVAR) DATALOC(LINE)" , "DATALEN("zscreenw")" end "LMMADD DATAID("daid") MEMBER(P2)" "LMCLOSE DATAID("daid")" return /*@ BCQ_LOADP2 */ /* . ----------------------------------------------------------------- */ BD_SHOW_TABLE: /*@ */ if branch then call BRANCH address ISPEXEC "LIBDEF ISPPLIB LIBRARY ID("@ddn.PLIB") STACK" "VGET (ZPF05) PROFILE" save_f5 = zpf05 @S@ = "" /* init */ do forever zpf05 = "END" ; "VPUT (ZPF05) PROFILE" "TBDISPL" tblid "PANEL(P1)" disp_rc = rc zpf05 = save_f5; "VPUT (ZPF05) PROFILE" if disp_rc > 8 then do zerrlm = exec_name "("BRANCH("ID")")", zerrlm , "K:"keynmes "N:"varnmes "SETMSG MSG(ISRZ002)" sw.0error_found = "1" "EDIT DATAID("daid.PLIB") MEMBER(P1) PROFILE(DEFAULT)" leave end if disp_rc = 8 then, if pfkey = "F5" then call Z_REFIND /* -*/ else leave if zcmd <> "" then do call BDC_ZCMD /* -*/ end ; else, do ztdsels upper @S@ /* action field */ if @S@ = "D" then "TBDELETE" tblid else do "TBGET" tblid "SAVENAME(xvars)" call BDA_BUILD_ROW call BDB_SHOW_ROW end if ztdsels = 1 then, /* never do the last one */ ztdsels = 0 else "TBDISPL" tblid /* next row #*/ end /* ztdsels */ @S@ = "" /* clear for re-display */ end /* forever */ "LIBDEF ISPPLIB" return /*@ BD_SHOW_TABLE */ /* . ----------------------------------------------------------------- */ BDA_BUILD_ROW: /*@ */ if branch then call BRANCH address ISPEXEC "TBCREATE XTABLE NOWRITE REPLACE KEYS(XVAR) NAMES(XTYPE XVALUE)" parse var xvars "(" xvars ")" xtype = "K" keynames = keynmes do while keynames <> "" parse var keynames xvar keynames xvalue = Value(xvar) "TBADD XTABLE" end /* keynames */ xtype = "N" varnames = varnmes do while varnames <> "" parse var varnames xvar varnames xvalue = Value(xvar) "TBADD XTABLE" end /* varnames */ xtype = "S" do while xvars <> "" parse var xvars xvar xvars xvalue = Value(xvar) "TBADD XTABLE" end /* xvars */ return /*@ BDA_BUILD_ROW */ /* . ----------------------------------------------------------------- */ BDB_SHOW_ROW: Procedure expose, /*@ */ (tk_globalvars) tblid keynames varnames xvars if branch then call BRANCH address ISPEXEC "CONTROL DISPLAY SAVE" "TBTOP XTABLE" call BDBA_PROCESS_ROW /* -*/ "TBEND XTABLE" "CONTROL DISPLAY RESTORE" return /*@ BDB_SHOW_ROW */ /* . ----------------------------------------------------------------- */ BDBA_PROCESS_ROW: /*@ */ if branch then call BRANCH address ISPEXEC sw.0KeyChange = "0" do forever "TBDISPL XTABLE PANEL(P2)" if zcmd <> "" then do upper zcmd if zcmd = "UPDATE" then do call BDBAL_LOAD_MAIN /* -*/ leave end /* UPDATE */ end /* zcmd */ if rc > 4 then leave /* PF3 ? */ do ztdsels if xtype = "K" then sw.0KeyChange = "1" /* Use TBADD */ "TBMOD XTABLE" @a@ = xvar /* for TRAPOUT purposes */ @b@ = xtype @c@ = xvalue if ztdsels = 1 then, /* never do the last one */ ztdsels = 0 else "TBDISPL XTABLE" /* next row #*/ end /* ztdsels */ "TBTOP XTABLE" end /* forever */ return /*@ BDBA_PROCESS_ROW */ /* . ----------------------------------------------------------------- */ BDBAL_LOAD_MAIN: /*@ */ if branch then call BRANCH address ISPEXEC "TBTOP XTABLE" do forever "TBSKIP XTABLE" if rc > 0 then leave if xtype = "S" then xvars = Space(xvars xvar,1) @z@ = Value(xvar,xvalue) /* load xvalue into xvar */ @a@ = xvalue end "TBMOD" tblid "SAVE("xvars")" /* update the main table */ return /*@ BDBAL_LOAD_MAIN */ /* . ----------------------------------------------------------------- */ BDC_ZCMD: /*@ */ if branch then call BRANCH address ISPEXEC parse var zcmd verb text if verb = "TPRINT" then do hdr. = 0 /* force re-do headers */ call BDCP_PRINT /* -*/ end /* PRINT */ else, if verb = "STATS" then do call BDCQ_STATS /* -*/ end /* STATS */ else, if verb = "SORT" then do call BDCS_SORT /* -*/ end /* SORT */ else, if Wordpos(Left(verb,1),"F L") > 0 then do parse var text fld . "=" val . if Symbol(fld) = "BAD" then do zerrsm = "Typo!" zerrlm = "Field-name" fld "is invalid." "SETMSG MSG(ISRZ002)" return end /* typo */ "TBVCLEAR" tblid @z@ = Value(fld,val"*") /* load value */ "TBSARG" tblid "NAMECOND("fld",EQ)" "TBTOP" tblid call Z_TBSCAN /* -*/ end /* L LOCATE F FIND */ return /*@ BDC_ZCMD */ /* Print the table . ----------------------------------------------------------------- */ BDCP_PRINT: /*@ */ pp_tv = trace() /* what setting at entry ? */ if branch then call BRANCH address ISPEXEC address TSO "NEWSTACK" if \sw.0scanned then, /* table has not been scanned */ call BDCPA_SCAN /* -*/ call BDCPH_HEADERS /* -*/ "TBTOP" tblid parse value "0" with linect asa do forever "TBSKIP" tblid "SAVENAME(XVARS)" /* next row */ if rc > 0 then leave call BDCPF_FORMAT_LINE /* -*/ linect = linect + 1 asa = "" if linect > 55 then do /* end-of-page */ parse value "0 1" with linect asa . call BDCPH_HEADERS /* -*/ end end /* forever */ rc = Trace("O"); rc = trace(pp_tv) qcount = queued() /* how many lines ? */ call BDCPP_WHAT_PRINTER /* -*/ call BDCPW_WRITEQ /* put queue to printer -*/ address TSO "DELSTACK" return /*@ BDCP_PRINT */ /* Scan the table to determine the maximum length of each variable. A short variable may have a longer name, and we want to accomodate that. Ignore extension variables. . ----------------------------------------------------------------- */ BDCPA_SCAN: /*@ */ if branch then call BRANCH address ISPEXEC do pt = 1 to Words(allnames) name = Word(allnames,pt) /* the variable name */ if ll.name < Length(name) then, ll.name = Length(name) end "TBTOP" tblid do forever "TBSKIP" tblid if rc > 0 then leave /* end of table */ do pt = 1 to Words(allnames) name = Word(allnames,pt) ll = Length(Value(name)) /* length of data */ if ll.name < ll then, /* */ ll.name = ll /* save bigger value */ end /* pt */ end /* forever */ sw.0scanned = '1' if monitor then do do pt = 1 to Words(allnames) name = Word(allnames,pt) say Right(name,9) ll.name end /* pt */ end return /*@ BDCPA_SCAN */ /* This is very dependent upon the shape of the table as determined in BCA_GETNAMES. Also, each line may have extension variables. . ----------------------------------------------------------------- */ BDCPF_FORMAT_LINE: /*@ */ if branch then call BRANCH address TSO line = "" do bhx = 1 to Words(localnames) token = Word(localnames,bhx) line = line Left(Value(token),ll.token) end /* bhx */ queue line return /*@ BDCPF_FORMAT_LINE */ /* Queue header-records . ----------------------------------------------------------------- */ BDCPH_HEADERS: /*@ */ if branch then call BRANCH address TSO if hdr.0 = 0 then, /* TRUE only if never called */ call BDCPH0_SETUP /* build column headers -*/ do hx = 1 to hdr.0 /* each header */ queue hdr.hx end /* hx */ return /*@ BDCPH_HEADERS */ /* Build column-headers . ----------------------------------------------------------------- */ BDCPH0_SETUP: /*@ */ if branch then call BRANCH address TSO call BDCPH0S_LOCALNAMES /* sets localnames -*/ parse value "2" with hdr.0 hdr.1 hdr.2 do bhx = 1 to Words(localnames) /* for each localname */ token = Word(localnames,bhx) /* isolate one */ hdr.1 = hdr.1 Center(token,ll.token) /* center in its slot */ hdr.2 = hdr.2 Copies("-",ll.token) /* dashes for underscores */ end /* bhx */ maxlen = Length(hdr.2) /* dashes */ hdr.1 = Overlay("1",hdr.1,1,1) /* insert paqe-eject */ return /*@ BDCPH0_SETUP */ /* Allow the caller to exclude fields from the print-spec and to arrange the others in proper order. . ----------------------------------------------------------------- */ BDCPH0S_LOCALNAMES: /*@ */ if branch then call BRANCH address ISPEXEC "TBCREATE @ARR KEYS(FLDNAME) NAMES(PRI ARMSG) NOWRITE REPLACE" pri = 0 do bhx = 1 to Words(allnames allxvars) fldname = Word(allnames allxvars,bhx) armsg = "" pri = pri + 5 "TBADD @ARR" /* load name to @ARR table */ end /* bhx */ sel = "" /* init */ do forever "TBSORT @ARR FIELDS(PRI,N,A)" "TBTOP @ARR" "TBDISPL @ARR PANEL(ARRANGE)" if rc > 4 then leave /* PF3 ? */ do ztdsels select when sel = "X" then do if armsg = "" then do armsg = "Excluded" /* mark EXCLUDED */ pri = 999 /* push to bottom */ end else parse value 998 with pri armsg end otherwise nop end /* select */ "TBMOD @ARR" /* reload changed line */ if ztdsels > 1 then "TBDISPL @ARR" end /* ztdsels */ sel = "" end /* forever */ localnames = "" do forever "TBSKIP @ARR" /* next row */ if rc > 4 then leave /* end of table? */ if armsg <> "" then leave /* no EXCLUDED lines */ localnames = localnames fldname /* add name to list */ end /* forever */ "TBEND @ARR" /* finished with table */ return /*@ BDCPH0S_LOCALNAMES */ /* Ask the user where they want it printed. . ----------------------------------------------------------------- */ BDCPP_WHAT_PRINTER: /*@ */ if branch then call BRANCH address ISPEXEC zwinttl = "Target Printer" "VGET ZPFCTL"; save_zpf = zpfctl /* save current setting */ zpfctl = "OFF"; "VPUT ZPFCTL" /* PFSHOW OFF */ "ADDPOP ROW(8) COLUMN(10)" "DISPLAY PANEL(PRTCONF)" disp_rc = rc "REMPOP ALL" zpfctl = save_zpf; "VPUT ZPFCTL" /* restore */ return /*@ BDCPP_WHAT_PRINTER */ /* Flush the queue to the printer . ----------------------------------------------------------------- */ BDCPW_WRITEQ: /*@ */ if branch then call BRANCH address TSO maxrecl = maxlen + 4 if prtcls <> "0" then do "ALLOC FI(@PRT) NEW REU DELETE UNIT(VIO) SPACE(1 5) TRACKS", "RECFM(V B A) LRECL("maxrecl") BLKSIZE(0)" "EXECIO" queued() "DISKW @PRT (FINIS" "PRINTDS FILE(@PRT) CCHAR CLASS("prtcls") DEST("prtdest") " zerrsm = "Printed" zerrlm = "Printed" qcount "records via PRINTDS to", "Class" prtcls", Dest" prtdest end /* Printed */ else do /* prtcls was zero */ outdsn = "@@."tblid".LIST" if Sysdsn(outdsn) = "OK" then do @oldstat = Msg("OFF") "DELETE" outdsn @z@ = Msg(@oldstat) end "ALLOC FI(@PRT) NEW REU CATALOG UNIT(SYSDA) SPACE(1 5) TRACKS", "DA("outdsn")", "RECFM(V B A) LRECL("maxrecl") BLKSIZE(0)" "EXECIO" queued() "DISKW @PRT (FINIS" zerrsm = "Not printed" zerrlm = qcount "print records were spooled to", "dataset" tblid".LIST", "because", "Class" prtcls "was specified." end /* Not Printed */ "FREE FI(@PRT)" address ISPEXEC "SETMSG MSG(ISRZ002)" return /*@ BDCPW_WRITEQ */ /* Retrieve stats for the table and present them in a pop-up. 'TBSTATS' tablenam 'CDATE('cdatname') CTIME('ctimname'), UDATE('udatname') UTIME('utimname') USER('username'), ROWCREAT('rcrtname') ROWCURR('rcurname'), ROWUPD('rupdname') TABLEUPD('tupdname'), SERVICE('servname') RETCODE('retcname'), STATUS1('sta1name') STATUS2('sta2name'), STATUS3('sta3name') LIBRARY('libname'), CDATE4D('cdat4dnm') UDATE4D('udat4dnm')' 'LMMSTATS DATAID('dataid') MEMBER('mbrname') VERSION('ver1'), MODLEVEL('mod1') CREATED('cdate') MODDATE('mdate'), MODTIME('mtime') CURSIZE('csize') INITSIZE('isize'), MODRECS('mrecs') USER('userid') CREATED4('cdate4'), MODDATE4('mdate4') DELETE' . ----------------------------------------------------------------- */ BDCQ_STATS: /*@ */ if branch then call BRANCH address ISPEXEC "TBSTATS" tblid, "CDATE(cdatname) CTIME(ctimname)", "UDATE(udatname) UTIME(utimname) USER(username)", "ROWCREAT(rcrtname) ROWCURR(rcurname)", "STATUS1(sta1 ) STATUS2(sta2 )", "STATUS3(sta3 )", "CDATE4D(cdat4dnm) UDATE4D(udat4dnm)" parse value rcrtname+0 rcurname+0 with, rcrtname rcurname . sta1.1 = "Exists in library chain" sta1.2 = "Does not exist in library chain" sta1.3 = "ISPTLIB not allocated" sta2.1 = "Table not open" sta2.2 = "NOWRITE" sta2.3 = "WRITE" sta2.4 = "SHARED NOWRITE" sta2.5 = "SHARED WRITE" sta3.1 = "Available for WRITE" sta3.2 = "Not available for WRITE" sta1rsn = sta1.sta1 sta2rsn = sta2.sta2 sta3rsn = sta3.sta3 "CONTROL DISPLAY SAVE" "VGET ZPFCTL"; save_zpf = zpfctl /* save current setting */ zpfctl = "OFF"; "VPUT ZPFCTL" /* PFSHOW OFF */ "ADDPOP ROW(2) COLUMN(3)" "DISPLAY PANEL(TBSTATS)" "REMPOP ALL" zpfctl = save_zpf; "VPUT ZPFCTL" /* restore */ "CONTROL DISPLAY RESTORE" return /*@ BDCQ_STATS */ /* Sort the table . ----------------------------------------------------------------- */ BDCS_SORT: /*@ */ if branch then call BRANCH address ISPEXEC zerrlm = "" sortspec = "" do while text <> "" parse var text spec text parse var spec fldnm "," fldtyp "," sortdir parse value fldtyp "C" with fldtyp . parse value sortdir "A" with sortdir . if WordPos(fldnm,allnames) = 0 then do /* wrong name */ zerrsm = "Sortspec error" zerrlm = zerrlm " Incorrect name: you specified >"fldnm"<. ", "The valid field names for this table are >", Space(allnames,1)"<. " end /* bad fldnm */ if Pos(fldtyp,"CN") = 0 then do /* wrong type */ zerrsm = "Sortspec error" zerrlm = zerrlm " Incorrect type: you specified >"fldtyp"<. ", "The valid field types are >C N<." end if Pos(sortdir,"AD") = 0 then do /* wrong dir */ zerrsm = "Sortspec error" zerrlm = zerrlm " Incorrect DIR: you specified >"sortdir"<. ", "The valid sort directtions are >A D<." end if zerrlm <> "" then do /* error */ zerrlm = Strip(zerrlm " Sort was not done.") "SETMSG MSG(ISRZ002)" return end sortspec = sortspec fldnm","fldtyp","sortdir end /* text */ sortspec = Space(sortspec,1) /* squeeze out extra blanks */ sortspec = Translate(sortspec,","," ") /* blanks to commas */ "TBSORT" tblid "FIELDS("sortspec")" if rc > 0 then do zerrsm = "TBSORT failed." zerrlm = exec_name "("BRANCH("ID")")", zerrlm "SETMSG MSG(ISRZ002)" end return /*@ BDCS_SORT */ /* . ----------------------------------------------------------------- */ BX_CLOSE_TABLE: /*@ */ if branch then call BRANCH address ISPEXEC "LIBDEF ISPTABL DATASET ID('"thisds"') STACK" if sw.0leave_open then, if sw.4EDIT then "TBSAVE" tblid else nop else, /* don't leave open */ if sw.4EDIT then "TBCLOSE" tblid else "TBEND" tblid "LIBDEF ISPTABL" return /*@ BX_CLOSE_TABLE */ /* Drop LIBDEFs . ----------------------------------------------------------------- */ BZ_EPILOG: /*@ */ if branch then call BRANCH address ISPEXEC 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 /*@ BZ_EPILOG */ /* Position the cursor, then TBSCAN . ----------------------------------------------------------------- */ Z_REFIND: /*@ */ if branch then call BRANCH address ISPEXEC "TBSKIP" tblid "ROW("lastfnd") NOREAD" call Z_TBSCAN /* -*/ pfkey = "" /* prevent re-use */ return /*@ Z_REFIND */ /* The table is positioned to find a row and the argument is set. . ----------------------------------------------------------------- */ Z_TBSCAN: /*@ */ if branch then call BRANCH address ISPEXEC "TBSCAN" tblid "ROWID(LASTFND) POSITION(LASTCRP)" if rc = 8 then do /* not found */ zerrsm = "Not found" if pfkey = "F5" then, zerrlm = "End of table encountered." else, zerrlm = "No rows found to match" fld"="val zerrlm = exec_name "("BRANCH("ID")")", zerrlm address ISPEXEC "SETMSG MSG(ISRZ002)" end /* not found */ "TBSKIP" tblid "ROW("lastfnd") NOREAD" return /*@ Z_TBSCAN */ /* . ----------------------------------------------------------------- */ 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 address ISPEXEC "VGET (ZSCREENW)" fb80po.0 = "NEW DEL UNIT(VIO) SPACE(5 5) TRACKS DIR(40)", "RECFM(F B) LRECL("zscreenw") BLKSIZE(0)" 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 sourceline(currln) <> "/*" text = sourceline(currln) /* save with a short name ! */ if Left(text,3) = ")))" then do /* package the queue */ parse var text ")))" ddn mbr . /* PLIB PANL001 maybe */ if Pos(ddn,ddnlist) = 0 then do /* doesn't exist */ ddnlist = ddnlist ddn /* keep track */ @ddn = ddn || Random(999) @ddn.ddn = @ddn 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("zscreenw")" 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 /*@ DEIMBED */ /* . -------------------------------------------------------------------*/ HELP: /*@ */ address TSO;"CLEAR" if helpmsg <> "" then say helpmsg; say "" ex_nam = Left(exec_name,8) /* predictable size */ say " "ex_nam" Displays any specified table. " say " " say " Syntax: "ex_nam" tblname " say " TBLIB tbllib (or) " say " IN tbllib " say " UPDATE " say " " say " tblname identifies the member in an ISPTLIB library to be " say " viewed/updated. " say " " say " tbllib identifies the ISPF Table Library from which to " say " retrieve the table. " say " " say " UPDATE (a switch in PARMS) requests that tblname be made " say " available for changes. " say " " "NEWSTACK"; pull; "CLEAR"; "DELSTACK" say " Debugging tools provided include: " say " " say " BRANCH: show all paragraph entries. " say " " say " TRACE tv: will use value following TRACE to place the execution in" say " 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 "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 */ /* ))) PLIB PRTCONF Print parameters )ATTR % TYPE( TEXT ) INTENS( HIGH ) SKIP( ON ) + TYPE( TEXT ) INTENS( LOW ) SKIP( ON ) _ TYPE( INPUT ) INTENS( HIGH ) CAPS( ON ) { TYPE( OUTPUT ) INTENS( HIGH ) JUST( RIGHT ) )BODY WINDOW(60,7) + + % {qcount+lines to print % {maxlen+(longest line) + + Class ===>_z+ Use Class%0+to suppress print. + Dest ===>_prtdest+ )INIT .ZVARS = '(PRTCLS)' )PROC )END ))) PLIB TBSTATS Table statistics )ATTR % TYPE( TEXT ) INTENS( HIGH ) SKIP( ON ) + TYPE( TEXT ) INTENS( LOW ) SKIP( ON ) _ TYPE( INPUT ) INTENS( LOW ) CAPS( ON ) @ TYPE( TEXT ) INTENS( HIGH ) COLOR( YELLOW ) ! TYPE( INPUT ) INTENS( NON ) { TYPE( OUTPUT ) INTENS( HIGH ) SKIP( ON ) CAPS( OFF ) )BODY WINDOW(68,12) @ % Statistics for{tblid + + + Created :{cdatname{ctimname+ Rows then:{rcrtname+ + {cdat4dnm + + Last Updated:{udatname{utimname+ Rows now :{rcurname+ + {udat4dnm + By ::>{username + + S1:{sta1 {sta1rsn + S2:{sta2 {sta2rsn + S3:{sta3 {sta3rsn )INIT )PROC )END ))) PLIB P1H Primary panel HELP )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 ) )BODY EXPAND(||) WIDTH(&ZSCREENW) %TUTORIAL |-| Table Overview |-| TUTORIAL %Command ===>_ZCMD + This panel (P1) shows all rows from the named table. The panel's header also shows the name of the dataset in which it was found. You may select any row(s) for a display of the individual fields which may be larger than the canonical 8-characters shown on this display. Further, any extension variables which are specific to a row will be shown on the Row Detail display. Primary commands recognized: L, SORT, TPRINT, STATS % L + % SORT+ "sortspec" is one or more of with "dir" defaulting to "A" (ascending) and "type" defaulting to "C" (character). % TPRINT +Print the table % STATS +Display the table statistics )PROC &ZCONT = P1H &ZUP = P1H )END ))) PLIB P2H Contents panel HELP )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 ) )BODY EXPAND(||) WIDTH(&ZSCREENW) %TUTORIAL |-| Row Detail |-| TUTORIAL %Next Selection ===>_ZCMD + This panel (P2) displays the contents of a single table row. Fields are designated as%"K"+(key),%"N"+(name), or%"S"+(extension). If the data on the panel is changed%and+you are authorized to write on the ISPTABL dataset, the changes may be set with the primary command%UPDATE.+ )PROC &ZCONT = P2H &ZUP = P2H )END ))) PLIB ARRANGE Specify field arrangement )ATTR % TYPE( TEXT ) INTENS( HIGH ) SKIP( ON ) + TYPE( TEXT ) INTENS( LOW ) SKIP( ON ) _ TYPE( INPUT ) INTENS( HIGH ) CAPS( ON ) # TYPE( INPUT ) INTENS( HIGH ) JUST( RIGHT ) ! TYPE( OUTPUT ) INTENS( HIGH ) SKIP( ON ) @ TYPE( OUTPUT ) INTENS( LOW ) SKIP( ON ) )BODY EXPAND(||) WIDTH(&ZSCREENW) %|-| Field Arrangement +|-| %Command ===>_ZCMD %Scroll ===>_ZAMT+ + "X" to mark "non-print" / V Field Position )MODEL _z!fldname + #pri+ @armsg )INIT .ZVARS = '(SEL)' .HELP = ARRH )REINIT )PROC IF (.PFKEY = 'PF05') &PFKEY = 'F5' .RESP = END )END ))) PLIB ARRH Field arrangement HELP )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 ) )BODY EXPAND(||) WIDTH(&ZSCREENW) %TUTORIAL |-| Row Detail |-| TUTORIAL %Next Selection ===>_ZCMD + Panel%ARRANGE+allows you to specify which columns to print and in what order. The%Position+value shown is relative; it is used only to determine which field is leftmost and which rightmost. To place a column between two others, change its position number appropriately. You may%X+any column to exclude it from the output. )PROC &ZCONT = ARRH &ZUP = ARRH )END */