/*                                                                  rexx
 Add commands to ISPF in-storage command table ISPCMDS.

 Syntax:

   Call ISPCMDU ['parameters']             REXX
   Address TSO "%ISPCMDU [parameters]"     REXX
   ISPCMDU [parameters]                    CLIST
   TSO ISPCMDU [parameters]                ISPF command line
   ISPCMDU                                 ISPF edit

 Parameters:

  DA(dsn(mbr))  Both dataset and membername are optional. Default
                datasets is the ISPPROF dataset, default membername
                is 'ISPCOMND'. If dsname is PARMLIB or .PARMLIB, then
                the parmlib concatenation is searched.
  ID(id)        set 'desc' field to id. Note that the desc field will
                in any case be prefixed by '<UCL>' (User Command List).
  LIST[(name)]  Do the list function, if specified then all other
                parameters except ML is ignored. name is the table
                name minus 'CMDS', i.e. ISP.
  ML(n)         Message level, shows process messages if gt 0.
                Current range is 0-3, default is 0.
  QUIET         Do not show confirmation and statistics.
  SYSTBL(name)  Name of ISPF command table, default is ISPCMDS.

 Input:

  A dataset with the following contents:
   To add an entry - the backslash can be any special character except
   the minus sign and the description is optional.
    \verb\abbrev\command[\description]
   To delete an entry
    -verb
   Comments are lines starting with REXX commments, or an asterix (*).
    /* comment text                           [*/]
    or
    * comment text
  The dataset can be named in the DA parameter, be the default or be
  an edited dataset/member. The verb is up-cased internally.
   Sample:
    -saywho
    \saywho\0\select cmd(%whoami)\

 Usage:

  Have your start-up proc do all the allocations, then end by
        IspStart cmd(%ISPCMDUX)
  ISPCMDUX could look like this:
        /* ISPF start - phase 2 - command table updates      REXX  */
        Address IspExec "Select cmd(%IspCmdU da(PARMLIB) quiet)"
        Address IspExec "Select PANEL(ISR@PRIM)"
        Exit 4                                    /* 4 is required */
  That way the updates are done automatically at logon time. If you
  want to start multiple screens then look at the ZSTART profile
  variable, ZSTART sample:
        ISPF;START 3.4;START 6;SWAP 1;TSO %ISPCMDU

 History:

  2024-01-27 Major rewrite, add LIST and ML parameters, add LIST function.
             Fix 'delete' action ignored.
             Better inline documentation.
  2018-10-09 da(PARMLIB(mbr)) locate mbr in parmlibs
  2016-10-25 Support long split lines
             da(.parmlib) locate ISPCOMND in parmlibs
  2016-02-17 Fix error in load in an edit macro
  2016-01-31 Retain aliases at top
             Use BPXWDYN instead of ALLOCATE
  2005-04-18 Initial

 Author
  Willy Jensen
  mail: willy@harders-jensen.com
  web : http://harders-jensen.com
*/

 Address ispexec
 "control errors return"
 parse value '0 0 0 0 60 ISPCMDS',
   with ?list ?quiet $ml lst.0 $width $systbl $wrktbl $id $da $list p
 $gblv='lst. $width $ml'
 address isredit "MACRO PROCESS (P)"
 ?edit=(rc=0)
 if \?edit then arg p
 p=translate(Unquote(p))
 do while p<>''
   p=strip(p)
   select
     when left(p,5)='LIST('   then,
       parse value 1 p with ?list .'('$list')' p
     when word(p,1)='LIST'    then parse value 1 p with ?list . p
     when word(p,1)='QUIET'   then parse value 1 p with ?quiet . p
     when left(p,3)='DA('     then parse var p .'('$da')' p
     when left(p,3)='ID('     then parse var p .'('$id')' p
     when left(p,3)='ML('     then parse var p .'('$ml')' p
     when left(p,7)='SYSTBL(' then parse var p .'('$systbl')' p
     otherwise exit xispmsg('Bad parameter:' p)
   end
 end
 if ?list then Exit ListTables($list)
 if right($systbl,4)<>'CMDS' & length($systbl)<5,
   then $systbl=$systbl'CMDS'

 Select
   when ?edit then call Edit_load /* edit macro */
   when $da<>'' then call Dsn_Load $da
   otherwise call Dsn_Load Locate_Ispprof()
 end

 Call MakeWorkTable

 if $ml>0 then say 'Updating system command table' $systbl
 added=0
 updated=0
 deleted=0
 rec=''
 do i=1 to r.0
   if r.i='' | word(r.i,1) = '/*' | left(r.i,1)='*' then iterate
   rec=rec''strip(r.i)
   if right(rec,1)='-' then rec=left(rec,length(rec)-1)
   else do
     parse var rec c +1 verb . (c) trunc . (c) act  (c) desc
     act =strip(act)
     desc=strip(desc)
     upper verb act
     if c = '-' then call tbldel
     else call tblupd
     rec=''
   end
 end

 Call RebuildTable    /* rewrite ISPCMDS */

 if $ml>0 then say 'added('added') updated('updated') deleted('deleted')'
 Call Close 0 'added('added') updated('updated') deleted('deleted')'

