/*                                                                        rexx
  Demo ISPF scrollable dynamic panel area

  Some panel related variables (ida = IspDynAr)
   idatop     lineno of 1st displayed line
   idascrwt   screen width
   idascrdp   screen depth
   idacsrf    fieldname in which to place cursor
   idacsrp    position in fieldname to place cursor
   idafld*    field definitions, position and length
   idaf.*     field definitions, position and length
   d.         scren data
   pnl*       panel related variables

  Primary commands:
   Find t      Find text t in entire line
   IF n c t    Show lines where column n (NAME or TYPE) matches text t
               using condition c. Valid conditions: =, <, >, and \. You
               may also use / for finding text anywhere in the column.
   Locate n    Position at name starting with n
   REFresh     Reload data
   RESet       Reset hidden

  Line commands
   L       listcat
   T1-T4   set dataset type color to one of the 4 text colors.,
   X       hide line

  Panel is created dynamically so that the program is self-contained.

  Change '80' below to a larger value or to 'ZSCRMAXW' to test for a
  wider screen - if you have one.
*/
 Address Ispexec
 "control errors return"
 "vget (zscrmaxd zscrmaxw) shared"
 parse value 80       zscrmaxd 1       0        'ZCMD',
        with idascrwt idascrdp idatop idacsrp idacsrf d. .
 parse value xrange('11'x,'17'x) with,
   idaat1 +1 idaat2 +1 idaat3 +1 idaat4 +1 idaai1 +1 idaai2 +1 idaai3 .
 /* field mappings */
 parse value  3 44 8 with idafsell idafnamel idaftypel
 parse value '1 SEL NAME TYPE' with p l    /* p = start pos */
 pnltexth=''
 do i=1 to words(l)
   n =word(l,i)                  /* field id               */
   $ =Value('IDAF'n'AP',p)       /* attribute position     */
   $ =Value('IDAF'n'P',p+1)      /* data position          */
   pnltexth=left(pnltexth,p-1)Upper1(lowcase(n))
   p=p+Value('IDAF'n'L')+1       /* pos of next attr       */
 end
 idafalll=p-1                    /* total length           */
 drop sel name type name type
 idaf.sel  = idafselp idafsell   /* used in GetField, SetField and SetAttr */
 idaf.name = idafnamep idafnamel /* used in GetField, SetField and SetAttr */
 idaf.type = idaftypep idaftypel /* used in GetField, SetField and SetAttr */
 idapanel  = MkPanel()

 /* Controller     */
 cc=2                      /* force initial load            */
 Do $main=1 to 999999
   if cc=2 then if Load()>0 then leave
   zcmd=''
   cc=Dialog()
   if cc>2 then leave      /* 1 = refresh, 2 = redrive load */
 End
 Call Quit

 /* terminate */
Quit:
 if arg(1)<>'' then Call xmsg arg(1)
 address ispexec "libdef ispplib"
 zz=bpxwdyn('free dd('pdsdd')')
 Exit 0

 /* Dialog */
