/* REXX ISPCTE - ISPF command table edit parameters libname mbrname libname(mbrname) - allows ISPCTE to be used from ISPF 3.4 mbrname - ispf profile ds will be used as libname !! After installation, change the usertable and sitetable to your local values. Note - an internal work table is created to be able to sort to put ZACT 'ALIAS' values up front. Externalized variables icteplds - permanent table dsname icteptbl - permanent table name ictepmds - permanent dsname(mbrname) ictepmds - permanent dsname(mbrname) ddname ictetlds - temp lib dsname ictetldd - temp lib ddname ictetmdd - temp mbr ddname ictettbl - temp table name ictewtbl - work table name (the one being displayed) ictenowr - nowrite option Updates: 2018-01-08 fix problems with internal copies 2018-01-10 add export / import commands and GetCfgTableNames() 2018-01-15 fix problem with prompt for new table add NOWRITE option, i.e. when viewing ISPCMDS. 2018-09-28 minor internal changes 2018-10-19 add prompt for table rewrite 2018-10-22 check for proper ISPF cmd table add support for user2-3 and site2-3 tables Written by Willy Jensen, email willy.h.jensen@outlook.com */ /* !! you must set the usertable / sitetable to your local values !! */ usertable1 = 'UCT1CMDS' dd2dsn('ispprof') /* name and library */ usertable2 = '' usertable3 = '' sitetable1 = 'SCT1CMDS SYSX.ISPTLIB' /* name and library */ sitetable2 = '' sitetable3 = '' ictevlist = 'icteplds icteptbl ictepmds ictepmdd', 'ictetlds ictettbl ictetldd ictetmdd', 'ictewtbl ictecfgd ictenowr' parse value usertable1 sitetable1 with usertbl userlib sitetbl sitelib, ddlist /* set to null */ parse value copies('0 ',20) with ictenowr . /* Locate and read the ISPF config table if not named above */ if usertbl='' then do Parse value GetCfgTableNames() with ut st if ut<>0 then usertbl=ut if st<>0 then sitetbl=ut end /* called as subroutine from XISPTBL ?? */ arg p1,pid,pcmd,ptable,ptext if p1='XISPTBL' then Exit XispCmdX(pid,pcmd,ptable,ptext) /* standard path */ parse source sys type whoami ddn whereami . parse value '' with ictetldd ictetmdd ictettbl ictewtbl Address ispexec "control errors return" ictenowr=(wordpos('NOWRITE',p1)>0) if ictenowr then p1=space(delword(p1,wordpos('NOWRITE',p1),1)) parse value translate(p1,' ',"'()") with p1 p2 . if p1<>'' & p2='' & length(p1)>4 then , call close 8 'Invalid table name' p1 Select when p1''p2='' then parse var usertable1 icteptbl icteplds . when p1''p2='USER' then parse var usertable1 icteptbl icteplds . when p1''p2='USER1' then parse var usertable1 icteptbl icteplds . when p1''p2='USER2' then parse var usertable2 icteptbl icteplds . when p1''p2='USER3' then parse var usertable3 icteptbl icteplds . when p1''p2='SITE' then parse var sitetable1 icteptbl icteplds . when p1''p2='SITE1' then parse var sitetable1 icteptbl icteplds . when p1''p2='SITE2' then parse var sitetable2 icteptbl icteplds . when p1''p2='SITE3' then parse var sitetable3 icteptbl icteplds . when p1<>'' & p2='' then parse value p1 LocMbrDs(p1,'isptlib'), with icteptbl icteplds otherwise parse value p2 p1, with icteptbl icteplds End if icteptbl='' then call close 8 'Table not set' if right(icteptbl,4)<>'CMDS' then icteptbl=icteptbl'CMDS' icteplds = word(icteplds userlib,1) ictepmds = icteplds'('icteptbl')' Address ispexec /*-------------------------------------------------------------------- Ensure that permanent user table exist --------------------------------------------------------------------*/ if sysdsn("'"ictepmds"'")<>'OK' then do parse value '' with isctep3 isctep4 isctep1 = 'Permanent table' ictepmds 'not found' isctep2 = 'Press ENTER to continue, END/RETURN to abort' "addpop" "display panel(ispctep)" cc=rc "rempop" if cc<>0 then exit 0 zerrlm='' "tbcreate" icteptbl "names(ZCTVERB ZCTTRUNC ZCTACT ZCTDESC)" if rc<>0 then call close 8 "Create new table failed" cc zerrlm "tbclose" icteptbl "library(ispprof)" if rc<>0 then call close 8 "Initial write of new table failed" cc zerrlm end /*-------------------------------------------------------------------- Make temp table lib --------------------------------------------------------------------*/ cc=bpxwdyn('alloc new delete rtddn(ictetldd) rtdsn(ictetlds)', 'tracks space(1,1) unit(vio) like('dd2dsn('ispprof')')') if cc<>0 then call close 8 "alloc templib failed" cc ictettbl=ictetldd ddlist=ddlist ictetldd cc=bpxwdyn('alloc shr rtddn(ictetmdd) da('ictetlds'('ictettbl')') if cc<>0 then call close 8 'alloc temp table rc' rc ddlist=ddlist ictetmdd cc=bpxwdyn('alloc shr rtddn(ictepmdd) da('ictepmds')') if cc<>0 then call close 8 'alloc perm ds' ictepmds 'failed' rc ddlist=ddlist ictepmdd Call Silent "Repro infile("ictepmdd") outfile("ictetmdd")" if rc<>0 then do n=1 to $.0 say $.n end if rc<>0 then call close 8 "repro to templib failed" rc /*-------------------------------------------------------------------- Open temp table, create edit-table --------------------------------------------------------------------*/ "tbopen" ictettbl "library("ictetldd")" /* table copy */ if rc<>0 then call close 8 "initial load from templib failed" rc ictewtbl='ZZZ'substr(ictettbl,4) /* SYS -> ZZZ */ "tbquery" ictettbl "names(names) rownum(n)" names = translate(names,' ','()') if wordpos('ZCTVERB',names)=0 | wordpos('ZCTTRUNC',names)=0 , | wordpos('ZCTACT',names)=0 | wordpos('ZCTDESC',names)=0 , then call close 8 "Table" icteptbl "is not a proper ISPF cmd table" if wordpos('ZSEL',names)=0 then names='ZSEL' names if wordpos('ZCTSORT',names)=0 then names='ZCTSORT' names "tbcreate" ictewtbl "names("names") nowrite" if rc<>0 then call close 8 "Create work table failed" rc Call CopyTable ictettbl,ictewtbl /*-------------------------------------------------------------------- Run the table edit dialog --------------------------------------------------------------------*/ "tbquery" icteptbl if rc<>0 then call ispmsg 'Note, table' icteptbl 'is not active' "vput ("ictevlist")" "vget zscrmaxw" w=min(zscrmaxw,160) cc=XISPTBL('table('ictewtbl') panel(ispctel) dpanel(ispcted) width('w')', 'isel(all) proc('whoami') id('ictettbl') crc(1)', 'sort(zctverb) hdr(Edit table' icteptbl 'in' icteplds')') if cc>8 then call close 8 'Error rc' cc if cc=8 then call close 1 'Cancelled' if ictenowr then call close 0 if cc<>1 & initial<>'Y' then call close 0 'no change' /* better prompt before saving table */ parse value '' with isctep2 isctep4 isctep1 = 'Rewrite changed table' ictepmds '?' isctep3 = 'Press ENTER to continue, END/RETURN to abort' "addpop" "display panel(ispctep)" cc=rc "rempop" if cc=0 then call SaveTable else call ispmsg 'Save aborted' Call Close 0 /*-------------------------------------------------------------------- Make and sort work table - ALIAS must be first --------------------------------------------------------------------*/ SaveTable: if ictenowr then return ispmsg('Table is in NOWRITE mode') address ispexec "vget ("ictevlist")" "tbsort" ictewtbl "fields(zctsort,C,A,zctverb,C,A)" if rc<>0 then call close 8 "Sort work table failed" rc Call CopyTable ictewtbl,ictettbl /* work -> temp */ "tbsort" ictewtbl "fields(zctverb,C,A)" Call CopyTable ictettbl,icteptbl /* temp -> perm */ /* Replace temporary table */ "tbsave" ictettbl "library("ictetldd")" /* make backup copy - requires PDS86 installed */ Call Silent "pdsmain '"icteplds"' repro" icteptbl, "as("overlay('Z',icteptbl,length(icteptbl))") replace" /* Replace permanent table */ cc=Silent("Repro infile("ictetmdd") outfile('"ictepmdd"')") if cc=0 then Return ispmsg('Table' icteptbl 'saved') say "Repro to templib failed" cc do n=1 to $.0 say $.n end Return 0 /*-------------------------------------------------------------------- Copy table --------------------------------------------------------------------*/ CopyTable: Procedure trace off arg srctbl,tgttbl Address IspExec /* clear target table */ zerrlm='' "tbquery" tgttbl "rownum(rows)" if rows>0 then do "tbbottom" tgttbl do rows "tbdelete" tgttbl end end /* copy table */ "tbquery" srctbl "rownum(rows)" "tbtop" srctbl do rows "tbskip" srctbl if wordpos(translate(zctact),'ALIAS')>0 then upper zctact zctsort=(zctact<>'ALIAS') /* 0 if 'ALIAS', else '1' */ zsel ='' "tbadd" tgttbl end "tbtop" tgttbl return 0 /*-------------------------------------------------------------------- Cleanup and terminate --------------------------------------------------------------------*/ Close: trace off parse arg clsrc clsmsg z=outtrap('zz.') /* silent commands */ if ictettbl<>'' then address ispexec "tbend" ictettbl if ictewtbl<>'' then address ispexec "tbend" ictewtbl address ispexec "tbopen zzzzzzzz library(zzzzzzzz)" /* release libdef */ Call Silent "free dd("ictetmdd ictetldd ictepmdd ictepldd")" z=outtrap('off') Exit XMsg(clsmsg,clsrc) XMsg: if arg(1)<>'' then say arg(1);return word(arg(2) 0,1) ISPMSG: parse arg zedlmsg address ispexec"setmsg msg(isrz000)" return 0 Silent: trace off; zz=outtrap(word(arg(2) '$.',1)) address tso arg(1);zz=outtrap('off');return rc DD2Dsn: zz=Listdsi(arg(1) 'file'); return sysdsname UnParan: return strip(translate(arg(1),' ','()')) LocMbrDs: trace off liblist='' arg libmbr . if right(libmbr,4)<>'CMDS' then libmbr=arg(1)'CMDS' address ispexec "qbaselib isptlib id(liblist)" liblist=dd2dsn('ispprof') space(translate(liblist," ","',")) do liblistn=1 to words(liblist) libds=word(liblist,liblistn) if Sysdsn("'"libds"("libmbr")'")='OK' then return libds end return '' /*-------------------------------------------------------------------- XISPTBL command handler --------------------------------------------------------------------*/ XispCmdX: arg pid,pcmd,ptable,ptext address ispexec "vget ("ictevlist")" /* i.e. "ZYZ00269","CMD","ZYZ00269","ACTivate" */ parse var ptext ptverb ptdata Select when pcmd<>'CMD' then exit 0 when ptext='SAVE' then exit SaveTable() when ptext ='EXPORT' then exit Export() when ptverb='IMPORT' & ptdata<>'' then exit Import(ptdata) when abbrev('ACTIVATE',ptext,3) then, exit CopyTable(ictewtbl,icteptbl) otherwise exit ispmsg(ptext 'is not a valid command') End Exit 0 /*-------------------------------------------------------------------- Import dataset, add to active table. format is ISPCMDU --------------------------------------------------------------------*/ Import: if Ds2stem(arg(1),'imp.')<>0 then, exit ispmsg('Import - load' arg(1) 'did not return data') parse value '' with zsel zctsort impn=0 do n=1 to imp.0 d=left(imp.n,1) if d='*' then iterate parse var imp.n . (d) zctverb (d) zcttrunc (d) zctact (d) zctdesc if word(zctdesc,1)='*U*' | word(zctdesc,1)='*S*', then zctdesc=subword(zctdesc,2) address ispexec "tbadd" ptable if rc=0 then impn=impn+1 end if impn>0 then address ispexec "tbsort" ptable "fields(zctverb,C,A)" return ispmsg(impn 'records imported from' arg(1)) /*-------------------------------------------------------------------- Export table to dataset, in ISPCMDU format --------------------------------------------------------------------*/ Export: address tso "delstack" /*just in case */ expds=userid()".ISPCTE."icteptbl".EXPORT" if sysdsn("'"expds"'")='OK' then Call silent "delete '"expds"'" cc=bpxwdyn('alloc new catalog rtddn(expdd) da('expds')', 'tracks space(1,1) unit(sysda) recfm(v,b) lrecl(500) blksize(0)') if cc<>0 then exit ispmsg('Export - alloc' expds 'rc' cc) ddlist=ddlist expdd address ispexec "tbquery" ptable "rownum(rows)" "tbtop" ptable queue '* table' ictetbl 'in' icteplds 'exported' date() time() 'by' userid() do n=1 to rows "tbskip" ptable queue ';'zctverb';'zcttrunc';'zctact';'zctdesc end address tso "execio" queued() "diskw" expdd "(finis)" cc=rc address tso "delstack" /*just in case */ if cc=0 then "edit dataset('"expds"')" Call FreeDD expdd return 0 /*-------------------------------------------------------------------- some subroutines --------------------------------------------------------------------*/ FreeDD: Procedure expose ddlist arg p . if bpxwdyn('free dd('p')')<>0 then return 1 n=wordpos(p,ddlist) if n>0 then ddlist=delword(ddlist,n,1) return 0 Ds2Stem: /* dataset,stem */ arg ds2sds .,ds2sstm . zz=Value(ds2sstm'0',0) cc=bpxwdyn('alloc da('ds2sds') shr rtddn(ds2sdd)') if cc=0 then address tso "execio * diskr" ds2sdd "(stem" ds2sstm "finis)" if cc=0 then zz=bpxwdyn('free dd('ds2sdd')') return Value(ds2sstm'0')=0 GetCfgTableNames: procedure cfgds=LocMbrDs('ISPCFIGU','ISPLLIB') if cfgds='' then return xmsg('ISPCFIGU not found in ISPLLIB') cfgmbr.0=0 cc=bpxwdyn('alloc da('cfgds'(ISPCFIGU)) shr rtddn(cfgmbrdd)') if cc=0 then address tso "execio * diskr" cfgmbrdd "(stem cfgmbr. finis)" if cc=0 then zz=bpxwdyn('free dd('cfgmbrdd')') if cfgmbr.0=0 then return xmsg('ISPCFIGU not loaded') do n=1 to cfgmbr.0 until p<>0 p=pos('BYES',cfgmbr.n) /* this works for z/OS 1.13 - 2.3 */ end if p=0 then return xmsg('BYES not found in config') ictecfgd=cfgds address ispexec "vput ictecfgd" parse value substr(cfgmbr.n,p-8,8) with ut +4 st if ut='' then return xmsg('Config User table name is blank') if st='' then return xmsg('Config Site table name is blank') return ut