/* REXX LA v.3 LISTA ST into a stack for one DDName or to screen (with or without DCB info) for one DDName or all of them. Use '(routine name) ?' for HELP-text. Written by Frank Clarke, rexxhead@yahoo.com Impact Analysis . SYSEXEC TRAPOUT Modification History 19980605 fxc standardized; added REXXSKEL v.19980225; DECOMM; version 2 will deliver all dsnames for any or all ddnames; 19991117 fxc upgrade from v.19980225 to v.19991109; 20010612 fxc v.3; WIDEHELP and general spiffing; 20210405 fxc upgrade from v.19991109 to v.20210402 20230401 fxc SYSUMON only if not testing 20230726 fxc adjust HELP; 20230806 fxc chg SYSPROC to SYSEXEC in Impact Analysis; 20231201 fxc disable SYSUMON; 20240310 fxc IDENT; 20240415 fxc DUMP_QUEUE quiet; */ arg argline address TSO /* REXXSKEL ver.20210402 */ arg parms "((" opts signal on syntax signal on novalue call TOOLKIT_INIT /* conventional start-up -*/ rc = Trace("O") rc = trace(tv) info = parms /* to enable parsing */ call A_INIT /* -*/ call B_DDN_LIST /* -*/ call C_FIND_DSNS /* -*/ if sw.0stack + sw.0list = 0 then exit if \sw.0list then, if dsnstr <> "" then push dsnstr /* load stack */ if queued() = 0 then, if sw.0list then push ddname": (empty)" else, push "(empty)" if \sw.nested then call DUMP_QUEUE 'quiet' /* -*/ exit /*@ LA */ /* Initialization . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO parse value "" with, dsnstr dc. ln. start. end. ddn. parse value "0 0 0 0 0 0 0 0 0 0 0" with, ii ddnx ddn# dsnx . if \sw.nested then sw.0stack = "0" parse var parms ddname ddname = Space(ddname,1) rc = Outtrap("ln.") /* open trap */ "LISTA ST" rc = Outtrap("OFF") /* close trap */ return /*@ A_INIT */ /* LISTA ST has been run and its output trapped. For each line, collect DSNs that belong to each DDN by recording the line numbers on which the attached DSNs start and end. . ----------------------------------------------------------------- */ B_DDN_LIST: /*@ */ if branch then call BRANCH address TSO /* Build DDName stack */ do trapx = 1 to ln.0 /* for each trapped line */ if Left(ln.trapx,1) <> "" then, /* DSName */ iterate /* pick it up later */ if Substr(ln.trapx,3,1) <> " " then do /* new DDName */ ddn# = ddn# + 1 /* DDName index */ ddn.ddn# = Word(ln.trapx,1) /* save DDName */ start.ddn# = trapx - 1 /* 1st dsn on previous line */ end.ddn# = trapx - 1 /* ...maybe the last one, too */ end else if Left(ln.trapx,1) = " " then, /* concatenated DSName */ end.ddn# = trapx - 1 /* new end-point */ end /* trapx */ return /*@ B_DDN_LIST */ /* . Given: array of DDNames (ddn.), the location of the 1st DSName for the DDName (start.) and the last DSName (end.); produce the requested output. . ----------------------------------------------------------------- */ C_FIND_DSNS: /*@ */ if branch then call BRANCH address TSO if \sw.nested then "CLEAR" do ddnx = 1 to ddn# /* for all ddnames */ if Wordpos(ddn.ddnx,ddname) > 0 |, /* target DDName ? */ ddname = "" then do /* or none specified */ wrkddn = ddn.ddnx /* save for printing */ do dsnx = start.ddnx to end.ddnx by 2 /* for each DSName */ if sw.0stack then do /* STACK requested */ if sw.0detail then queue Left(wrkddn,8) ln.dsnx; else, dsnstr = dsnstr ln.dsnx /* form one-line list */ end else, if sw.0list then do /* LIST requested */ dsnstr = dsnstr ln.dsnx /* form one-line list */ end else, if sw.0dcb then do /* DCB requested */ rc = Outtrap("dc.") /* open trap */ "LISTD '"ln.dsnx"'" /* LISTD to trap */ parse var dc.3, /* delivered DCB */ recfm, lrecl, blksize, dsorg . /* ...and clip off the rest. */ slug = Left(recfm,3), /* must all be equal */ Right(lrecl,4), /* must all be equal */ Right(blksize,7), /* right-justify */ dsorg /* must all be equal */ say Left(Left(wrkddn,10), /* DDName */ ln.dsnx,50), /* DSName */ slug /* DCB */ rc = Outtrap("off") /* close trap */ end else, /* not STACK, not DCB */ say Left(Left(wrkddn,10), /* DDName */ ln.dsnx,50) /* DSName */ wrkddn="" /* group-indicate */ end /* dsnx */ if sw.0list then do queue ddn.ddnx":" dsnstr dsnstr = "" end end /* ddn = ddname */ end /* ddnx */ return /*@ C_FIND_DSNS */ /* Parse non-canonical opts to the right of the '((' . ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ address TSO sw.0dcb = SWITCH("DCB") sw.0detail = SWITCH("DETAIL") sw.0stack = SWITCH("STACK") sw.0list = SWITCH("LIST") return /*@ LOCAL_PREINIT */ /* . ----------------------------------------------------------------- */ HELP: /*@ */ address TSO "CLEAR" if helpmsg <> "" then say helpmsg ex_nam = Left(exec_name,8) /* predictable size */ say " " say " "ex_nam" (v.3) Allocation List to stack or display " say " " say " Syntax: "ex_nam" ddname-list (( options " say " " say " options may contain any of: " say " DCB STACK DETAIL LIST " say " " say " DCB produces a list of DSNames + DCBs. DCB is only " say " appropriate for DISPLAY (that is, not STACK). " say " " say " STACK returns information to a calling routine via the " say " data stack. The format depends on other options. " say " STACK is ignored unless invocation is via an " say " independent caller. " say " " say " STACK and DCB are mutually exclusive. " say " " say " more.... " "NEWSTACK"; pull; "CLEAR"; "DELSTACK" say " " say " DETAIL If present, this requests the output be returned in " say " two-column format with the first column being a " say " group-indicated DDName and the second column the " say " DSName. " say " If not present, the output is returned as a string " say " containing the fully-qualified, unquoted list of " say " DSNames allocated to the specified DDName. " say " " say " LIST If present, this requests the output be returned one " say " line per DDName in the format " say " ddn>: dsnlist " say " The DSNames are unquoted fully-qualified. " say " " say " DETAIL and LIST are mutually exclusive. " say " " say " more.... " "NEWSTACK"; pull; "CLEAR"; "DELSTACK" say " " say " Debugging tools provided include: " say " " say " MONITOR displays key information throughout processing. " say " Displays most paragraph names upon entry. " 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" 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 arg mode . "QSTACK" /* how many stacks? */ stk2dump = rc - tk_init_stacks /* remaining stacks */ if stk2dump = 0 & queued() = 0 then return if mode <> "QUIET" then, 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. */ if mode <> "QUIET" then, say "Processing Stack #" dd " Total Lines:" queued() do queued();parse 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 */ sw.nested = sysvar("SYSNEST") = "YES" sw.batch = sysvar("SYSENV") = "BACK" sw.inispf = sysvar("SYSISPF") = "ACTIVE" 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 . 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 */