183 lines
9.2 KiB
Plaintext
183 lines
9.2 KiB
Plaintext
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; ;
|
|
; Copyright 1987, 2006 Fidelity Information Services, Inc ;
|
|
; ;
|
|
; This source code contains the intellectual property ;
|
|
; of its copyright holder(s), and is made available ;
|
|
; under a license. If you do not know the terms of ;
|
|
; the license, please stop and do not read further. ;
|
|
; ;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
%RSEL ;service@greystone.com gtm,%rsel;19920523;GT.M %RSEL utility - routine select into a local array
|
|
;invoke ^%RSEL to create %ZR - a local array of existing routines, interactively
|
|
;invoke OBJ^%RSEL to create %ZR based on object modules
|
|
;invoke CALL^%RSEL to maintain the array %ZR with the input %ZR, %ZE specifies extensions .m or .o[bj]
|
|
;
|
|
SRC
|
|
n $et s $et=$s($d(%zdebug):"b",1:"zg "_$zl_":err^%RSEL")
|
|
n add,beg,cnt,ctrap,d,delim,end,exc,from,i,k,last,mtch,pct,r,rd,rdf,out,scwc,stack,stop,strt,to,%ZE
|
|
s %ZE=".m"
|
|
k %ZR
|
|
i $d(%ZRSET) k ^%RSET($j)
|
|
d init,main
|
|
q
|
|
OBJ
|
|
n $et s $et=$s($d(%zdebug):"b",1:"zg "_$zl_":err^%RSEL")
|
|
n add,beg,cnt,ctrap,d,delim,end,exc,from,i,k,last,mtch,pct,r,rd,rdf,out,scwc,stack,stop,strt,to,%ZE
|
|
s %ZE=$s($zver["VMS":".obj",1:".o")
|
|
k %ZR
|
|
i $d(%ZRSET) k ^%RSET($j)
|
|
d init,main
|
|
q
|
|
RD
|
|
n $et s $et=$s($d(%zdebug):"b",1:"zg "_$zl_":err^%RSEL")
|
|
n add,beg,cnt,ctrap,d,delim,end,exc,from,i,k,last,mtch,pct,r,rd,rdf,out,scwc,stack,stop,strt,to,%ZRSET
|
|
w !,"Routine directory"
|
|
d init
|
|
s (out,rd,rdf)=1
|
|
i $l($g(%ZR)) w ! d work w !,"Total of ",cnt," routine",$s(cnt=1:".",1:"s."),! q
|
|
d main
|
|
i rdf s %ZR="*" d work W !,"Total of ",cnt," routine",$s(cnt=1:".",1:"s."),!
|
|
q
|
|
CALL
|
|
n add,beg,cnt,ctrap,d,delim,end,exc,from,i,k,last,mtch,pct,r,rd,rdf,out,scwc,stack,stop,strt,to n:'$d(%ZE) %ZE
|
|
i $g(%ZE)'[".o" s %ZE=".m"
|
|
d init
|
|
i $d(%ZRSET) d i $l($g(^%RSET($j))) s out=0 d main s ^%RSET($j)=cnt q
|
|
. i $d(^%RSET($j))>1 s r="" f s r=$o(^%RSET($j,r)) q:'$l(r) s cnt=cnt+1
|
|
e d i $l($g(%ZR)) s out=0 d main s:'$d(%ZRSET) %ZR=cnt s:$d(%ZRSET) ^%RSET($j)=cnt q
|
|
. i $d(%ZR)>1 s r="" f s r=$o(%ZR(r)) q:'$l(r) s cnt=cnt+1
|
|
d main
|
|
q
|
|
SILENT(patt,label)
|
|
n $et s $et=$s($d(%zdebug):"b",1:"zg "_$zl_":err^%RSEL")
|
|
i ""=$g(label) s label="SRC"
|
|
d @label
|
|
q
|
|
init
|
|
i $zver["VMS" d
|
|
. s delim=",",scwc="%",from="abcdefghijklmnopqrstuvwxyz !""#$&'()+'-./;<=>?@[]\^_`{}|~",to="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
|
|
e d
|
|
. s delim=" ",scwc="?",from=" !""#$&'()+'-./;<=>@[]\^_`{}|~",to=""
|
|
s from=from_$c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127)
|
|
zsh "d":d
|
|
s d=""
|
|
f s d=$o(d("D",d)) q:d="" i $p=$p(d("D",d)," ") s d=d("D",d),ctrap=$p($p(d,"CTRA=",2)," "),exc=$p(d,"EXCE=",2) q
|
|
e s (ctrap,exc)="" ; should never happen
|
|
s k=$l(exc,"""")
|
|
s k=$l(exc) i $e(exc,1,1)="""",$e(exc,k,k)="""" s exc=$e(exc,2,k-1)
|
|
if ctrap'="" s exc="s ctrap="_ctrap x exc
|
|
k d
|
|
s (cnt,rd)=0,out=1,(last,r(0))=$c(255)
|
|
i '$l($zro) s d=1,d(1)="" q
|
|
s d=0
|
|
f k=1:1:$l($zro,delim) d i $l(r) s d=d+1,d(d)=$p(r,"*")
|
|
. s r=$p($zro,delim,k)
|
|
. i delim=" " d s:$l(r) r=$zparse(r_"/","","*") q ; UNIX conventions
|
|
. . i r'["(" q ; no source info - it does both
|
|
. . i %ZE[".o" d q ; only want objects
|
|
. . . s r=$p(r,"(") ; grab object directory
|
|
. . . f k=k:1:$l($zro,delim) q:$p($zro,delim,k)[")" ; and step over source info
|
|
. . s r=$p(r,"(",2) ; grab 1st souce directory
|
|
. . i r[")" s r=$p(r,")") q ; it's the only one - we're done
|
|
. . d f k=k+1:1 s r=$p($zro,delim,k) i $l(r) d i r[")" s r=$p(r,")") q ; record all but the last
|
|
. . . i r'[")" s r=$p($zparse(r_"/","","*"),"*") i $l(r) s d=d+1,d(d)=r
|
|
. e d s:$l(r) r=$zparse(r,"","*") q ; VMS conventions
|
|
. . i r[".olb" s r="" q ; it's an object library and we don't poke in them
|
|
. . i r'["/" q ; no souces info - it does both
|
|
. . i %ZE[".o" d q ; only want objects
|
|
. . . s r=$p(r,"/") ; grab the object directory
|
|
. . . f k=k:1:$l($zro,delim) q:$p($zro,delim,k)[")" ; and step over source info
|
|
. . s r=$p(r,"=",2) ; grab 1st source directory
|
|
. . i $e(r)'="(" q ; /SRC or /NOSRC - we're done
|
|
. . s r=$p(r,"(",2) ; strip the opening (
|
|
. . i r[")" s r=$p(r,")") q ; it's in parens but only one
|
|
. . d f k=k+1:1 s r=$p($zro,delim,k) i $l(r) d i r[")" s r=$p(r,")") q ; record all but the last
|
|
. . . i r'[")" s r=$p($zparse(r,"","*"),"*") i $l(r) s d=d+1,d(d)=r
|
|
q
|
|
main
|
|
u:'$d(%zdebug) $p:(ctrap=$c(3):exception="zg "_$zl_":main^%RSEL")
|
|
s mtch="__" d start(0)
|
|
f d q:'$l(%ZR)
|
|
. zsh "s":stack ; get the current stack
|
|
. i $p(stack("S",1),"^",2)=$p($g(stack("S",4)),"^",2) s %ZR=patt,patt="",out=0 k stack q:'$l(%ZR) ; if silent, don't prompt
|
|
. e r !,"Routine: ",%ZR,! q:'$l(%ZR)
|
|
. i $e(%ZR)="?" d help q
|
|
. d work
|
|
. i '$d(stack) q ; if silent, don't output count
|
|
. e w !,$s(rd:"T",1:"Current t"),"otal of ",cnt," routine",$s(cnt=1:".",1:"s."),!
|
|
i $D(%ZRSET) s ^%RSET($j)=cnt k %ZR
|
|
e s %ZR=cnt
|
|
u $p:(ctrap=ctrap:exception=exc)
|
|
q
|
|
work
|
|
i rd s add=1,cnt=0,r=%ZR k %ZR s %ZR=r ; This behavior is a bit odd
|
|
e i "'-"[$e(%ZR) s add=0,r=$e(%ZR,2,999)
|
|
e s add=1,r=%ZR
|
|
s r=$tr(r,from,to) ; strip out invalid characters, and, in VMS, xlate lower to upper
|
|
; In addition, filter out "all" non-ascii characters (irrespective of M or UTF-8)
|
|
n r1,c s r1="" f k=1:1:$l(r) s c=$e(r,k) if $a(c)<128 s r1=r1_c
|
|
s r=r1
|
|
s end=$p(r,":",2),beg=$p(r,":"),rdf=0
|
|
i end=beg!'$l(end) q:'$l(beg) s stop=last ; if all stripped out, done
|
|
s:'$l(beg) beg="*" s pct=$e(beg) ; CAUTION: ELSE on next line
|
|
e s strt=$$mask(beg),stop=$$mask(end) i $l($p(stop,"$")) q:stop']strt ; if end before begining, done
|
|
i "*?"[pct s mtch="%*" d start(1) f s r=$$search(1) q:r]stop!'$l(r) d save ; if alls, get _files first
|
|
s pct=pct="%",mtch=beg
|
|
d start(pct)
|
|
f s r=$$search(pct) q:r]stop!'$l(r) d save ; do begining
|
|
i stop=last q ; no range - we're done
|
|
s stop=$p(stop,"$")
|
|
i $l(stop),stop]$p(strt,"$") d ; if no overlap, do middle
|
|
. s strt=$tr(strt,"$",last)
|
|
. i pct s mtch="%*" d start(1) f s r=$$search(1) q:stop']r!'$l(r) i r]strt d save
|
|
. i $e(end)'="%" s mtch="*" d start(0) f s r=$$search(0) q:stop']r!'$l(r) i r]strt d save
|
|
e s strt=$p(strt,"$") i '$l(strt) s strt="$"
|
|
s pct=$e(end)="%",mtch=end
|
|
d start(pct)
|
|
f s r=$$search(pct) q:'$l(r) i strt']r d save ; and finish
|
|
q
|
|
mask(val)
|
|
q $tr($e(val),"*?","$$")_$tr($e(val,2,9999),"*?%","$$$")
|
|
;
|
|
start(pct)
|
|
s mtch=$s('pct:mtch,1:"_"_$e(mtch,2,9999))_%ZE
|
|
f k=1:1:d s r(k)=$$next(k,pct)
|
|
q
|
|
search(pct)
|
|
s r=last
|
|
f k=d:-1:1 i $l(r(k)) s:r(k)=r(k-1) r(k)=$$next(k,pct) i $l(r(k)),r(k)']r s i=k,r=r(k)
|
|
i r'=last s r(i)=$$next(i,pct)
|
|
e s r=""
|
|
q r
|
|
;
|
|
next(k,pct,t)
|
|
f s t=$zsearch(d(k)_mtch,k) q:t="" s t=$zparse(t,"NAME") q:t?1A.AN!pct i scwc="%",$e(t)]"Z" s t="" q
|
|
q $s('pct:t,$e(t)="_":"%"_$e(t,2,9999),1:"")
|
|
;
|
|
save
|
|
i $d(%ZRSET) d
|
|
. i add,'$d(^%RSET($j,r)) s ^%RSET($j,r)=d(i),cnt=cnt+1
|
|
. e i 'add,$d(^%RSET($j,r)) k ^%RSET($j,r) s cnt=cnt-1
|
|
. i i out w:$x>70 ! w r,?$x\10+1*10
|
|
e d
|
|
. i add,'$d(%ZR(r)) s %ZR(r)=d(i),cnt=cnt+1
|
|
. e i 'add,$d(%ZR(r)) k %ZR(r) s cnt=cnt-1
|
|
. i i out w:$x>70 ! w r,?$x\10+1*10
|
|
q
|
|
help
|
|
i "Dd"[$e(%ZR,2),$l(%ZR)=2 d q
|
|
. w ! s r=""
|
|
. f s r=$o(%ZR(r)) q:'$l(r) w:$x>70 ! w r,?($x\10+1*10)
|
|
w !,"<RET>",?15,"to leave",!,"* ",?15,"for all",!,"rout ",?15,"for 1 routine",!,"rout1:rout2 ",?15,"for a range"
|
|
w !,"* ",?15,"as wildcard permitting any number of characters"
|
|
w !,scwc,?15,"as a single character wildcard in positions other than the first"
|
|
i rd q
|
|
w !,"' ",?15,"as the 1st character to remove routines from the list"
|
|
w !,"?D ",?15,"for the currently selected routines"
|
|
q
|
|
err
|
|
u $p:(ctrap=ctrap:exception=exc) w !,$p($ZS,",",2,999),!
|
|
s $ec=""
|
|
q
|