/* rexx Demo Dynamic display area using TEXTBLD function */ Address ispexec "control errors return" parse source . @what @who . @where . /* see panel def at the end for attribute defs in panel */ parse value '1112131415161718'x with clrb +1 clrg +1 clrp +1 clrr, +1 clrt +1 clrw +1 clry +1 sfa +1 . /* determine if called as (line)command handler i.e XTBDISD SEL TBC0234 00000002 E;PASSING TEXT" */ arg prm if Subword(prm,1,2)='XTBDISD CMD' then Exit PCmd(subword(prm,3)) if Subword(prm,1,2)='XTBDISD SEL' then Exit LCmd(subword(prm,3)) /* set/get some display options */ parse value userid()'.LIB XTBDDYNA' with dslist area libdd1 libdd2 "vget zscrmaxw shared" width=zscrmaxw if zscrmaxw>=100 then width=100 Call MakePanel /* create panel lib */ panel=libdd1 /* use dynamic ddname */ table=libdd1 /* use dynamic ddname */ Call MakeTable /* create data table */ r=XTBDISD(, 'table('table') panel('panel') area('area') width('width')', 'sfd('sfa '2)', /* select-field definition */ 'lclist(E G P S)', /* line commands passed to me */ 'lcblst(EE GG PP SS)', /* line block commands */ 'pas(S)', /* point-and-shoot linecmd */ 'proc('@who')', /* call me for commands */ 'passtxt(passing text)', /* pass this text to me */ 'textbld(', /* build display line */ 'txtclr1 || left(dsn,44) || txtclr2', '|| left(type,8) left(vol,6) left(cat,14) || txtclr3 || no)', ) say 'returns' r parse var r cc text if cc<>0 then say 'rc:' cc text Call close 0 /* make panel lib */ MakePanel: address tso "newstack" do n=1 to 9999 if word(sourceline(n),1)='/*panel' then do do m=n+1 to 9999 if word(sourceline(m),1)='*/' then leave n queue sourceline(m) end end end cc=bpxwdyn('alloc new delete lrecl(80) recfm(f,b) blksize(0)', 'tracks space(1,1) dir(1) unit(3390) rtddn(libdd1) rtdsn(libds1)') if cc<>0 then call close "bpxwdyn alloc1 failed" cc cc=bpxwdyn('alloc old da('libds1'('libdd1')) rtddn(libdd2)') if cc<>0 then call close "bpxwdyn alloc2 failed" cc "execio" queued() "diskw" libdd2 "(finis)" cc=rc "delstack" if libdd2<>'' then cc=BpxWdyn('free dd('libdd2')') if cc<>0 then call close "write panel failed" cc address ispexec "libdef ispplib library id("libdd1") stack" if rc<>0 then call close "libdef ispplib failed" rc return 0 /* make test table */ MakeTable: address ispexec "tbcreate" table "names(xtbdsel xtbdattr xtbdtext", "dsn type vol cat no txtclr1 txtclr2 txtclr3 ) nowrite share" zz=outtrap('lc.') address tso "listc lvl("dslist") vol" zz=outtrap('off') no=0 do n=1 to lc.0 if left(lc.n,1)<>'' then parse var lc.n type '-' . dsn . if word(lc.n,1)='IN-CAT' then parse var lc.n . . cat . if left(word(lc.n,1),7)='VOLSER-' then do parse value clrg clrb clrp with txtclr1 txtclr2 txtclr3, xtbdsel xtbdattr xtbdtext vol = right(strip(word(lc.n,1)),6) no = right(no+1,4,0) type = space(type,0) if pos('EXEC',dsn>0) then txtclr1=clrr xtbdtext=dsn type vol cat /* reqd for FIND, ONLY etc */ address ispexec "tbadd" table end end if no=0 then call close 8 'Maketable made nothing' return 0 /* cleanup and return */ Close: parse arg _rc _msg if queued()>0 then address tso "delstack" if table<>'' then address ispexec "tbend" table if libdd1<>'' then address ispexec "libdef ispplib" if libdd1<>'' then cc=BpxWdyn('free dd('libdd1')') parse arg _rc _msg if _msg<>'' then say _msg Exit word(_rc 0,1) XMsg: if arg(1)<>'' then say arg(1);return word(arg(2) 0,1) /* handle primary commands */ PCmd: arg $table $infotbl $cmd';'$ptxt address ispexec "tbget" $infotbl say 'Pcmd table: ' $table say ' infotbl:' $infotbl say ' cmd: ' $cmd say ' text: ' $ptxt say ' blkc: ' xtbdblkc say ' blkp: ' xtbdblkp say ' hidn: ' xtbdhidn if $cmd='LISTTBL' then exit PCmdListTbl() if word($cmd,1)='SORT' then exit PCmdSortTbl() xtbdhidn=28 address ispexec "tbput" $infotbl Exit 0 /* primary command LIST */ PCmdListTbl: Procedure expose $table "tbtop" $table "tbquery" $table "rownum(rown)" if rown>25 then rown=25 Do rown "tbskip" $table "rowid(r) position(p)" say r p left(xtbdattr,1), left(translate(xtbdtext,' ',xrange('00'x,'20'x)),60) end return 0 /* primary command SORT */ PCmdSortTbl: Procedure expose $table $cmd "tbsort" $table "fields("word($cmd,2)",C,A)" return 0 /* Update table */ UpdTable: Procedure /* table,rid,sel,colors */ parse arg table,p "tbskip" table "row("p")" parse arg .,.,xtbdsel,clr1 clr2 clr3 . if clr1<>'' then txtclr1=clr1 if clr2<>'' then txtclr2=clr2 if clr3<>'' then txtclr3=clr3 "tbput" table return rc /* handle line commands E edit dataset G change color to green P change color to pink S swap colors */ LCmd: arg $table $infotbl $rid $sel';'$ptxt if wordpos($sel,$lcblst)>0 then $sel=substr($sel,2) "tbskip" $table "row("$rid")" "tbget" $infotbl Select when wordpos($sel,'E G P S R')>0 then Interpret "Exit LCmd"$sel"()" otherwise Exit Updtable($table,$rid,'?'$sel) End Exit xmsg('Internal error 999',999) LCmdE: /* Linecmd - Edit */ zerrlm='' address ispexec "edit dataset('"dsn"')" if rc>4 then say 'Edit' dsn 'rc' rc zerrlm Return 0 LCmdG: return Updtable($table,$rid,'',clrg clrb clrg) LCmdP: return Updtable($table,$rid,'',clrg clrb clrp) LCmdS: if txtclr1=clry then, return Updtable($table,$rid,'',clrg txtclr2 txtclr3) return Updtable($table,$rid,'',clry txtclr2 txtclr3) /*panel )Attr + type(text ) color(turq ) caps(off) " type(text ) color(green) caps(off) _ type(input ) color(turq ) caps(on ) hilite(uscore) @ type(output ) color(blue ) caps(off) | area(dynamic) extend(on) scroll(on) /* required */ 11 type(dataout) color(blue ) caps(off) /* can be used in screendef */ 12 type(dataout) color(green ) caps(off) /* can be used in screendef */ 13 type(dataout) color(pink ) caps(off) /* can be used in screendef */ 14 type(dataout) color(red ) caps(off) /* can be used in screendef */ 15 type(dataout) color(turq ) caps(off) /* can be used in screendef */ 16 type(dataout) color(white ) caps(off) /* can be used in screendef */ 17 type(dataout) color(yellow) caps(off) /* can be used in screendef */ 18 type(datain ) color(turq ) caps(off) hilite(uscore) )Body expand(\\) width(&xtbdwdth) % \ \Demo dynamic area\ \+&smsg + %ISPF cmd ==>_zcmd \ \+ +Scrl_scrl+ + + |xtbddyna\ \| )Init if (&$csrpos NE 0) .cursor = XTBDDYNA .csrpos = &$csrpos *REXX(*,smsg,xtbdhidn,xtbdrecn,xtbdppos,xtbdblkc) smsg='' if datatype(xtbdrecn)='NUM' then do smsg='line' xtbdppos+0 'of' xtbdrecn+0 if datatype(xtbdhidn)='NUM', then if xtbdhidn<>0 then smsg=smsg','xtbdhidn 'hidden' end if xtbdblkc<>'' then smsg='Block command incomplete' smsg=right(smsg,29) *ENDREXX )Proc &$pcsrpos = .csrpos &$pcursor = .cursor &$plvline = lvline(XTBDDYNA) )End */