211 lines
7.6 KiB
Mathematica
211 lines
7.6 KiB
Mathematica
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
; ;
|
||
|
|
; Copyright 2010 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. ;
|
||
|
|
; ;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
gdeparse: ;command parser
|
||
|
|
GDEPARSE
|
||
|
|
n verb,NAME,REGION,SEGMENT,gqual,lquals
|
||
|
|
d matchtok("TKIDENT","Verb") s verb=token
|
||
|
|
d checkkw(.verb,"verb","syntab")
|
||
|
|
d @verb
|
||
|
|
q
|
||
|
|
qual(qual,ent,s)
|
||
|
|
i ntoktype="TKEOL" zm gdeerr("QUALREQD"):ent
|
||
|
|
d matchtok(sep,ent),matchtok("TKIDENT",ent)
|
||
|
|
s qual=token d checkkw(.qual,ent,s) s t=@s@(qual)
|
||
|
|
i negated,t'["NEGATABLE" zm gdeerr("NONEGATE"):qual
|
||
|
|
i t["REQUIRED",ntoktype'="TKEQUAL",'negated zm gdeerr("VALUEREQD"):qual
|
||
|
|
i "NEGATABLE"[t!negated,ntoktype="TKEQUAL" zm gdeerr("NOVALUE"):qual
|
||
|
|
i t["NEGATABLE" s qual("value")='negated
|
||
|
|
i ntoktype="TKEQUAL",t'["LIST" s qual("value")=$$getvalue(s,qual) q
|
||
|
|
i ntoktype="TKEQUAL" d list(qual)
|
||
|
|
q
|
||
|
|
getvalue:(s,qual)
|
||
|
|
d matchtok("TKEQUAL","Value")
|
||
|
|
i ntoktype="TKEOL" zm gdeerr("VALUEREQD"):qual
|
||
|
|
d @@s@(qual,"TYPE")
|
||
|
|
q value
|
||
|
|
;
|
||
|
|
list:(lhead)
|
||
|
|
n sep
|
||
|
|
s tmp=lqual,v=lqual("value")
|
||
|
|
i $e(comline,cp)="(" d GETTOK^GDESCAN
|
||
|
|
s sep=ntoktype d getlitm
|
||
|
|
i sep="TKLPAREN" s sep=ntoktype f q:ntoktype="TKRPAREN" zm:"TKRPAREN|TKCOMMA"'[ntoktype gdeerr("RPAREN") d getlitm
|
||
|
|
i ntoktype="TKRPAREN" d GETTOK^GDESCAN
|
||
|
|
s lqual=tmp,lqual("value")=v
|
||
|
|
q
|
||
|
|
TNUMBER
|
||
|
|
d GETTOK^GDESCAN
|
||
|
|
i toktype'="TKNUMLIT" zm gdeerr("VALUEBAD"):token:"number"
|
||
|
|
i $l(token)'=$zl(token) zm gdeerr("NONASCII"):token:"number" ; error if the token has non-ascii numbers
|
||
|
|
s value=token
|
||
|
|
q
|
||
|
|
TFSPEC
|
||
|
|
k filespec
|
||
|
|
i ntoktype="TKEOL" zm gdeerr("QUALREQD"):"file specification"
|
||
|
|
i ntoktype="TKSTRLIT" s filespec=$ze(ntoken,2,$zl(ntoken)-1)
|
||
|
|
e d TFSPECP
|
||
|
|
d GETTOK^GDESCAN ; put the scanner back on track
|
||
|
|
i $zl(filespec)>(SIZEOF("file_spec")-1) zm gdeerr("VALUEBAD"):filespec:"file specification"
|
||
|
|
i '$l($zparse(filespec,"","","","SYNTAX_ONLY")) zm gdeerr("VALUEBAD"):filespec:"file specification"
|
||
|
|
s @("value="_$s($l(filexfm):filexfm,1:filespec)) ; do system specific file name translation
|
||
|
|
q
|
||
|
|
TFSPECP ; scan filespec token by token
|
||
|
|
n c,cp1 ; unix filenames must be quoted to avoid / conflicts with qualifiers
|
||
|
|
s cp1=cp-$l(ntoken)
|
||
|
|
f i=0:1 s c=$e(comline,cp1+i) q:c'?@dbfilpar!'$l(c)
|
||
|
|
s filespec=$e(comline,cp1,cp1+i-1),cp=cp1+i
|
||
|
|
q
|
||
|
|
TACCMETH
|
||
|
|
d GETTOK^GDESCAN
|
||
|
|
i toktype'="TKIDENT" zm gdeerr("VALUEBAD"):token:qual
|
||
|
|
s value=$tr(token,lower,upper)
|
||
|
|
i @s@(qual,"TYPE","VALUES")'[("\"_value) zm gdeerr("VALUEBAD"):token:qual
|
||
|
|
q
|
||
|
|
TNULLSUB
|
||
|
|
d GETTOK^GDESCAN
|
||
|
|
i toktype'="TKIDENT" zm gdeerr("VALUEBAD"):token:qual
|
||
|
|
s value=$tr(token,lower,upper)
|
||
|
|
i @s@(qual,"TYPE","VALUES")'[("\"_value) zm gdeerr("VALUEBAD"):token:qual
|
||
|
|
q
|
||
|
|
TREGION
|
||
|
|
n REGION d REGION s value=REGION
|
||
|
|
q
|
||
|
|
TSEGMENT
|
||
|
|
n SEGMENT d SEGMENT s value=SEGMENT
|
||
|
|
q
|
||
|
|
NAME
|
||
|
|
k NAME
|
||
|
|
i ntoktype="TKEOL" zm gdeerr("OBJREQD"):"name"
|
||
|
|
n c,cp1
|
||
|
|
s cp1=cp-$l(ntoken)
|
||
|
|
f i=0:1 s c=$e(comline,cp1+i) q:c'?.1"%".1AN.1"*"!'$l(c)
|
||
|
|
s NAME=$e(comline,cp1,cp1+i-1),cp=cp1+i d GETTOK^GDESCAN ; put the scanner back on track
|
||
|
|
i '$l(NAME) zm gdeerr("VALUEBAD"):token:"name"
|
||
|
|
i $l(NAME)'=$zl(NAME) zm gdeerr("NONASCII"):NAME:"name" ; error if the name is non-ascii
|
||
|
|
i NAME'="*" s x=$e(NAME) i x'="%",x'?1A zm gdeerr("NAMSTARTBAD"):NAME
|
||
|
|
i $e(NAME,2,999)'?.AN.1"*" zm gdeerr("VALUEBAD"):NAME:"name"
|
||
|
|
i $l(NAME)>PARNAMLN zm gdeerr("VALTOOLONG"):NAME:PARNAMLN:"name"
|
||
|
|
q
|
||
|
|
REGION
|
||
|
|
k REGION
|
||
|
|
i ntoktype="TKEOL" zm gdeerr("OBJREQD"):renpref_"region"
|
||
|
|
n c,cp1
|
||
|
|
s cp1=cp-$l(ntoken)
|
||
|
|
f i=0:1 s c=$e(comline,cp1+i) q:c'?.1AN.1"$".1"_"!'$l(c)
|
||
|
|
s REGION=$tr($e(comline,cp1,cp1+i-1),lower,upper),cp=cp1+i d GETTOK^GDESCAN ; put the scanner back on track
|
||
|
|
i '$l(REGION) zm gdeerr("VALUEBAD"):token:renpref_"region"
|
||
|
|
i $l(REGION)'=$zl(REGION) zm gdeerr("NONASCII"):REGION:"region" ; error if the name of the region is non-ascii
|
||
|
|
i REGION=defreg q
|
||
|
|
s x=$e(REGION) i x'?1A zm gdeerr("PREFIXBAD"):REGION:renpref_"region"
|
||
|
|
i $l(REGION)>PARREGLN zm gdeerr("VALTOOLONG"):REGION:PARREGLN:renpref_"region"
|
||
|
|
q
|
||
|
|
SEGMENT
|
||
|
|
k SEGMENT
|
||
|
|
i ntoktype="TKEOL" zm gdeerr("OBJREQD"):renpref_"segment"
|
||
|
|
n c,cp1
|
||
|
|
s cp1=cp-$l(ntoken)
|
||
|
|
f i=0:1 s c=$e(comline,cp1+i) q:c'?.1AN.1"$".1"_"!'$l(c)
|
||
|
|
s SEGMENT=$tr($e(comline,cp1,cp1+i-1),lower,upper),cp=cp1+i d GETTOK^GDESCAN ; put the scanner back on track
|
||
|
|
i '$l(SEGMENT) zm gdeerr("VALUEBAD"):token:renpref_"segment"
|
||
|
|
i $l(SEGMENT)'=$zl(SEGMENT) zm gdeerr("NONASCII"):SEGMENT:"segment" ; error if the name of the segment is non-ascii
|
||
|
|
i SEGMENT=defseg q
|
||
|
|
s x=$e(SEGMENT) i x'?1A zm gdeerr("PREFIXBAD"):SEGMENT:renpref_"segment"
|
||
|
|
i $l(SEGMENT)>PARSEGLN zm gdeerr("VALTOOLONG"):SEGMENT:PARSEGLN:renpref_"segment"
|
||
|
|
q
|
||
|
|
matchtok:(tok,ent)
|
||
|
|
d GETTOK^GDESCAN
|
||
|
|
i toktype=tok q
|
||
|
|
zm gdeerr("VALUEBAD"):token:ent
|
||
|
|
q
|
||
|
|
checkkw:(kw,ent,kwlist)
|
||
|
|
n x1,x2
|
||
|
|
s kw=$tr(kw,lower,upper)
|
||
|
|
i $e(kw,1,2)="NO" s negated=1,kw=$e(kw,3,999)
|
||
|
|
e s negated=0
|
||
|
|
s x1="" f s x1=$o(@kwlist@(x1)) q:kw=$e(x1,1,$l(kw))!'$l(x1)
|
||
|
|
i '$l(x1) zm gdeerr("KEYWRDBAD"):kw:ent
|
||
|
|
s x2=x1 f s x2=$o(@kwlist@(x2)) q:kw=$e(x2,1,$l(kw))!'$l(x2)
|
||
|
|
i $l(x2) zm gdeerr("KEYWRDAMB"):kw:ent
|
||
|
|
s kw=x1
|
||
|
|
q
|
||
|
|
getqual: d qual(.lqual,"Local qualifier","syntab("""_verb_""","""_gqual_""")")
|
||
|
|
i '$d(lquals(lqual)) s lquals(lqual)=$g(lqual("value"))
|
||
|
|
e zm gdeerr("QUALDUP"):lqual
|
||
|
|
q
|
||
|
|
getlitm: d qual(.lqual,"Local qualifier","syntab("""_verb_""","""_gqual_""","""_lhead_""")")
|
||
|
|
i '$d(lquals(lqual)) s lquals(lqual)=$g(lqual("value"))
|
||
|
|
e zm gdeerr("QUALDUP"):lqual
|
||
|
|
q
|
||
|
|
|
||
|
|
;-----------------------------------------------------------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
ADD
|
||
|
|
CHANGE
|
||
|
|
d qual(.gqual,"Global qualifier","syntab("""_verb_""")"),@gqual
|
||
|
|
f q:ntoktype="TKEOL" d getqual
|
||
|
|
d @gqual^@("GDE"_$e(verb,1,5))
|
||
|
|
q
|
||
|
|
RENAME
|
||
|
|
d qual(.gqual,"Global qualifier","syntab("""_verb_""")")
|
||
|
|
n renpref
|
||
|
|
s renpref="old " d @gqual s old=@gqual
|
||
|
|
s renpref="new " d @gqual s new=@gqual
|
||
|
|
s renpref="" d matchtok("TKEOL","End of line")
|
||
|
|
d @gqual^GDERENAM(old,new)
|
||
|
|
q
|
||
|
|
TEMPLATE
|
||
|
|
d qual(.gqual,"Global qualifier","syntab("""_verb_""")")
|
||
|
|
f q:ntoktype="TKEOL" d getqual
|
||
|
|
d @gqual^GDETEMPL
|
||
|
|
q
|
||
|
|
DELETE
|
||
|
|
d qual(.gqual,"Global qualifier","syntab("""_verb_""")"),@gqual,matchtok("TKEOL","End of line"),@gqual^GDEDELET
|
||
|
|
q
|
||
|
|
LOCKS
|
||
|
|
d qual(.gqual,"Global qualifier","syntab("""_verb_""")"),matchtok("TKEOL","End of line"),LOCKS^GDELOCKS
|
||
|
|
q
|
||
|
|
LOG
|
||
|
|
i ntoktype="TKEOL" d INQUIRE^GDELOG q
|
||
|
|
d qual(.gqual,"Global qualifier","syntab("""_verb_""")"),matchtok("TKEOL","End of line"),LOG^GDELOG
|
||
|
|
q
|
||
|
|
SHOW
|
||
|
|
i ntoktype="TKEOL" d ALL^GDESHOW q
|
||
|
|
d qual(.gqual,"Global qualifier","syntab("""_verb_""")") s t="NAMEREGIONSEGMENT"[gqual
|
||
|
|
i t,ntoktype="TKEOL" d @("ALL"_$e(gqual,1,5))^GDESHOW q
|
||
|
|
n mapreg
|
||
|
|
i gqual="MAP",ntoktype'="TKEOL" d getqual s mapreg=$g(lquals("REGION"))
|
||
|
|
i 't,"COMMANDS"=gqual,ntoktype'="TKEOL" d getqual s cfile=$g(lquals("FILE"))
|
||
|
|
d @gqual:t,matchtok("TKEOL","End of line"),@gqual^GDESHOW
|
||
|
|
q
|
||
|
|
VERIFY
|
||
|
|
i ntoktype="TKEOL" s x=$$ALL^GDEVERIF q
|
||
|
|
d qual(.gqual,"Global qualifier","syntab("""_verb_""")")
|
||
|
|
i "ALL|MAP"[gqual s x=$$ALL^GDEVERIF q
|
||
|
|
n verified s verified=1
|
||
|
|
i ntoktype="TKEOL" d @("ALL"_$e(gqual,1,3))^GDEVERIF i 1
|
||
|
|
e i "NAMEREGIONSEGMENT"[gqual d @gqual,@gqual^GDEVERIF i 1
|
||
|
|
e zm gdeerr("NOVALUE"):gqual
|
||
|
|
i $d(verified) zm gdeerr("VERIFY"):$s(verified:"OK",1:"FAILED") w !
|
||
|
|
q
|
||
|
|
EXIT
|
||
|
|
QUIT
|
||
|
|
d matchtok("TKEOL","End of line")
|
||
|
|
d ^@("GDE"_$tr(verb,lower,upper))
|
||
|
|
q
|
||
|
|
SETGD f d q:ntoktype="TKEOL"
|
||
|
|
. d qual(.gqual,"Global qualifier","syntab("""_verb_""")") s:gqual="FILE" tfile=gqual("value") s:gqual="QUIT" update=0
|
||
|
|
d GDESETGD^GDESETGD
|
||
|
|
q
|
||
|
|
HELP
|
||
|
|
SPAWN
|
||
|
|
d ^@("GDE"_$tr(verb,lower,upper))
|
||
|
|
q
|