/* REXX ARRANGE A routine to demonstrate the technique for adding entries to a table in a random sequence and maintaining that sequence throughout processing. The sequence number may be a fractional decimal number and will cause the new line to be inserted in the proper order as specified by the sequence. Command REORDER will cause the table to be resequenced and remain in the original order. Use '(routine name) ?' for HELP-text. |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| | | | WARNING: EMBEDDED COMPONENTS. | | See text following TOOLKIT_INIT | | | |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| Written by Frank Clarke 20010507 rexxhead@yahoo.com Impact Analysis . SYSEXEC TRAPOUT Modification History 20211026 fxc added HELP text 20230608 fxc use &ZUP/&ZCONT 20230613 fxc add DEL to DEIMBED ALLOC 20230726 fxc adjust HELP; 20230806 fxc chg SYSPROC to SYSEXEC in Impact Analysis; 20240305 fxc align panel names; 20240308 fxc chg dollar-sign to @ everywhere; 20240404 fxc changed tutorial to scrollable area; 20240414 fxc DUMP_QUEUE quiet; */ 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 /* -*/ if \sw.nested then call DUMP_QUEUE 'quiet' /* -*/ exit /*@ ARRANGE */ /* Initialization . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO call DEIMBED /* -*/ return /*@ A_INIT */ /* Mainline for ISPEXEC table operations. . ----------------------------------------------------------------- */ B_TABLE_OPS: /*@ */ if branch then call BRANCH address ISPEXEC call BA_OPEN /* -*/ call BB_LIBDEF_INIT /* -*/ call BD_DISPLAY /* -*/ call BX_LIBDEF_DROP /* -*/ call BZ_CLOSE /* -*/ return /*@ B_TABLE_OPS */ /* Open the table; build anew if necessary. . ----------------------------------------------------------------- */ BA_OPEN: /*@ */ if branch then call BRANCH address ISPEXEC "TBSTATS" @tn@ "STATUS1(s1) STATUS2(s2)" if s1 > 1 then do "TBCREATE" @tn@ "NAMES(POSITION DSNAME) NOWRITE REPLACE" "TBSORT" @tn@ "FIELDS(POSITION,N,A)" end; else, if s2 = 1 then do "TBOPEN " @tn@ openmode.noupdt end else "TBTOP" @tn@ return /*@ BA_OPEN */ /* LIBDEF the embedded components. . ----------------------------------------------------------------- */ BB_LIBDEF_INIT: /*@ */ 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 "LIBRARY ID("@ddn") STACK" end ddnlist = ddnlist dd return /*@ BB_LIBDEF_INIT */ /* Display the table. . ----------------------------------------------------------------- */ BD_DISPLAY: /*@ */ if branch then call BRANCH address ISPEXEC do forever "TBTOP" @tn@ "TBDISPL" @tn@ "PANEL(ARRNG01)" if rc > 8 then do "SETMSG MSG(ISRZ002)" leave end ; else, if rc > 4 then leave /* PF3 ? */ call BDA_ZCMD /* -*/ call BDB_ADDNEW /* -*/ call BDC_ZTDSELS /* -*/ end /* forever */ return /*@ BD_DISPLAY */ /* Process the ZCMD field. . ----------------------------------------------------------------- */ BDA_ZCMD: /*@ */ if branch then call BRANCH address ISPEXEC if zcmd <> "" then do if zcmd = "REORDER" then do /* resequence table */ "TBSORT" @tn@ "FIELDS(POSITION,N,A)" address TSO "NEWSTACK" /* isolate a queue */ do forever "TBSKIP" @tn@ /* next row */ if rc > 0 then leave /* no more rows */ queue dsname "TBDELETE" @tn@ /* lose this row */ end /* forever */ /* The table should be empty and the queue should have all the datasetnames from the table in the proper order */ position = 1.0 do queued() /* each datasetname */ pull dsname "TBADD" @tn@ position = position + 1.0 end /* queued */ address TSO "DELSTACK" /* restore the queue */ end /* REORDER */ end return /*@ BDA_ZCMD */ /* Add a new row. . ----------------------------------------------------------------- */ BDB_ADDNEW: /*@ */ if branch then call BRANCH address ISPEXEC if newpos <> "" then, if newds <> "" then do position = newpos dsname = newds if Sysdsn(dsname) = "OK" then do "TBMOD" @tn@ parse value "" with newpos newds end else do zerrsm = "Oops!" zerrlm = "DSN" dsname "is invalid. Not added." "SETMSG MSG(ISRZ002)" end /* Bad DSN */ end return /*@ BDB_ADDNEW */ /* Process individual row selections. . ----------------------------------------------------------------- */ BDC_ZTDSELS: /*@ */ if branch then call BRANCH address ISPEXEC do ztdsels select when action = "D" then do /* Delete */ "TBDELETE" @tn@ end otherwise "TBPUT" @tn@ end /* Select */ if ztdsels = 1 then, /* never do the last one */ ztdsels = 0 else "TBDISPL" @tn@ /* next row #*/ end /* ztdsels */ action = '' /* clear for re-display */ return /*@ BDC_ZTDSELS */ /* Detach the LIBDEFed material. . ----------------------------------------------------------------- */ BX_LIBDEF_DROP: /*@ */ 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 /*@ BX_LIBDEF_DROP */ /* Close the table. Since this table was defined NOWRITE, it is discarded after use. . ----------------------------------------------------------------- */ BZ_CLOSE: /*@ */ if branch then call BRANCH address ISPEXEC "TBEND" @tn@ return /*@ BZ_CLOSE */ /* . ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ address TSO parse value KEYWD("USETBL") "ARNG00" with, @tn@ . 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 DEL 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 */ /* . ----------------------------------------------------------------- */ HELP: /*@ */ address TSO;"CLEAR" if helpmsg <> "" then say helpmsg; say "" ex_nam = Left(exec_name,8) /* predictable size */ say " " say " "ex_nam" is a demonstration program as an example of table " say " handling. It has no real purpose beyond being an example." say " " say " Syntax: "ex_nam" no parms " say " (( USETBL tblnm " say " " say " tblnm specifies a table name to use. This also has no " say " real purpose since the table is defined 'NOWRITE' " say " and is discarded at routine-end. The default table " say " name is ARNG00. " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " Debugging tools provided include: " 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" (( BRANCH 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 */ /* . ----------------------------------------------------------------- */ 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") "N" 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 */ /* Panel definitions follow ))) PLIB ARRNG01 .. )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( INPUT ) INTENS( LOW ) )BODY EXPAND(||) %|-| The Lone Arranger - TEST +|-| %Command ===>_ZCMD %Scroll ===>_ZAMT + -- D=Delete or specify new Position: ===>_newpos+ and + / DSN: ===>_newds %V ---Pos- DSName )MODEL _Z+ !position@dsname )INIT .ZVARS = '(action)' .HELP = arrngh1 )REINIT )PROC )END ))) PLIB ARRNGH1 .. )ATTR % TYPE( TEXT ) INTENS( HIGH ) SKIP( ON ) + TYPE( TEXT ) INTENS( LOW ) SKIP( ON ) _ TYPE( INPUT ) INTENS( HIGH ) @ TYPE( OUTPUT ) INTENS( LOW ) SKIP( ON ) } AREA( SCRL ) EXTEND( ON ) )BODY EXPAND(||) %TUTORIAL |-| The Lone Arranger |-| TUTORIAL %Next Selection ===>_ZCMD + }hlptxt } )AREA HLPTXT + + This demonstrator program shows how to build (for instance) a + dataset list adding elements anywhere in the list as it is built. + + The list starts out empty and the user adds rows by specifying a % sequence number+and a%DSName+(which must be valid). This DSName + is inserted to the list in the order implied by the sequence + number. If seq# 1 is added followed by seq# 2, adding seq# 1.6 + next will cause that item to be inserted between the other two. + + Command%REORDER+causes the sequence numbers to be reset in + increments of 1.0 but the order of the table remains unchanged. + + A%D+next to any row will cause that row to be deleted. + + You may change the DSName on any row just by overtyping it. + )PROC &ZUP = ARRNGH1 &ZCONT = ARRNGH1 )END */