Dialog:
trace off
 address ispexec
 Do forever
   /* build panel area */
   idaarea=''
   pnllo=0
   do pnlli=idatop to d.0 until pnllo>=idascrdp
     if left(d.pnlli,1)='-' then iterate /* suppressed */
     idaarea=idaarea''left(d.pnlli,idascrwt)
     pnllo=pnllo+1
     pnldlp.pnllo=pnlli                  /* data list pos */
   end
   if idacsrf='IDAAREA' then ,
     idacsrp=((idacsrp%idascrwt)*idascrwt)+2
   else parse value 'ZCMD 1' with idacsrf idacsrp
   pnlstatl=right(idatop 'of' d.0,22)
   "display panel("idapanel")"
   if rc>8 then Call Quit 'panel' idapanel 'rc' rc zerrlm
   if rc>4 | wordpos(translate(zcmd),'END RETURN')>0 then return 4

   /* handle primary commands */
   if zcmd<>'' then do
     cc=Pcmd()
     if cc>1 then Return cc
     if cc=1 then iterate
     zcmd=''
   end

   /* pull line commands */
   pnlln  =0                                        /* panel line number     */
   lcmderr=0
   lcmdn  =0
   do pnlap=1 to zscrmaxd*idascrwt by idascrwt
     pnlln   =pnlln+1
     pnlsel  =strip(substr(idaarea,pnlap+1,idafsell))
     dln=pnldlp.pnlln                               /* data line no          */
     if pnlsel='' ,
       & substr(d.dln,idafselp,idafsell)<>'' then do /* field cleared?       */
       zz=SetField(dln,'sel',' ','i1')              /* clear data list field */
       lcmdn=lcmdn+1
       iterate
     end
     if pnlsel<>'' then do
       lcmdn=lcmdn+1
       pnlline =strip(substr(idaarea,pnlap,idascrwt)) /* entire line incl attr*/
       cc=Lcmd(pnlsel,pnlline,pnlln,dln)
       lcmderr=cc
       if cc<>0 then leave
     end
   end
   if lcmderr<>0 then iterate
   /* point-and-shoot */
   if lcmdn=0 & idacsrf='IDAAREA' then do
     pnlap   =((idacsrp%idascrwt)*idascrwt)+2       /* pos of line start    */
     pnlln   =(idacsrp%idascrwt)+1                  /* panel line nr        */
     pnlline =strip(substr(idaarea,pnlap,idascrwt)) /* entire line incl attr*/
     cc=Lcmd('S',pnlline,pnlln,pnldlp.pnlln)
   end

   /* handle scrolling */
   "vget (zverb zscrolla zscrolln) shared"
   if wordpos(zverb,'DOWN UP')>0 then do
     vs=space(zverb zscrolla,0) /* verb & scroll */
     Select
       when vs='UPMAX'   then idatop=1
       when vs='DOWNMAX' then idatop=d.0 -$plvline+1
       when zverb='UP'   then do /* idatop=idatop-zscrolln */
         n=zscrolln
         lp=idatop
         do p=idatop to 1 by -1 while n>=0
           if left(d.p,1)<>'-' then parse value n-1 p with n lp
         end
         idatop=lp
         idacsrf='ZCMD'
       end
       when zverb='DOWN' then do /* idatop=idatop+zscrolln */
         n=zscrolln
         do p=idatop to d.0 while n>0
          if left(d.p,1)<>'-' then n=n-1
         end
         idatop=p
         idacsrf='ZCMD'
       end
       otherwise nop
     end
     zscrolln=''
     if idatop<1 then idatop=1
     if idatop>d.0 then idatop=d.0
   end /* scroll */

 end /* main */
 Return 4

 /*                     line command handler                         */
LCmd:                   /* linecmd, pnlline nr, dataline nr */
 arg lcmd,lcline,lcpln,lcdln
 parse var lcline . =(idafnameap) . +1 lcname . ,
       =(idaftypeap) . +1 lctype . +(idaftypel) .
 Select
   when lcmd='L'  then Return Xtso("listcat ent('"lcname"') all")*0
   when lcmd='X'  then Return SetAttr(lcdln,'sel','-')
   when wordpos(lcmd,'T1 T2 T3 T4')>0 then zz=SetAttr(lcdln,'type',lcmd)
   when lcmd='S'  then say space(translate(d.lcdln,' ',xrange('11'x,'17'x)))
   otherwise return SetField(lcdln,'sel',lcmd,idaai3),
             + xmsg('Invalid line command' lcmd)+1
 end
 zz=SetField(lcdln,'sel',' ',idaai1)
 Return 0

 /*                   primary command handler                        */
