/* REXX FETCH Edit a dataset based on a nickname (See ZA_LOAD_NAMES for instructions for adding new synonyms.) |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| | | | WARNING: EMBEDDED COMPONENTS. | | See text following TOOLKIT_INIT | | | |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| Written by Frank Clarke, Oldsmar FL Impact Analysis . SYSEXEC TBLGEN . SYSEXEC STRSORT . SYSEXEC TRAPOUT Modification History 20090929 fxc chg LMMDISP to MEMLIST; */ arg argline address TSO /* REXXSKEL ver.19991109 */ 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 */ if \sw.inISPF then do arg line "ISPSTART CMD("exec_name line")" /* Invoke ISPF if nec. */ exit /* ...and restart it */ end call A_INIT /* -*/ if Pos( "*",parms ) = 0 &, dsid <> "" then, /* specified, not generic */ call B_GET_IT /* -*/ else, /* no DSID specified */ call C_ISPF_IT /* -*/ exit /*@ FETCH */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO func. = "VIEW" func.1 = "EDIT" $tmpsw = KEYWD("FOR") = "EDIT" state = state | $tmpsw parse var info dsid . fullstak = dsnstak dsnstak2 origds = FIND_ORIGIN() return /*@ A_INIT */ /* . ----------------------------------------------------------------- */ B_GET_IT: /*@ */ if branch then call BRANCH address ISPEXEC origdsid = dsid /* in case it's no good... */ candidates = "" /* init */ if Wordpos(dsid,fullstak) = 0 then do do idx = 1 to Words(fullstak) if Abbrev(Word(fullstak,idx),dsid) then, candidates = candidates Word(fullstak,idx) end end else candidates = dsid /* matched as word */ if Words(candidates) > 1 then do address TSO (exec_name) parms"*" "((" opts return helpmsg = " <"origdsid"> matched to more than one known", "nickname:" Space(candidates,1) call HELP /* ...and don't come back! */ end /* too many hits */ if Words(candidates) = 0 then do helpmsg = " <"origdsid"> was not found in the list of known", "nicknames." call HELP /* ...and don't come back! */ end /* not enough hits */ dsid = Space(candidates,0) "CONTROL ERRORS RETURN" (func.state) "DATASET("dsn.dsid")" /* EDIT or VIEW */ if rc > 8 then do "SETMSG MSG(ISRZ002)" end return /*@ B_GET_IT */ /* Display the table . ----------------------------------------------------------------- */ C_ISPF_IT: /*@ */ if branch then call BRANCH address ISPEXEC "CONTROL ERRORS RETURN" /* I'll handle my own */ call CA_PROLOG /* -*/ call CD_DISPLAY /* -*/ call CZ_EPILOG /* -*/ return /*@ C_ISPF_IT */ /* . ----------------------------------------------------------------- */ CA_PROLOG: /*@ */ if branch then call BRANCH address ISPEXEC call DEIMBED /* extract ISPF material -*/ 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 /*@ CA_PROLOG */ /* . ----------------------------------------------------------------- */ CD_DISPLAY: /*@ */ if branch then call BRANCH address ISPEXEC if Pos( "*",dsid ) > 0 then, do mode = "SCAN" /* generic spec */ "TBVCLEAR" $tn$ /* zap all names */ dsid = Strip( dsid,,"*" ) fetag = dsid"00"x fetagh = dsid"ff"x "TBSARG" $tn$ "NAMECOND( FETAG,GE FETAGH,LE )" end else mode = "ALL" "TBSORT" $tn$ "FIELDS(FETAG,C,A)" do forever "TBDISPL" $tn$ "PANEL(FETCH01)" if rc > 4 then leave if zcmd ^= "" then do "CONTROL DISPLAY SAVE" call CDP_PROCESS_CMD /* -*/ "CONTROL DISPLAY RESTORE" iterate end do ztdsels "CONTROL DISPLAY SAVE" select when Pos(action,"B") > 0 then do "BROWSE DATASET("fedsn")" end when action = "E" then do "EDIT DATASET("fedsn")" end when Pos(action,"V") > 0 then do "VIEW DATASET("fedsn")" end when Pos(action,"M") > 0 then do "LMINIT DATAID(MEML) DATASET("fedsn")" if rc > 0 then, say "LMINIT failed RC="rc zerrsm "-" zerrlm else do "LMOPEN DATAID("meml") OPTION(INPUT)" if rc > 0 then, say "LMOPEN failed RC="rc zerrsm "-" zerrlm else do "MEMLIST DATAID("meml") FIELD( 9 )" if rc > 8 then, say "MEMLIST failed RC="rc zerrsm "-" zerrlm "LMCLOSE DATAID("meml")" end "LMFREE DATAID("meml")" end end when Pos(action,"S") > 0 then do (func.state) "DATASET("fedsn")" end otherwise nop end /* select */ "CONTROL DISPLAY RESTORE" if ztdsels > 1 then "tbdispl" $tn$ end /* ztdsels */ action = "" end /* forever */ return /*@ CD_DISPLAY */ /* . ----------------------------------------------------------------- */ CDP_PROCESS_CMD: /*@ */ if branch then call BRANCH address ISPEXEC return /*@ CDP_PROCESS_CMD */ /* Release the LIBDEFs . ----------------------------------------------------------------- */ CZ_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 /*@ CZ_EPILOG */ /* The structure of the FE table on the Master Table (AAMSTR) is KEYS(fetag) NAMES(fedsn fetagh). If the AAMSTR table is properly configured as by TBLMSTR exec, the TBLGEN command below will build a proper FE table. It is not kept beyond the end of the session. . ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ if branch then call BRANCH address TSO if SWITCH("INSTALL") then do queue "FETCH" queue 3 queue "SELECT CMD(%FETCH &ZPARM)" queue "Fetch datasets by nickmane" "FCCMDUPD" exit end /* INSTALL */ $tn$ = "$FETCH" state = SWITCH("EDIT") /* 1=EDIT 0=VIEW */ if Pos( "*",parms ) > 0 |, parms = "" then, "TBLGEN FE NOWRITE REPLACE" /* build temporary FE table */ call ZA_LOAD_NAMES /* -*/ groups = "ABC SLS MKT" types = "N V" stages = "DV PR" parse value "" with dsnstak2 s1 g1 t1 do Words(groups) parse value groups g1 with g1 groups do Words(types) parse value types t1 with t1 types do Words(stages) parse value stages s1 with s1 stages dsnstak2 = dsnstak2 Space(g1 t1 s1,0) end /* stages */ stages = stages s1; s1 = "" /* at end, restore last one */ end /* types */ types = types t1; t1 = "" /* at end, restore last one */ end /* groups */ groups = groups g1; g1 = "" /* at end, restore last one */ call ZB_LOAD_LEVELS /* -*/ return /*@ LOCAL_PREINIT */ /* To add a new item to the selection list: (1) add a new "dsn." row (2) add the index value to "dsnstak" DSNSTAK is sorted before use so you don't have to worry about 'order', but you should keep the "DSN." list in order to avoid accidentally duplicating an index value. . ----------------------------------------------------------------- */ ZA_LOAD_NAMES: /*@ */ if branch then call BRANCH address TSO dsn. = "" dsn.LOGONS = "'SYS1.PROCLIB'" /* Add new ones in any order -- they now get sorted */ dsnstak = STRSORT( , " LOGONS ", ) if Pos( "*",parms ) > 0 |, parms = "" then, call ZT_TBADD(dsnstak) /* -*/ return /*@ ZA_LOAD_NAMES */ /* . ----------------------------------------------------------------- */ ZB_LOAD_LEVELS: /*@ */ if branch then call BRANCH address TSO do zbx = 1 to Words(dsnstak2) thislvl = Word(dsnstak2,zbx) /* isolate */ dsn.thislvl = "'ACNN.TS.D822.MSD.DOCUMENT("thislvl")'" end /* zbx */ if Pos( "*",parms ) > 0 |, parms = "" then, call ZT_TBADD(dsnstak2) /* -*/ return /*@ ZB_LOAD_LEVELS */ /* Load the table . ----------------------------------------------------------------- */ ZT_TBADD: /*@ */ if branch then call BRANCH address ISPEXEC arg taglist do while taglist <> "" parse var taglist fetag taglist /* isolate */ fedsn = dsn.fetag /* load dsn */ fetagh = fetag "TBADD" $tn$ /* add to table */ end /* taglist */ return /*@ ZT_TBADD */ /* 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 */ /* Find where code was run from. It assumes cataloged data sets. Original by Doug Nadel With SWA code lifted from Gilbert Saint-flour's SWAREQ exec . ----------------------------------------------------------------- */ FIND_ORIGIN: Procedure /*@ */ answer="* UNKNOWN *" /* assume disaster */ Parse Source . . name dd ds . /* get known info */ Call listdsi(dd "FILE") /* get 1st ddname from file */ Numeric digits 10 /* allow up to 7FFFFFFF */ If name = "?" Then /* if sequential exec */ answer="'"ds"'" /* use info from parse source */ Else /* now test for members */ If sysdsn("'"sysdsname"("name")'")="OK" Then /* if in 1st ds */ answer="'"sysdsname"("name")'" /* go no further */ Else /* hooboy! Lets have some fun!*/ Do /* scan tiot for the ddname */ tiotptr=24+ptr(12+ptr(ptr(ptr(16)))) /* get ddname array */ tioelngh=c2d(stg(tiotptr,1)) /* nength of 1st entry */ Do Until tioelngh=0 | tioeddnm = dd /* scan until dd found */ tioeddnm=strip(stg(tiotptr+4,8)) /* get ddname from tiot */ If tioeddnm <> dd Then /* if not a match */ tiotptr=tiotptr+tioelngh /* advance to next entry */ tioelngh=c2d(stg(tiotptr,1)) /* length of next entry */ End If dd=tioeddnm Then, /* if we found it, loop through the data sets doing an swareq for each one to get the dsname */ Do Until tioelngh=0 | stg(4+tiotptr,1)<> " " tioejfcb=stg(tiotptr+12,3) jfcb=swareq(tioejfcb) /* convert SVA to 31-bit addr */ dsn=strip(stg(jfcb,44)) /* dsname JFCBDSNM */ vol=storage(d2x(jfcb+118),6) /* volser JFCBVOLS (not used) */ If sysdsn("'"dsn"("name")'")='OK' Then, /* found it? */ Leave /* we is some happy campers! */ tiotptr=tiotptr+tioelngh /* get next entry */ tioelngh=c2d(stg(tiotptr,1)) /* get entry length */ End answer="'"dsn"("name")'" /* assume we found it */ End Return answer /*@ FIND_ORIGIN */ /* . ----------------------------------------------------------------- */ ptr: Return c2d(storage(d2x(Arg(1)),4)) /*@ */ /* . ----------------------------------------------------------------- */ stg: Return storage(d2x(Arg(1)),Arg(2)) /*@ */ /* . ----------------------------------------------------------------- */ SWAREQ: Procedure /*@ */ If right(c2x(Arg(1)),1) \= 'F' Then /* SWA=BELOW ? */ Return c2d(Arg(1))+16 /* yes, return sva+16 */ sva = c2d(Arg(1)) /* convert to decimal */ tcb = c2d(storage(21c,4)) /* TCB PSATOLD */ tcb = ptr(540) /* TCB PSATOLD */ jscb = ptr(tcb+180) /* JSCB TCBJSCB */ qmpl = ptr(jscb+244) /* QMPL JSCBQMPI */ qmat = ptr(qmpl+24) /* QMAT QMADD */ Do While sva>65536 qmat = ptr(qmat+12) /* next QMAT QMAT+12 */ sva=sva-65536 /* 010006F -> 000006F */ End return ptr(qmat+sva+1)+16 /*@ SWAREQ */ /* . ----------------------------------------------------------------- */ HELP: /*@ */ address TSO;"CLEAR" ; say "" if helpmsg <> "" then do; say helpmsg; say ""; end ex_nam = Left(exec_name,8) /* predictable size */ say " FETCH retrieves selected datasets by their 'nicknames'. " say " Recognized nicknames (so far) are: " say " " do Words(dsnstak) /* each valid value */ parse var dsnstak this1 dsnstak /* isolate */ say Right(this1,14) "=" dsn.this1 end /* dsnstak */ say " plus" Words(dsnstak2) "catalog pointers. " say " " say " (The minimum abbreviation is whatever portion of the nickname " say " is required to make it unique. You may also make a generic " say " request by appending an asterisk, e.g.: 'jcl*'. This will " say " display all nicknames which match the specified pattern.) " say " " say " more...... " "NEWSTACK" ; pull ; "CLEAR" ; "DELSTACK" say " " say " In addition, catalog listings by high-level-qualifier are " say " available by specifying a six-character value composed of one " say " of each of the following three sets: " say " " say " GROUP: "groups say " TYPE: "types say " STAGE: "stages say " " say " Other nicknames will be added as time goes by. Check here for" say " news of new additions. " say " " say " " say " You may have the FETCHed data brought to you ready for Edit by " say " specifying: " say " FETCH ..... (( EDIT " say " or " say " FETCH .... FOR EDIT (but only if a data item is specified) " say " " say " You may have the verb 'FETCH' added to your personal command table" say " by specifying: " say " FETCH ..... (( INSTALL " say " but no other processing will take place in that invocation. " 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 " 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 */ "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 -*/ if Word(parms,1) = "?" then call HELP /* I won't be back */ return /*@ TOOLKIT_INIT */ /* )))PLIB FETCH01 )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(LOW) SKIP(ON) )BODY EXPAND(||) %|-| FETCHable Datasets +|-| %Command ===>_ZCMD %Scroll ===>_ZAMT+ + --Tag-- --Dataset Name-------- )MODEL ROWS(&mode) _z!fetag @fedsn )INIT .ZVARS = '(ACTION)' .HELP = FETCH01H )REINIT )PROC )END )))PLIB FETCH01H )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 |-| FETCHable Datsets |-| TUTORIAL %Next Selection ===>_ZCMD + Select by%S, E, B,+or%V+any of the shown datasets. %S+is equivalent to%V+(View). This copy of FETCH was found in!origds )PROC )END */