iSharkFly-Open
/
fis-gtm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
fis-gtm/sr_port/rsel.mpt

183 lines
9.2 KiB
Plaintext
Raw Normal View History

ENH: Initial import from sourceforge. These source tree was directly imported from http://sourceforge.net/projects/fis-gtm/files/GT.M-x86-Linux-src/V5.4-002B/ by extracting the file: gtm_V54002B_linux_i686_src.tar.gz
2012-02-05 11:35:58 -05:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; 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