/* REXX APF The core code here came from IBM-MAIN and it has been dressed up to make it considerably more Gebraucherfreundlich. |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| | | | WARNING: EMBEDDED COMPONENTS. | | See text following TOOLKIT_INIT | | | |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| Written by Frank Clarke 20010516 Impact Analysis . SYSPROC TRAPOUT Modification History ccyymmdd xxx ..... .... */ 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" call A_INIT /* -*/ call B_TABLE_OPS /* -*/ call ZB_SAVELOG /* -*/ if \sw.nested then call DUMP_QUEUE /* -*/ exit /*@ APF */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO call A0_SETUP_LOG /* -*/ $tn$ = "APFLIST" return /*@ A_INIT */ /* . ----------------------------------------------------------------- */ A0_SETUP_LOG: /*@ */ if branch then call BRANCH address TSO parse value "0" with, log# log. parse value Date("S") Time("S") Time("N") with, yyyymmdd sssss hhmmss . parse var yyyymmdd 4 yrdigit 5 mm 7 dd /* 9 12 14 maybe */ if Pos(yrdigit,"13579") > 0 then mm = mm + 12 /* mm=24 */ logtag = Substr("ABCDEFGHIJKLMNOPQRSTUVWX",mm,1) /* logtag=X */ subid = logtag""dd""Right(sssss,5,0) /* X1423722 ? */ vb4k.0 = "NEW CATALOG UNIT(SYSDA) SPACE(1 5) TRACKS", "RECFM(V B) LRECL(4096) BLKSIZE(0)" vb4k.1 = "SHR" /* if it already exists... */ logdsn = "@@LOG."exec_name"."subid".LIST" call ZL_LOGMSG("Log started by" Userid() yyyymmdd hhmmss) return /*@ A0_SETUP_LOG */ /* . ----------------------------------------------------------------- */ B_TABLE_OPS: /*@ */ if branch then call BRANCH address ISPEXEC call BA_PROLOG /* -*/ call BD_DISPLAY /* -*/ call BZ_EPILOG /* -*/ return /*@ B_TABLE_OPS */ /* . ----------------------------------------------------------------- */ BA_PROLOG: /*@ */ if branch then call BRANCH address ISPEXEC call DEIMBED /* -*/ call BAA_BUILD_TABLE /* -*/ call BAL_LOAD_TABLE /* -*/ 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 */ /* . ----------------------------------------------------------------- */ BAA_BUILD_TABLE: /*@ */ if branch then call BRANCH address ISPEXEC "TBCREATE" $tn$ "KEYS(DSN) NAMES(VOL SEQ) NOWRITE REPLACE" return /*@ BAA_BUILD_TABLE */ /* . ----------------------------------------------------------------- */ BAL_LOAD_TABLE: /*@ */ if branch then call BRANCH address ISPEXEC NUMERIC DIGITS 10 CVT = C2d(Storage(10,4)) /* point to cvt */ CVTAUTHL = C2d(Storage(D2x(CVT + 484),4)) /* point to authlib tbl */ If CVTAUTHL <> C2d('7FFFF001'x) then do /* static list ? */ NUMAPF = C2d(Storage(D2x(CVTAUTHL),2)) /* # APF libs in table */ APFOFF = 2 /* first ent in APF tbl */ Do I = 1 to NUMAPF LEN = C2d(Storage(D2x(CVTAUTHL+APFOFF),1)) VOL.I = Storage(D2x(CVTAUTHL+APFOFF+1),6) DSN.I = Storage(D2x(CVTAUTHL+APFOFF+1+6),LEN-6) APFOFF = APFOFF + LEN +1 End End /* CVTAUTHL */ Else Do /* dynamic APF list via PROGxx */ ECVT = C2d(Storage(D2x(CVT + 140),4)) /* point to CVTECVT */ ECVTCSVT = C2d(Storage(D2x(ECVT + 228),4)) /* point to CSV table */ APFA = C2d(Storage(D2x(ECVTCSVT + 12),4)) /* APFA */ AFIRST = C2d(Storage(D2x(APFA + 8),4)) /* First entry */ ALAST = C2d(Storage(D2x(APFA + 12),4)) /* Last entry */ LASTONE = 0 /* flag for end of list */ NUMAPF = 1 /* tot # of entries in list */ Do forever DSN.NUMAPF = Storage(D2x(AFIRST+24),44) /* DSN of APF library */ DSN.NUMAPF = Strip(DSN.NUMAPF) /* remove blanks */ CKSMS = Storage(D2x(AFIRST+4),1) /* DSN of APF library */ if bitand(CKSMS,'80'x) = '80'x then, /* SMS data set? */ VOL.NUMAPF = '*SMS* ' /* SMS control dsn */ else, VOL.NUMAPF = Storage(D2x(AFIRST+68),6) /* VOLSER of APF lib */ If Substr(DSN.NUMAPF,1,1) <> X2c('00') /* check for deleted */ then NUMAPF = NUMAPF + 1 /* APF entry */ AFIRST = C2d(Storage(D2x(AFIRST + 8),4)) /* next entry */ if LASTONE = 1 then leave If AFIRST = ALAST then LASTONE = 1 End NUMAPF = NUMAPF-1 End call ZL_LOGMSG(numapf "APF entries found") do ix = 1 to numapf vol = vol.ix dsn = dsn.ix seq = ix "TBADD" $tn$ call ZL_LOGMSG("RC="rc seq dsn) end /* ix */ "TBSORT" $tn$ "FIELDS(SEQ,N,A)" return /*@ BAL_LOAD_TABLE */ /* . ----------------------------------------------------------------- */ BD_DISPLAY: /*@ */ if branch then call BRANCH address ISPEXEC do forever "TBDISPL" $tn$ "PANEL(APFLIST)" if rc > 4 then leave /* PF3 ? */ do ztdsels "CONTROL DISPLAY SAVE" "BROWSE DATASET('"dsn"')" "CONTROL DISPLAY RESTORE" if ztdsels = 1 then, /* never do the last one */ ztdsels = 0 else "TBDISPL" $tn$ /* next row */ end /* ztdsels */ action = '' /* clear for re-display */ end /* forever */ return /*@ BD_DISPLAY */ /* . ----------------------------------------------------------------- */ BZ_EPILOG: /*@ */ if branch then call BRANCH address ISPEXEC "TBEND" $tn$ /* finished with table */ 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 */ /* . ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ address TSO return /*@ LOCAL_PREINIT */ /* subroutines below LOCAL_PREINIT are not selected by SHOWFLOW */ /* Parse out the embedded components at the back of the source code. . ----------------------------------------------------------------- */ DEIMBED: Procedure expose, /*@ */ (tk_globalvars) ddnlist $ddn. daid. address TSO fb80po.0 = "NEW UNIT(VIO) SPACE(5 5) TRACKS DIR(40)", "RECFM(F B) LRECL(80) 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(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 /*@ DEIMBED */ /* . ----------------------------------------------------------------- */ ZB_SAVELOG: /*@ */ if branch then call BRANCH address TSO if Symbol("LOG#") = "LIT" then return /* not yet set */ "ALLOC FI($LOG) DA("logdsn") REU" vb4k.0 "EXECIO" log# "DISKW $LOG (STEM LOG. FINIS" "FREE FI($LOG)" return /*@ ZB_SAVELOG */ /* . ----------------------------------------------------------------- */ ZL_LOGMSG: Procedure expose, /*@ */ (tk_globalvars) log. log# rc = Trace("O") address TSO parse arg msgtext parse value log#+1 msgtext with, zz log.zz 1 log# . if monitor then say, msgtext return /*@ ZL_LOGMSG */ /* . ----------------------------------------------------------------- */ HELP: /*@ */ address TSO;"CLEAR" if helpmsg <> "" then do ; say helpmsg; say ""; end ex_nam = Left(exec_name,8) /* predictable size */ /* The following template may be used to customize HELP-text for this routine. say " "ex_nam" ........ " say " ........ " say " " say " Syntax: "ex_nam" .......... " say " .......... " say " " say " .... .......... " say " .......... " "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 "ex_nam" parameters (( debug-options " say " " say " For example: " say " " say " TSO "ex_nam" (( MONITOR TRACE ?R " .*/ 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 */ "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 ssend = ssbeg + ssend do ssii = ssbeg to ssend ; say sourceline(ssii) ; 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") "O" with tv . tk_globalvars = "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 APFLIST )ATTR % TYPE(TEXT) INTENS(HIGH) SKIP(ON) + TYPE(TEXT) INTENS(LOW) SKIP(ON) _ TYPE(INPUT) INTENS(HIGH) CAPS(ON) ! TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) } TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) JUST(RIGHT) @ TYPE(OUTPUT) INTENS(LOW) SKIP(ON) )BODY EXPAND(ºº) %º-º APF Libraries +º-º %Command ===>_ZCMD %Scroll ===>_ZAMT + Dataset Name Seq Volume )MODEL _Z!DSN }seq !VOL )INIT .ZVARS = '(ACTION)' .HELP = APFLSTH )REINIT )PROC )END )))PLIB APFLSTH )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(ºº) %TUTORIAL º-º APF Libraries º-º TUTORIAL %Next Selection ===>_ZCMD % Select any row or rows with any character to invoke BROWSE on the selected dataset(s). You will be placed into BROWSE if you have sufficient authority to open the directory for READ. )PROC )END */