Close:
 parse arg _rc _msg
 if _msg<>'' then call XispMsg _msg
 Address TSO "delstack"
 if $wrktbl<>'' then Address IspExec "tbend" $wrktbl
 parse arg _rc _msg
 Exit word(_rc 4,1)

TblUpd:
 trace off
 if locate(verb)=0 then do
   call updvars
   "tbput" $wrktbl
   if $ml>1 then say 'Update' zctverb 'to worktbl rc' rc
   if $ml>2 then do
     say ' verb:  ' zctverb
     say ' trunc: ' zcttrunc
     say ' action:' zctact
     say ' desc:  ' zctdesc
   end
   updated=updated+1
   return
 end
 /* verb not found, add it */
 "tbtop" $wrktbl
 call updvars
 "tbadd" $wrktbl
 if $ml>1 then say 'Adding' zctverb 'to worktbl rc' rc
 if $ml>2 then do
   say ' verb:  ' zctverb
   say ' trunc: ' zcttrunc
   say ' action:' zctact
   say ' desc:  ' zctdesc
 end
 added=added+1
 return

TblDel:
 trace off
 if Locate(verb)>0 then return
 "tbdelete" $wrktbl
 if $ml>1 then say 'Delete' verb 'in worktbl rc' rc
 deleted=deleted+1
 return

UpdVars:
 trace off
 if $ml>1 then say 'Update' verb 'in worktbl'
 zctverb=verb
 zcttrunc=trunc
 zctact=act
 rtype='C'
 if desc = '' & $id<>'' then desc = '*'$id'*'
 desc = '<UCL>' desc
 zctdesc=desc
 return

Locate:
 trace off
 "tbtop" $wrktbl
 "tbvclear" $wrktbl
 arg zctverb .
 "tbscan" $wrktbl "arglist(zctverb)"
 f=''
 if rc<>0 then f=' NOT'
 if $ml>1 then say 'Locate' zctverb 'in worktbl -'f 'found'
 return rc

XispMsg:
 if ?quiet then return 0
 parse arg zedlmsg
 if zedlmsg = '' then return 0
 zedlmsg= 'ISPCMDU' zedlmsg
 address ispexec "Vput (zedlmsg)"
 address ispexec "setmsg msg(isrz000)"
 return 0

Edit_Load:   /* load data to stem from edit session */
 if $ml>0 then say 'EditLoad...'
 address isredit "(ln) = linenum .zlast"
 do i=1 to ln
   address isredit '(l) = line' i
   r.i = strip(l,t)
 end
 r.0=ln
 if $ml>1 then say 'Edit Load added' r.0 'records...'
 return

Dsn_Load:   /* load from library */
 arg d m .
 d = strip(d,"b","'")
 if m = '' then m = 'ISPCOMND'
 if $ml>0 then say 'Dsnload' d'('m')...'
 if d='PARMLIB' | d='.PARMLIB' then do
   d=Locate_Parmlib(m)
   if d='' then call close 8 'Could not find member' m 'in parmlib'
 end
 d = "'"d"("m")'"
 address tso
 if sysdsn(d)<>'OK' then ,
   call close 8 'Could not locate file' d
 if BpxWdyn('alloc da('d') shr rtddn(xdd)')<>0 then,
   call close 8 'Allocate' d 'failed'
 "execio * diskr" xdd "(stem r. finis)"
 cc = rc
 zz=BpxWdyn('free dd('xdd')')
 if cc<>0 then call close 8 'Reading' d 'failed rc' cc
 if $ml>1 then say 'Dsn Load added' r.0 'records...'
 return 0

