106 lines
3.5 KiB
Plaintext
106 lines
3.5 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. ;
|
|
; ;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
%GSEL ;GT.M %GSEL utility - global select into a local array
|
|
;invoke ^%GSEL to create %ZG - a local array of existing globals, interactively
|
|
;
|
|
n add,beg,cnt,end,g,gd,gdf,k,out,pat,stp,i,c,g1
|
|
i '$d(%zdebug) n $et s $et="zg "_$zl_":ERR^%GSEL" u $p:(ctrap=$c(3):exc="zg "_$zl_":LOOP^%GSEL")
|
|
d init,main
|
|
u $p:(ctrap="":exc="")
|
|
q
|
|
GD n add,beg,cnt,end,g,gd,gdf,k,out,pat,stp
|
|
s cnt=0,(out,gd,gdf)=1
|
|
d main
|
|
i gdf s %ZG="*" d setup,it w !,"Total of ",cnt," global",$s(cnt=1:".",1:"s."),!
|
|
q
|
|
CALL n add,beg,cnt,end,g,gd,gdf,k,out,pat,stp,i,c,g1
|
|
s (cnt,gd)=0
|
|
i $d(%ZG)>1 s g="" f s g=$o(%ZG(g)) q:'$l(g) s cnt=cnt+1
|
|
i $g(%ZG)'?.N s out=0 d setup,it s %ZG=cnt q
|
|
s out=1
|
|
d main
|
|
q
|
|
init k %ZG
|
|
s (cnt,gd)=0,out=1
|
|
q
|
|
main f d inter q:'$l(%ZG)
|
|
s %ZG=cnt
|
|
q
|
|
inter r !,"Global ^",%ZG,! q:'$l(%ZG)
|
|
i $e(%ZG)="?",$l(%ZG)=1 d help q
|
|
i (%ZG="?D")!(%ZG="?d") d cur q
|
|
d setup,it
|
|
w !,$s(gd:"T",1:"Current t"),"otal of ",cnt," global",$s(cnt=1:".",1:"s."),!
|
|
q
|
|
setup i gd s add=1,cnt=0,g=%ZG k %ZG s %ZG=g
|
|
e i "'-"[$e(%ZG) s add=0,g=$e(%ZG,2,999)
|
|
e s add=1,g=%ZG
|
|
s g=$tr(g,"? !""#$&'()+'-./;<=>@[]\^_`{}|~","%")
|
|
s g=$tr(g,$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))
|
|
s g1="" f i=1:1:$l(g) s c=$e(g,i) if $a(c)<128 s g1=g1_c ; Filter out "all" non-ascii characters (be it M or UTF-8)
|
|
s g=g1
|
|
s end=$p(g,":",2),beg=$p(g,":")
|
|
i end=beg s end=""
|
|
q
|
|
it s gdf=0
|
|
i end'?."*",end']beg q
|
|
s g=beg d pat
|
|
i pat["""" d start f d search q:'$l(g) d save
|
|
i pat["""",'$l(end) q
|
|
s beg=stp
|
|
i '$l(g) s g=stp
|
|
s pat=".E",stp="^"_$e(end)_$tr($e(end,2,9999),"%","z") d start f d search q:'$l(g) d save
|
|
s g=end d pat
|
|
i pat["""" s:beg]g g=beg d start f d search q:'$l(g) d save
|
|
q
|
|
pat
|
|
n tmpstp
|
|
i $e(g)="%" s g="!"_$e(g,2,9999)
|
|
s pat=g
|
|
f q:$l(g,"%")<2 s g=$p(g,"%",1)_"#"_$p(g,"%",2,999),pat=$p(pat,"%",1)_"""1E1"""_$p(pat,"%",2,999)
|
|
f q:$l(g,"*")<2 s g=$p(g,"*",1)_"$"_$p(g,"*",2,999),pat=$p(pat,"*",1)_""".E1"""_$p(pat,"*",2,999)
|
|
i $e(g)="!" s g="%"_$e(g,2,9999),pat="%"_$e(pat,2,9999)
|
|
i pat["""" s pat="1""^"_pat_""""
|
|
s tmpstp="z",$p(tmpstp,"z",30)="z"
|
|
s g="^"_$p($p(g,"#"),"$"),stp=g_$e(tmpstp,$l(g)-1,31)
|
|
q
|
|
start i g="^" s g="^%"
|
|
i g?@pat,$d(@g) d save
|
|
q
|
|
search f s g=$o(@g) s:g]stp g="" q:g?@pat!'$l(g)
|
|
q
|
|
save i add,'$d(%ZG(g)) s %ZG(g)="",cnt=cnt+1 d prt:out
|
|
i 'add,$d(%ZG(g)) k %ZG(g) s cnt=cnt-1 d prt:out
|
|
q
|
|
prt w:$x>70 ! w g,?$x\10+1*10
|
|
q
|
|
help ;
|
|
w !,?2,"<RET>",?25,"to leave",!,?2,"""*""",?25,"for all"
|
|
w !,?2,"global",?25,"for 1 global"
|
|
w !,?2,"global1:global2",?25,"for a range"
|
|
w !,?2,"""*"" as a wildcard",?25,"permitting any number of characters"
|
|
w !,?2,"""%"" as a wildcard",?25,"for a single character in positions other than the first"
|
|
w !,?2,"""?"" as a wildcard",?25,"for a single character in positions other than the first"
|
|
i gd q
|
|
w !,?2,"""'"" as the 1st character",!,?25,"to remove globals from the list"
|
|
w !,?2,"?D",?25,"for the currently selected globals",!
|
|
q
|
|
cur w ! s g=""
|
|
f s g=$o(%ZG(g)) q:'$l(g) w:$x>70 ! w g,?($x\10+1*10)
|
|
q
|
|
ERR u $p w !,$p($ZS,",",2,999),!
|
|
u $p:(ctrap="":exc="")
|
|
s $ec=""
|
|
q
|
|
LOOP d main
|
|
u $p:(ctrap="":exc="")
|
|
q
|