PCmd: /* parm = panel line pos, panel line nr */
 parse var zcmd pcvrb pcdata
 Select
   when Abbrev('LOCATE',pcvrb,1) then Return PcLocate(pcdata)
   when Abbrev('FIND',pcvrb,1) then Return PcFind(pcdata)
   when pcvrb='IF' then Return PcFilter(pcdata)
   when Abbrev('RESET',zcmd,3) then return Reset()+1
   when Abbrev('REFRESH',zcmd,3) then return 2
   when Abbrev('WHEN',pcvrb,1) then return PcWhen(pcdata)
   otherwise return xmsg('Invalid command')+1
 End
 Return 0

PcLocate:  /* set display at name         */
 dl=length(pcdata)
 drop name
 parse var idaf.name np nl
 do i=1 to d.0
   if substr(d.i,np,dl)>=pcdata then do
     if substr(d.i,np,dl)=pcdata then idatop=i
     else idatop=i-1
     return 0
   end
 end
 return xmsg('not found')+1

PcFind:    /* set display at line containing text */
 do p=idatop+1 to d.0
   if pos(pcdata,d.p)>0 then do
     idatop=p
     return 0
   end
 end
 return xmsg('not found')+1

PcFilter:  /* filter on conditional value */
           /* analyze expression like date1>2020 */
 signal on error  name PcFilterE
 signal on syntax name PcFilterE
 arg fltprm
 fltp=Verify(fltprm' ','=<>\/','m')
 parse var fltprm fltvrb =(fltp) flts
 fltp   =Verify(flts' ','=<>\/','n')
 parse var flts fltcnd =(fltp) fltval
 if fltcnd='\' then fltcnd='<>'
 fltvrb =strip(fltvrb)
 fltval =strip(fltval)
 fltvall=length(fltval)
 parse var idaf.fltvrb fltpos fltlen
 if Verify(fltval,'*%','m')>0 then do     /* using mask, require pgm RXPATTRN */
   cc=RxPattrn('stem(d.) pos('fltpos') len('fltlen') mask('fltval')',
      'mchr('idaai1') nchr(-)')
   idatop=1
   return 0
 end
 if fltcnd='/' then fltt="pos('"fltval"',substr(d.n,"fltpos","fltlen"))>0"
 else fltt="substr(d.n,"fltpos","fltvall")"fltcnd"'"fltval"'"
 Interpret ,      /* the whole loop is interpreted due to performance */
       "do n=1 to d.0;if" fltt,
         "then d.n=overlay(idaai1,d.n);",    /* show line */
         "else d.n=overlay('-',d.n);",       /* hide line */
       "end;"
 idatop=1
 return 0
PcFilterE:
 Return xmsg('Error' rc '-' Errortext(rc))+1

ResetCmd: zcmd='';return 0

Reset:   /* make all rows visible, clear selection */
 val=idaai1''copies(' ',idafsell)
 do n=1 to d.0
   d.n=overlay(val,d.n,1)
   d.n=overlay(idaat1,d.n,idafnameap)
   d.n=overlay(idaat2,d.n,idaftypeap)
 end
 parse value 0 1 with d0hidn idatop zcmd
 return 0

GetField:
 arg gfn,gff    /* data rec#, fieldname */
 parse var idaf.gff gfp gfl
 return substr(d.gfn,gfp,gfl)

SetField:
 parse arg sfn .,sff .,sfv,sfc . /* line nr, name, value, attrchr */
 upper sff sfc
 parse var idaf.sff sfp sfl
 if length(sfc)>1 then sfc=value('IDAA'sfc)
 if sfc<>'' then d.sfn=overlay(sfc''sfv,d.sfn,sfp-1,sfl+1)
 else            d.sfn=overlay(sfv,d.sfn,sfp,sfl)
 return 0

SetAttr:
 arg sfn .,sff .,sfa .           /* line nr, field, attrchr */
 parse var idaf.sff sfp sfl
 if length(sfa)>1 then sfa=value('IDAA'sfa)
 d.sfn=overlay(sfa,d.sfn,sfp-1)
 return 0

