source: WorldVistAEHR/trunk/r/XML_PARSER-MXML/MXMLPRS0.m@ 1195

Last change on this file since 1195 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 8.1 KB
RevLine 
[613]1MXMLPRS0 ;SAIC/DKM - XML Parser ;03/09/2005 12:57
2 ;;7.3;TOOLKIT;**58,89**;Apr 25, 1995
3 ;=================================================================
4 ; State 0: Prolog
50 N ATTR
6 S ST=1
7 D WS()
8 I '$$NEXT("<?xml") D ERROR(31) Q
9 D WS(1),ATTRIBS("?xml",.ATTR),WS()
10 I $$NEXT("?>",3)
11 D:$G(ATTR("version"))'="1.0" ERROR(10,$G(ATTR("version")))
12 Q
13 ; State 1: Document type declaration
141 N PUB,SYS
15 D WS()
16 Q:$$COMMENT
17 S ST=2
18 I '$$NEXT("<!DOCTYPE") D ERROR(32) Q
19 D WS(1)
20 S LVL(0)=$$NAME(2),DTD=""
21 D WS(),SYSPUB(.SYS,.PUB)
22 I OPTION["V",$L(SYS)!$L(PUB) D
23 .S DTD=$$EXTRNL(SYS,PUB)
24 D WS(),CBK("DOCTYPE",LVL(0),PUB,SYS)
25 I $$NEXT("[") S ST=5
26 E S:$$NEXT(">",3) ST=6
27 Q
28 ; State 2: Non-markup text
292 N TXT,CHR
30 D:'LVL WS()
31 S TXT=""
32 F S CHR=$E(XML,CPOS) Q:"<"[CHR!EOD D
33 .I $$NEXT("&") S TXT=TXT_$$ENTITY
34 .E S TXT=TXT_CHR,CPOS=CPOS+1
35 S:CHR="<" ST=3
36 I $L(TXT) D
37 .I 'LVL D ERROR(6) Q
38 .I '$$ISCHILD(LVL(LVL),"#PCDATA",1) D:$L($TR(TXT,WS)) ERROR(27) Q
39 .D CBK("CHARACTERS",TXT)
40 Q
41 ; State 3: Markup text
423 N END,ENAME,ATTR
43 S ST=2
44 Q:$$COMMENT
45 Q:$$CDATA
46 Q:$$PI
47 Q:'$$NEXT("<",3)
48 S END=$$NEXT("/"),ENAME=$$NAME(2)
49 Q:'$L(ENAME)
50 I 'END D
51 .S:LVL LVL(LVL,"N")=$$ISCHILD(LVL(LVL),ENAME,LVL(LVL,"N"))
52 .D:'LVL(LVL,"N") ERROR(24,ENAME)
53 .D ATTRIBS(ENAME,.ATTR),CBK("STARTELEMENT",ENAME,.ATTR),WS()
54 .D READ ;*89 Check for more data
55 .S END=$$NEXT("/"),LVL=LVL+1
56 .M LVL(LVL)=ERR
57 .S LVL(LVL)=ENAME,LVL(LVL,"N")=1
58 .I LVL=1 D
59 ..I $D(LVL(0))#2,LVL(0)'=ENAME D ERROR(15,ENAME) Q
60 ..I '$D(LVL(-1)) S LVL(-1)=""
61 ..E D ERROR(45,ENAME)
62 I END D
63 .I LVL>0,$G(LVL(LVL))=ENAME D
64 ..D:'$$ISCHILD(ENAME,"*",LVL(LVL,"N")) ERROR(25)
65 ..D CBK("ENDELEMENT",ENAME)
66 ..K LVL(LVL)
67 ..S LVL=LVL-1
68 .E D ERROR(5,ENAME)
69 I $$NEXT(">",3)
70 Q
71 ; State 5: Internal or external DTD
725 N X,Y
73 D DOPARAM
74 Q:$$COMMENT
75 I CS,$$NEXT("]]>") S CS=CS-1 Q
76 I $$NEXT("]") D Q
77 .S ST=6
78 .D WS()
79 .I $$NEXT(">",3)
80 Q:'$$NEXT("<!",3)
81 S X=$S($$NEXT("["):"[",1:$$NAME(2))
82 Q:'$L(X)
83 I $G(DTD(X)) S ST=$$WS(X'="["),ST=DTD(X)
84 E D ERROR(16,X)
85 Q
86 ; State 6: Check for external DTD
876 S ST=2
88 Q:OPTION'["V"
89 I $G(DTD)'="" D Q
90 .D OPNDOC(DTD,,"]>"),0
91 .S ST=5,DTD=""
92 D:CS ERROR(42)
93 Q
94 ; State 8: End of DTD declaration
958 D WS()
96 I $$NEXT(">",3)
97 S ST=5
98 Q
99 ; State 20: DTD ENTITY declaration
10020 N SYS,PUB,ENAME,TYP,DUP,Z
101 I $$NEXT("%"),$$WS(1) S TYP=2
102 E S TYP=1
103 S ENAME=$$NAME(2)
104 Q:'$L(ENAME)
105 S ST=8,ENAME=$S(TYP=2:"%",1:"")_ENAME,DUP=$D(^TMP(ID,$J,"ENT",ENAME))
106 D NOFWD("UNP",ENAME),ERROR(18,ENAME):DUP,WS(1)
107 I $$SYSPUB(.SYS,.PUB) D
108 .D WS()
109 .I TYP=1,$$NEXT("NDATA") D
110 ..D WS(1)
111 ..S Z=$$NAME(2)
112 ..Q:'$L(Z)
113 ..D FWD("NOT",Z)
114 ..S:'DUP ^TMP(ID,$J,"ENT",ENAME)="",^TMP(ID,$J,"UNP",ENAME)=Z
115 .E D:'DUP
116 ..S Z=$$EXTRNL(SYS,PUB)
117 ..S:$L(Z) ^TMP(ID,$J,"ENT",ENAME)=Z
118 E D
119 .S Z=$$VALUE(1,TYP)
120 .D:'DUP SETENT(ENAME,Z)
121 Q
122 ; State 30: DTD ELEMENT declaration
123 ; Builds a parse tree for child elements
12430 N STK,ELEMENT,CHILD,START,END,MIXED,X,Z
125 D DOPARAM
126 S ELEMENT=$$NAME(2),ST=8
127 Q:'$L(ELEMENT)
128 Q:'$$WS(1)
129 I $D(^TMP(ID,$J,"ELE",ELEMENT)) D ERROR(20,ELEMENT) Q
130 D NOFWD("ELE",ELEMENT)
131 S Z=$S($$NEXT("EMPTY"):1,$$NEXT("ANY"):2,1:0),^TMP(ID,$J,"ELE",ELEMENT)=Z
132 Q:Z
133 S STK=0,MIXED=0,START=1,END=2
134 ; Check for opening parenthesis
135LPAREN D DOPARAM
136 I MIXED<2 D
137 .F D WS() Q:'$$NEXT("(",$S(STK:0,1:3)) S STK(STK)=START,STK=STK+1
138 ; Element name, parameter entity, or #PCDATA
139 D DOPARAM
140 I 'MIXED,$$NEXT("#PCDATA") S CHILD="#PCDATA",MIXED=2
141 E S CHILD=$$NAME(2),MIXED=$S('MIXED:1,MIXED=2:3,1:MIXED) Q:'$L(CHILD) D FWD("ELE",CHILD)
142 I $D(STK(-1,CHILD)) D ERROR(23,CHILD) Q
143 S STK(-1,CHILD)="",^TMP(ID,$J,"ELE",ELEMENT,START,CHILD)=END
144 S:CHILD="#PCDATA" ^(END)=""
145 G:MIXED>1 SEQOPR
146 ; Check for repetition modifier
147REPMOD S X=$S($$NEXT("*",$S(MIXED=3:3,1:0)):2,MIXED>1:0,$$NEXT("+"):1,$$NEXT("?"):3,1:0)
148 S:X=1 ^TMP(ID,$J,"ELE",ELEMENT,END,START)=""
149 S:X=2 ^TMP(ID,$J,"ELE",ELEMENT,END,START)="",^TMP(ID,$J,"ELE",ELEMENT,START,END)=""
150 S:X=3 ^TMP(ID,$J,"ELE",ELEMENT,START,END)=""
151 ; Check for sequence operator
152SEQOPR D WS()
153 S X=$S($$NEXT("|"):2,MIXED=2:0,$$NEXT(","):1,1:0)
154 I X D G LPAREN
155 .S:'$D(STK(STK,0)) STK(STK,0)=X
156 .D:STK(STK,0)'=X ERROR(22,$E(",|",X))
157 .S:X=1 START=END,END=END+1
158 D WS()
159 I '$$NEXT(")",$S(STK:3,1:0)) D Q
160 .S ^TMP(ID,$J,"ELE",ELEMENT,END,"*")=-1
161 I 'STK D ERROR(21) Q
162 K STK(STK)
163 S STK=STK-1,START=STK(STK)
164 G REPMOD
165 ; State 40: DTD ATTLIST declaration
16640 N ELEMENT,ATTRIB,TYPE,DFLT,DUP,X,Y
167 D DOPARAM
168 S ELEMENT=$$NAME(2)
169 Q:'$L(ELEMENT)
170 Q:'$$WS(1)
171 D FWD("ELE",ELEMENT)
172 ; Attribute name
173ATTNAME D DOPARAM
174 S ATTRIB=$$NAME(2)
175 Q:'$L(ATTRIB)
176 S DUP=$D(^TMP(ID,$J,"ATT",ELEMENT,ATTRIB))
177 D ERROR(4,ATTRIB):DUP,WS(1)
178 ; Attribute type
179 S TYPE=$$FNDTKN("TYP")
180 I 'TYPE D ERROR(33) Q
181 S:'DUP ^TMP(ID,$J,"ATT",ELEMENT,ATTRIB)=TYPE
182 D WS(TYPE'=1),NOTN:TYPE=8,ENUM:TYPE=1,WS()
183 ; Default modifier
184 S DFLT=$$FNDTKN("MOD")
185 S:'DUP $P(^TMP(ID,$J,"ATT",ELEMENT,ATTRIB),"^",2)=DFLT,Y=$G(^("#ID"))
186 I TYPE=5 D ; If ID type
187 .D:DFLT=3 ERROR(34)
188 .I '$L(Y) S:'DUP ^TMP(ID,$J,"ATT",ELEMENT,"#ID")=ATTRIB
189 .E D ERROR(35,Y)
190 ; Default value
191 I DFLT=3!'DFLT D
192 .D:DFLT WS(1)
193 .S X=$$VALUE(1)
194 .Q:DUP
195 .S $P(^TMP(ID,$J,"ATT",ELEMENT,ATTRIB),"^",3)=X
196 .D CHKVAL(ELEMENT,ATTRIB,X)
197 ; Next attribute or end of declaration
198 D WS()
199 G:'$$NEXT(">") ATTNAME
200 S ST=5
201 Q
202 ; Search for a token of the specified group
203 ; GRP=Group id
204 ; Returns token id within group or 0 if none found
205FNDTKN(GRP) ;
206 N TKN
207 S TKN=""
208 F S TKN=$O(^TMP(ID,$J,GRP,TKN),-1) Q:$$NEXT(TKN)
209 Q $S($L(TKN):^TMP(ID,$J,GRP,TKN),1:0)
210 ; Enumerated attribute type
211ENUM F D WS() S X=$$NAMETKN(3) Q:'$L(X) D Q:'$$NEXT("|")
212 .D:TYPE=8 FWD("NOT",X)
213 .S ^TMP(ID,$J,"ATT",ELEMENT,ATTRIB,X)=""
214 .D WS()
215 I $$NEXT(")",3)
216 Q
217 ; NOTATION attribute type
218NOTN D ENUM:$$NEXT("(",3)
219 Q
220 ; State 50: DTD NOTATION declaration
22150 N NAME,SYS,PUB,DUP
222 S NAME=$$NAME(3),ST=8
223 Q:'$L(NAME)
224 Q:'$$WS(1)
225 S DUP=$D(^TMP(ID,$J,"NOT",NAME))
226 D NOFWD("NOT",NAME),ERROR(48,NAME):DUP
227 I '$$SYSPUB(.SYS,.PUB,1) D ERROR(39) Q
228 Q:DUP
229 S ^TMP(ID,$J,"NOT",NAME,1)=SYS,^(2)=PUB
230 D CBK("NOTATION",NAME,SYS,PUB)
231 Q
232 ; State 60: Conditional sections
23360 N CSTYPE,CSCNT,DLM
234 D DOPARAM
235 S CSTYPE=$S($$NEXT("INCLUDE"):1,$$NEXT("IGNORE"):2,1:0),ST=5
236 I 'CSTYPE D ERROR(41) Q
237 I DOCSTK=1 D ERROR(44) Q
238 D WS()
239 Q:'$$NEXT("[",3)
240 I CSTYPE=1 S CS=CS+1 Q
241 S CSCNT=1,DLM=""
242 F D Q:'CSCNT!EOD
243 .I $L(DLM),$$NEXT(DLM) S DLM=""
244 .E I $L(DLM) S CPOS=CPOS+1
245 .E I $$NEXT(QT) S DLM=QT
246 .E I $$NEXT("'") S DLM="'"
247 .E I $$NEXT("<![") S CSCNT=CSCNT+1
248 .E I $$NEXT("]]>") S CSCNT=CSCNT-1
249 .E S CPOS=CPOS+1
250 .D:CPOS>LLEN READ
251 D:CSCNT ERROR(42)
252 Q
253 ;Local Functions moved from MXMLPRSE
254 ; Execute event callback (if defined)
255 ; EVT=Event name
256 ; Pn=Parameters
257CBK(EVT,P1,P2,P3,P4) ;
258 Q:EOD<0
259 N EN,PNUM
260 S EN=$G(CBK(EVT))
261 Q:EN=""
262 S PNUM=^TMP(ID,$J,"CBK",EVT)
263 D @(EN_$P("(.P1,.P2,.P3,.P4",",",1,PNUM)_$S('PNUM:"",1:")"))
264 Q
265 ; Save current document location for error reporting
266 ; See EPOS^MXMLPRSE
267EPOS S ERR("XML")=XML,ERR("POS")=CPOS,ERR("LIN")=LPOS
268 Q
269 ; Check next characters
270 ; SEQ=character sequence
271 ; ERN=Error to signal if not found (optional)
272NEXT(SEQ,ERN) ;
273 I SEQ=$E(XML,CPOS,CPOS+$L(SEQ)-1) S CPOS=CPOS+$L(SEQ) Q 1
274 D:$G(ERN) EPOS^MXMLPRSE,ERROR(ERN,SEQ)
275 Q 0
276 ; Skip whitespace
277 ; ERN=Error to signal if not found (optional)
278 ; Optional return value =1 if whitespace found, 0 if not.
279WS(ERN) N CHR,FND
280 D EPOS^MXMLPRSE
281 S FND=0
282 F D:CPOS>LLEN READ S CHR=$E(XML,CPOS) Q:WS'[CHR!EOD D
283 .S ERN=0,CPOS=CPOS+1,FND=1
284 D:$G(ERN) ERROR(ERN)
285 Q:$Q FND
286 Q
287 ; Shortcuts to functions/procedures defined elsewhere
288ATTRIBS(X,Y) D ATTRIBS^MXMLPRSE(.X,.Y) Q
289CDATA() Q $$CDATA^MXMLPRSE
290CHKVAL(X,Y,Z) D CHKVAL^MXMLPRS1(.X,.Y,.Z) Q
291COMMENT() Q $$COMMENT^MXMLPRSE
292DOPARAM G DOPARAM^MXMLPRSE
293ENTITY(X) Q $$ENTITY^MXMLPRSE(.X)
294ERROR(X,Y) D ERROR^MXMLPRSE(.X,.Y) Q
295EXTRNL(X,Y,Z) Q $$EXTRNL^MXMLPRSE(.X,.Y,.Z)
296FWD(X,Y) D FWD^MXMLPRS1(.X,.Y) Q
297ISCHILD(X,Y,Z) Q $$ISCHILD^MXMLPRS1(.X,.Y,.Z)
298NAME(X) Q $$NAME^MXMLPRSE(.X)
299NAMETKN(X) Q $$NAMETKN^MXMLPRSE(.X)
300NOFWD(X,Y) D NOFWD^MXMLPRS1(.X,.Y) Q
301OPNDOC(X,Y,Z) D OPNDOC^MXMLPRSE(.X,.Y,.Z) Q
302PI() Q $$PI^MXMLPRSE
303SETENT(X,Y) D SETENT^MXMLPRSE(.X,.Y) Q
304SYSPUB(X,Y,Z) Q:$Q $$SYSPUB^MXMLPRSE(.X,.Y,.Z)
305 D SYSPUB^MXMLPRSE(.X,.Y) Q
306READ G READ^MXMLPRSE
307VALUE(X,Y) Q $$VALUE^MXMLPRSE(.X,.Y)
Note: See TracBrowser for help on using the repository browser.