MakeWorkTable:  /* copy system ISPCMDS */
 $wrktbl='T'left(space(translate(time('l'),' ','.:'),0),7)
 if $ml>0 then say 'Make work table' $wrktbl 'in progress...'
 Address IspExec
 "tbcreate" $wrktbl "names(rtype zctverb zcttrunc zctact zctdesc)"
 "tbtop" $systbl
 do forever
   "tbskip" $systbl
   if rc<>0 then leave
   if word(zctact,1)='ALIAS' then rtype='A'  /* alias   */
   else rtype='C'                     /* command */
   "tbadd" $wrktbl
 end
 "tbtop" $wrktbl
 if $ml>0 then say 'Work table created'
 return 0

RebuildTable:  /* rewrite system command table */
 if $ml>0 then say 'Rebuild table in progress...'
 Address IspExec
 /* clear system table */
 "tbbottom" $systbl
 do forever
   "tbdelete" $systbl
   if rc<>0 then leave
 end
 /* build system table */
 "tbsort" $wrktbl "FIELDS(RTYPE,C,A,ZCTVERB,C,A) "
 "tbtop"  $wrktbl
 do forever
   "tbskip" $wrktbl
   if rc<>0 then leave
   "tbadd" $systbl
   if rc<>0 then call close 16 'Add system table' $systbl 'failed rc' rc
 end
 "tbtop" $systbl
 if $ml>0 then say 'Rebuild table done...'
 return 0

ListTables: Procedure expose ($gblv)    /* list all in-storage command table */
 arg tsel
 if tsel<>'' then tsel=tsel'CMDS'
 if $ml>1 then say space('Listtables' tsel '..')
 "qtabopen list(qtol.)"
 tbllist=''
 do qtn=1 to qtol.0
   tn=strip(qtol.qtn)
   if right(tn,4)<>'CMDS' then iterate
   if tsel<>'' then if tn<>tsel then iterate
   tbllist=tbllist tn
 end
 if $ml>1 then say 'Listing tables:' space(tbllist)
 call ListAdd 'Listing tables:' space(tbllist)
 call ListAdd ''
 do tln=1 to words(tbllist)
   tblname=word(tbllist,tln)
   Call ListAdd '-->' tblname
   Call ListAdd ''
   'tbquery' tblname 'rownum(rows)'
   if rc<>0 then do
     Call ListAdd '*Table is probably libdef''d in another screen'
     Call ListAdd ''
     iterate
   end
   tblid = left(tblname,length(tblname)-4)
   zerrlm=''
   'tbtop' tblname
   do rows
     'tbskip' tblname
     Call ListAdd  left(zctverb,8) left(tblid,4),
       left(zcttrunc,3) left(zctact,$width) left(zctdesc,$width)
   end
   Call ListAdd ''
 end
 Return ListView()

Unquote: return strip(space(translate(arg(1)," ","'")))

Locate_Ispprof: call Listdsi 'ispprof file';return sysdsname

Locate_Parmlib: Procedure /* locate member in parmlib concatenation */
 arg mbr
 /* go through list of parmlibs*/
 cvt      = Storage(10,4)                    /* get the CVT address   */
 cvtecvt  = Storage(D2x(C2d(cvt)+140),4)     /* get the ECVT address  */
 ecvtipa  = Storage(D2x(C2d(cvtecvt)+392),4) /* get the ihaipa Address*/
 Do loop = 0 to 10                           /* loop for parmlibs    */
  ipaplib = Storage(D2x(c2d(ecvtipa)+416+(loop*64)),64) /*           */
  ipapldsn = Substr(ipaplib,1,44)            /* parmlib dsname       */
  ipaplvol = Substr(ipaplib,46,6)            /* parmlib volume       */
  ipaplflg = X2b(C2x(Substr(ipaplib,64,1)))  /* parmlib flags        */
  if Strip(ipapldsn) = '' then iterate       /*                      */
  if sysdsn("'"strip(ipapldsn)"("mbr")'")='OK' then return strip(ipapldsn)
 End
 return ''

ListAdd:  parse value 1+lst.0 1+lst.0 arg(1) with # lst.0 lst.#; return 0
ListView: Procedure expose ($gblv) /* make view temp dataset */
 if $ml>1 then say 'ListView, listing' lst.0 'lines...'
 cc=bpxwdyn('alloc new delete rtddn(lstdd) unit(vio) dsorg(ps)',
    'lrecl(27994) recfm(v,b) blksize(0) tracks space(1,4)')
 if cc<>0 then exit xispmsg("alloc failed" cc)+12
 address tso "execio" lst.0 "diskw" lstdd "(stem lst. finis"
 address ispexec  "lminit dataid(did1) ddname("lstdd")"
 address ispexec  "view dataid("did1")"
 return Bpxwdyn("free dd("lstdd")")*0