/* load testdata */
Load:
trace off
 sv =left(' ',idafsell)
 dn=0
 zz=outtrap('lst.')
 address tso "listcat lvl('sys1') nonvsam cluster"
 zz=outtrap('off')
 do n=1 to lst.0 by 2
   dn=dn+1
   d.dn=idaai1''sv''idaat1,
        || left(word(lst.n,3),idafnamel)''idaat2''word(lst.n,1)
 end

 d.0=dn
 return 0

XMsg: parse arg zedlmsg;return xisp("setmsg msg(ISRZ000)")
XTSO: address TSO arg(1); return rc
XIsp: zerrlm='';address ispexec arg(1); return rc
Upper1:  return translate(left(arg(1),1))substr(arg(1),2) /* upcase 1st char */
LowCase: return translate(arg(1),xrange('a','z'),xrange('A','Z'))

 /* load panel to temp dataset */
MkPanel:
 p.1 =')Attr                                                            '
 p.2 =' + type(text   ) color(green) caps(off)                          '
 p.3 =' " type(text   ) color(blue ) caps(off)                          '
 p.4 =' _ type(input  ) color(turq ) caps(on ) hilite(uscore)           '
 p.5 =' | area(dynamic) extend(on) scroll(on)  /* required */           '
 p.6 =' /* text 1 - 4 */                                                '
 p.7 =' 11 type(dataout) color(turq  ) caps(off)                        '
 p.8 =' 12 type(dataout) color(green ) caps(off)                        '
 p.9 =' 13 type(dataout) color(pink  ) caps(off)                        '
 p.10=' 14 type(dataout) color(white ) caps(off)                        '
 p.11=' /* input 1 - 3 */                                               '
 p.12=' 15 type(datain ) color(turq  ) caps(off) hilite(uscore)         '
 p.13=' 16 type(datain ) color(yellow) caps(off) hilite(uscore)         '
 p.14=' 17 type(datain ) color(red   ) caps(off) hilite(uscore)         '
 p.15=')Body expand(\\) width(&idascrwt)                                '
 p.16='%                     Demo scrollable dynamic panel area "&pnlstatl'
 p.17='%ISPF cmd ==>_zcmd \ \+ +Scrl_scrl+                              '
 p.18='+                                                                '
 p.19='+Listing LVL(SYS1) NONVSAM CLUSTER                               '
 p.20='+                                                                '
 p.21='%&pnltexth\ \+                                                   '
 p.22='|idaarea\ \|                                                    '
 p.23=')Init                                                            '
 p.24=' .cursor = &idacsrf            /* set cursor in field        */ '
 p.25=' .csrpos = &idacsrp            /* set cursor pos in field    */ '
 p.26=')Proc                                                            '
 p.27=' &idacsrp = .csrpos            /* get cursor pos in field    */ '
 p.28=' &idacsrf = .cursor            /* get fieldname of cursor    */ '
 p.29=' &$plvline = lvline(idaarea)                                    '
 p.30=')End                                                             '
 p.0=30
 cc=bpxwdyn('alloc new delete lrecl(80) recfm(f,b) blksize(0)',
            'tracks space(1,1) dir(1) unit(sysda) rtddn(pdsdd) rtdsn(pdsds)')
 if cc<>0 then exit xmsg("bpxwdyn pds rc" cc)
 cc=bpxwdyn('alloc shr da('pdsds'('pdsdd')) rtddn(mbrdd)')
 if cc<>0 then exit xmsg("bpxwdyn mbr rc" cc)+bpxwdyn('free dd('pdsdd')')
 address tso "execio" p.0 "diskw" mbrdd "(stem p. finis)"
 zz=bpxwdyn('free dd('mbrdd')')
 cc=xisp("libdef ispplib library id("pdsdd") stack")
 if cc<>0 then call quit "libdef rc" cc zerrlm
 return pdsdd  /* use as panel name */