- MXMLPRS0 ;SAIC/DKM - XML Parser ;03/09/2005 12:57
- ;;7.3;TOOLKIT;**58,89,136**;Apr 25, 1995;Build 5
- ;Per VHA Directive 6402, this routine should not be modified
- ;=================================================================
- ; State 0: Prolog
- 0 N ATTR
- S ST=1
- D WS()
- I '$$NEXT("<?xml") D ERROR(31) Q
- D WS(1),ATTRIBS("?xml",.ATTR),WS()
- I $$NEXT("?>",3)
- D:$G(ATTR("version"))'="1.0" ERROR(10,$G(ATTR("version")))
- Q
- ; State 1: Document type declaration
- 1 N PUB,SYS
- D WS()
- Q:$$COMMENT
- S ST=2
- I '$$NEXT("<!DOCTYPE") D ERROR(32) Q
- D WS(1)
- S LVL(0)=$$NAME(2),DTD=""
- D WS(),SYSPUB(.SYS,.PUB)
- I OPTION["V",$L(SYS)!$L(PUB) D
- .S DTD=$$EXTRNL(SYS,PUB)
- D WS(),CBK("DOCTYPE",LVL(0),PUB,SYS)
- I $$NEXT("[") S ST=5
- E S:$$NEXT(">",3) ST=6
- Q
- ; State 2: Non-markup text
- 2 N TXT,CHR
- D:'LVL WS()
- S TXT=""
- F S CHR=$E(XML,CPOS) Q:"<"[CHR!EOD D
- .I $$NEXT("&") S TXT=TXT_$$ENTITY
- .E S TXT=TXT_CHR,CPOS=CPOS+1
- .D:(LLEN-CPOS)<50 READ ;P136
- S:CHR="<" ST=3
- I $L(TXT) D
- .I 'LVL D ERROR(6) Q
- .I '$$ISCHILD(LVL(LVL),"#PCDATA",1) D:$L($TR(TXT,WS)) ERROR(27) Q
- .D CBK("CHARACTERS",TXT)
- Q
- ; State 3: Markup text
- 3 N END,ENAME,ATTR
- S ST=2
- Q:$$COMMENT
- Q:$$CDATA
- Q:$$PI
- Q:'$$NEXT("<",3)
- S END=$$NEXT("/"),ENAME=$$NAME(2)
- Q:'$L(ENAME)
- I 'END D
- .S:LVL LVL(LVL,"N")=$$ISCHILD(LVL(LVL),ENAME,LVL(LVL,"N"))
- .D:'LVL(LVL,"N") ERROR(24,ENAME)
- .D ATTRIBS(ENAME,.ATTR),CBK("STARTELEMENT",ENAME,.ATTR),WS()
- .D READ ;*89 Check for more data
- .S END=$$NEXT("/"),LVL=LVL+1
- .M LVL(LVL)=ERR
- .S LVL(LVL)=ENAME,LVL(LVL,"N")=1
- .I LVL=1 D
- ..I $D(LVL(0))#2,LVL(0)'=ENAME D ERROR(15,ENAME) Q
- ..I '$D(LVL(-1)) S LVL(-1)=""
- ..E D ERROR(45,ENAME)
- I END D
- .I LVL>0,$G(LVL(LVL))=ENAME D
- ..D:'$$ISCHILD(ENAME,"*",LVL(LVL,"N")) ERROR(25)
- ..D CBK("ENDELEMENT",ENAME)
- ..K LVL(LVL)
- ..S LVL=LVL-1
- .E D ERROR(5,ENAME)
- I $$NEXT(">",3)
- Q
- ; State 5: Internal or external DTD
- 5 N X,Y
- D DOPARAM
- Q:$$COMMENT
- I CS,$$NEXT("]]>") S CS=CS-1 Q
- I $$NEXT("]") D Q
- .S ST=6
- .D WS()
- .I $$NEXT(">",3)
- Q:'$$NEXT("<!",3)
- S X=$S($$NEXT("["):"[",1:$$NAME(2))
- Q:'$L(X)
- I $G(DTD(X)) S ST=$$WS(X'="["),ST=DTD(X)
- E D ERROR(16,X)
- Q
- ; State 6: Check for external DTD
- 6 S ST=2
- Q:OPTION'["V"
- I $G(DTD)'="" D Q
- .D OPNDOC(DTD,,"]>"),0
- .S ST=5,DTD=""
- D:CS ERROR(42)
- Q
- ; State 8: End of DTD declaration
- 8 D WS()
- I $$NEXT(">",3)
- S ST=5
- Q
- ; State 20: DTD ENTITY declaration
- 20 N SYS,PUB,ENAME,TYP,DUP,Z
- I $$NEXT("%"),$$WS(1) S TYP=2
- E S TYP=1
- S ENAME=$$NAME(2)
- Q:'$L(ENAME)
- S ST=8,ENAME=$S(TYP=2:"%",1:"")_ENAME,DUP=$D(^TMP(ID,$J,"ENT",ENAME))
- D NOFWD("UNP",ENAME),ERROR(18,ENAME):DUP,WS(1)
- I $$SYSPUB(.SYS,.PUB) D
- .D WS()
- .I TYP=1,$$NEXT("NDATA") D
- ..D WS(1)
- ..S Z=$$NAME(2)
- ..Q:'$L(Z)
- ..D FWD("NOT",Z)
- ..S:'DUP ^TMP(ID,$J,"ENT",ENAME)="",^TMP(ID,$J,"UNP",ENAME)=Z
- .E D:'DUP
- ..S Z=$$EXTRNL(SYS,PUB)
- ..S:$L(Z) ^TMP(ID,$J,"ENT",ENAME)=Z
- E D
- .S Z=$$VALUE(1,TYP)
- .D:'DUP SETENT(ENAME,Z)
- Q
- ; State 30: DTD ELEMENT declaration
- ; Builds a parse tree for child elements
- 30 N STK,ELEMENT,CHILD,START,END,MIXED,X,Z
- D DOPARAM
- S ELEMENT=$$NAME(2),ST=8
- Q:'$L(ELEMENT)
- Q:'$$WS(1)
- I $D(^TMP(ID,$J,"ELE",ELEMENT)) D ERROR(20,ELEMENT) Q
- D NOFWD("ELE",ELEMENT)
- S Z=$S($$NEXT("EMPTY"):1,$$NEXT("ANY"):2,1:0),^TMP(ID,$J,"ELE",ELEMENT)=Z
- Q:Z
- S STK=0,MIXED=0,START=1,END=2
- ; Check for opening parenthesis
- LPAREN D DOPARAM
- I MIXED<2 D
- .F D WS() Q:'$$NEXT("(",$S(STK:0,1:3)) S STK(STK)=START,STK=STK+1
- ; Element name, parameter entity, or #PCDATA
- D DOPARAM
- I 'MIXED,$$NEXT("#PCDATA") S CHILD="#PCDATA",MIXED=2
- E S CHILD=$$NAME(2),MIXED=$S('MIXED:1,MIXED=2:3,1:MIXED) Q:'$L(CHILD) D FWD("ELE",CHILD)
- I $D(STK(-1,CHILD)) D ERROR(23,CHILD) Q
- S STK(-1,CHILD)="",^TMP(ID,$J,"ELE",ELEMENT,START,CHILD)=END
- S:CHILD="#PCDATA" ^(END)=""
- G:MIXED>1 SEQOPR
- ; Check for repetition modifier
- REPMOD S X=$S($$NEXT("*",$S(MIXED=3:3,1:0)):2,MIXED>1:0,$$NEXT("+"):1,$$NEXT("?"):3,1:0)
- S:X=1 ^TMP(ID,$J,"ELE",ELEMENT,END,START)=""
- S:X=2 ^TMP(ID,$J,"ELE",ELEMENT,END,START)="",^TMP(ID,$J,"ELE",ELEMENT,START,END)=""
- S:X=3 ^TMP(ID,$J,"ELE",ELEMENT,START,END)=""
- ; Check for sequence operator
- SEQOPR D WS()
- S X=$S($$NEXT("|"):2,MIXED=2:0,$$NEXT(","):1,1:0)
- I X D G LPAREN
- .S:'$D(STK(STK,0)) STK(STK,0)=X
- .D:STK(STK,0)'=X ERROR(22,$E(",|",X))
- .S:X=1 START=END,END=END+1
- D WS()
- I '$$NEXT(")",$S(STK:3,1:0)) D Q
- .S ^TMP(ID,$J,"ELE",ELEMENT,END,"*")=-1
- I 'STK D ERROR(21) Q
- K STK(STK)
- S STK=STK-1,START=STK(STK)
- G REPMOD
- ; State 40: DTD ATTLIST declaration
- 40 N ELEMENT,ATTRIB,TYPE,DFLT,DUP,X,Y
- D DOPARAM
- S ELEMENT=$$NAME(2)
- Q:'$L(ELEMENT)
- Q:'$$WS(1)
- D FWD("ELE",ELEMENT)
- ; Attribute name
- ATTNAME D DOPARAM
- S ATTRIB=$$NAME(2)
- Q:'$L(ATTRIB)
- S DUP=$D(^TMP(ID,$J,"ATT",ELEMENT,ATTRIB))
- D ERROR(4,ATTRIB):DUP,WS(1)
- ; Attribute type
- S TYPE=$$FNDTKN("TYP")
- I 'TYPE D ERROR(33) Q
- S:'DUP ^TMP(ID,$J,"ATT",ELEMENT,ATTRIB)=TYPE
- D WS(TYPE'=1),NOTN:TYPE=8,ENUM:TYPE=1,WS()
- ; Default modifier
- S DFLT=$$FNDTKN("MOD")
- S:'DUP $P(^TMP(ID,$J,"ATT",ELEMENT,ATTRIB),"^",2)=DFLT,Y=$G(^("#ID"))
- I TYPE=5 D ; If ID type
- .D:DFLT=3 ERROR(34)
- .I '$L(Y) S:'DUP ^TMP(ID,$J,"ATT",ELEMENT,"#ID")=ATTRIB
- .E D ERROR(35,Y)
- ; Default value
- I DFLT=3!'DFLT D
- .D:DFLT WS(1)
- .S X=$$VALUE(1)
- .Q:DUP
- .S $P(^TMP(ID,$J,"ATT",ELEMENT,ATTRIB),"^",3)=X
- .D CHKVAL(ELEMENT,ATTRIB,X)
- ; Next attribute or end of declaration
- D WS()
- G:'$$NEXT(">") ATTNAME
- S ST=5
- Q
- ; Search for a token of the specified group
- ; GRP=Group id
- ; Returns token id within group or 0 if none found
- FNDTKN(GRP) ;
- N TKN
- S TKN=""
- F S TKN=$O(^TMP(ID,$J,GRP,TKN),-1) Q:$$NEXT(TKN)
- Q $S($L(TKN):^TMP(ID,$J,GRP,TKN),1:0)
- ; Enumerated attribute type
- ENUM F D WS() S X=$$NAMETKN(3) Q:'$L(X) D Q:'$$NEXT("|")
- .D:TYPE=8 FWD("NOT",X)
- .S ^TMP(ID,$J,"ATT",ELEMENT,ATTRIB,X)=""
- .D WS()
- I $$NEXT(")",3)
- Q
- ; NOTATION attribute type
- NOTN D ENUM:$$NEXT("(",3)
- Q
- ; State 50: DTD NOTATION declaration
- 50 N NAME,SYS,PUB,DUP
- S NAME=$$NAME(3),ST=8
- Q:'$L(NAME)
- Q:'$$WS(1)
- S DUP=$D(^TMP(ID,$J,"NOT",NAME))
- D NOFWD("NOT",NAME),ERROR(48,NAME):DUP
- I '$$SYSPUB(.SYS,.PUB,1) D ERROR(39) Q
- Q:DUP
- S ^TMP(ID,$J,"NOT",NAME,1)=SYS,^(2)=PUB
- D CBK("NOTATION",NAME,SYS,PUB)
- Q
- ; State 60: Conditional sections
- 60 N CSTYPE,CSCNT,DLM
- D DOPARAM
- S CSTYPE=$S($$NEXT("INCLUDE"):1,$$NEXT("IGNORE"):2,1:0),ST=5
- I 'CSTYPE D ERROR(41) Q
- I DOCSTK=1 D ERROR(44) Q
- D WS()
- Q:'$$NEXT("[",3)
- I CSTYPE=1 S CS=CS+1 Q
- S CSCNT=1,DLM=""
- F D Q:'CSCNT!EOD
- .I $L(DLM),$$NEXT(DLM) S DLM=""
- .E I $L(DLM) S CPOS=CPOS+1
- .E I $$NEXT(QT) S DLM=QT
- .E I $$NEXT("'") S DLM="'"
- .E I $$NEXT("<![") S CSCNT=CSCNT+1
- .E I $$NEXT("]]>") S CSCNT=CSCNT-1
- .E S CPOS=CPOS+1
- .D:CPOS>LLEN READ
- D:CSCNT ERROR(42)
- Q
- ;Local Functions moved from MXMLPRSE
- ; Execute event callback (if defined)
- ; EVT=Event name
- ; Pn=Parameters
- CBK(EVT,P1,P2,P3,P4) ;
- Q:EOD<0
- N EN,PNUM
- S EN=$G(CBK(EVT))
- Q:EN=""
- S PNUM=^TMP(ID,$J,"CBK",EVT)
- D @(EN_$P("(.P1,.P2,.P3,.P4",",",1,PNUM)_$S('PNUM:"",1:")"))
- Q
- ; Save current document location for error reporting
- ; See EPOS^MXMLPRSE
- EPOS S ERR("XML")=XML,ERR("POS")=CPOS,ERR("LIN")=LPOS
- Q
- ; Check next characters
- ; SEQ=character sequence
- ; ERN=Error to signal if not found (optional)
- NEXT(SEQ,ERN) ;
- I SEQ=$E(XML,CPOS,CPOS+$L(SEQ)-1) S CPOS=CPOS+$L(SEQ) Q 1
- D:$G(ERN) EPOS^MXMLPRSE,ERROR(ERN,SEQ)
- Q 0
- ; Skip whitespace
- ; ERN=Error to signal if not found (optional)
- ; Optional return value =1 if whitespace found, 0 if not.
- WS(ERN) N CHR,FND
- D EPOS^MXMLPRSE
- S FND=0
- F D:CPOS>LLEN READ S CHR=$E(XML,CPOS) Q:WS'[CHR!EOD D
- .S ERN=0,CPOS=CPOS+1,FND=1
- D:$G(ERN) ERROR(ERN)
- Q:$Q FND
- Q
- ; Shortcuts to functions/procedures defined elsewhere
- ATTRIBS(X,Y) D ATTRIBS^MXMLPRSE(.X,.Y) Q
- CDATA() Q $$CDATA^MXMLPRSE
- CHKVAL(X,Y,Z) D CHKVAL^MXMLPRS1(.X,.Y,.Z) Q
- DOPARAM G DOPARAM^MXMLPRSE
- ENTITY(X) Q $$ENTITY^MXMLPRSE(.X)
- ERROR(X,Y) D ERROR^MXMLPRSE(.X,.Y) Q
- EXTRNL(X,Y,Z) Q $$EXTRNL^MXMLPRSE(.X,.Y,.Z)
- FWD(X,Y) D FWD^MXMLPRS1(.X,.Y) Q
- ISCHILD(X,Y,Z) Q $$ISCHILD^MXMLPRS1(.X,.Y,.Z)
- NAME(X) Q $$NAME^MXMLPRSE(.X)
- NAMETKN(X) Q $$NAMETKN^MXMLPRSE(.X)
- NOFWD(X,Y) D NOFWD^MXMLPRS1(.X,.Y) Q
- OPNDOC(X,Y,Z) D OPNDOC^MXMLPRSE(.X,.Y,.Z) Q
- PI() Q $$PI^MXMLPRSE
- SETENT(X,Y) D SETENT^MXMLPRSE(.X,.Y) Q
- SYSPUB(X,Y,Z) Q:$Q $$SYSPUB^MXMLPRSE(.X,.Y,.Z)
- D SYSPUB^MXMLPRSE(.X,.Y) Q
- READ G READ^MXMLPRSE
- VALUE(X,Y) Q $$VALUE^MXMLPRSE(.X,.Y)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMXMLPRS0 8707 printed Feb 18, 2025@23:36:42 Page 2
- MXMLPRS0 ;SAIC/DKM - XML Parser ;03/09/2005 12:57
- +1 ;;7.3;TOOLKIT;**58,89,136**;Apr 25, 1995;Build 5
- +2 ;Per VHA Directive 6402, this routine should not be modified
- +3 ;=================================================================
- +4 ; State 0: Prolog
- 0 NEW ATTR
- +1 SET ST=1
- +2 DO WS()
- +3 IF '$$NEXT("<?xml")
- DO ERROR(31)
- QUIT
- +4 DO WS(1)
- DO ATTRIBS("?xml",.ATTR)
- DO WS()
- +5 IF $$NEXT("?>",3)
- +6 if $GET(ATTR("version"))'="1.0"
- DO ERROR(10,$GET(ATTR("version")))
- +7 QUIT
- +8 ; State 1: Document type declaration
- 1 NEW PUB,SYS
- +1 DO WS()
- +2 if $$COMMENT
- QUIT
- +3 SET ST=2
- +4 IF '$$NEXT("<!DOCTYPE")
- DO ERROR(32)
- QUIT
- +5 DO WS(1)
- +6 SET LVL(0)=$$NAME(2)
- SET DTD=""
- +7 DO WS()
- DO SYSPUB(.SYS,.PUB)
- +8 IF OPTION["V"
- IF $LENGTH(SYS)!$LENGTH(PUB)
- Begin DoDot:1
- +9 SET DTD=$$EXTRNL(SYS,PUB)
- End DoDot:1
- +10 DO WS()
- DO CBK("DOCTYPE",LVL(0),PUB,SYS)
- +11 IF $$NEXT("[")
- SET ST=5
- +12 IF '$TEST
- if $$NEXT(">",3)
- SET ST=6
- +13 QUIT
- +14 ; State 2: Non-markup text
- 2 NEW TXT,CHR
- +1 if 'LVL
- DO WS()
- +2 SET TXT=""
- +3 FOR
- SET CHR=$EXTRACT(XML,CPOS)
- if "<"[CHR!EOD
- QUIT
- Begin DoDot:1
- +4 IF $$NEXT("&")
- SET TXT=TXT_$$ENTITY
- +5 IF '$TEST
- SET TXT=TXT_CHR
- SET CPOS=CPOS+1
- +6 ;P136
- if (LLEN-CPOS)<50
- DO READ
- End DoDot:1
- +7 if CHR="<"
- SET ST=3
- +8 IF $LENGTH(TXT)
- Begin DoDot:1
- +9 IF 'LVL
- DO ERROR(6)
- QUIT
- +10 IF '$$ISCHILD(LVL(LVL),"#PCDATA",1)
- if $LENGTH($TRANSLATE(TXT,WS))
- DO ERROR(27)
- QUIT
- +11 DO CBK("CHARACTERS",TXT)
- End DoDot:1
- +12 QUIT
- +13 ; State 3: Markup text
- 3 NEW END,ENAME,ATTR
- +1 SET ST=2
- +2 if $$COMMENT
- QUIT
- +3 if $$CDATA
- QUIT
- +4 if $$PI
- QUIT
- +5 if '$$NEXT("<",3)
- QUIT
- +6 SET END=$$NEXT("/")
- SET ENAME=$$NAME(2)
- +7 if '$LENGTH(ENAME)
- QUIT
- +8 IF 'END
- Begin DoDot:1
- +9 if LVL
- SET LVL(LVL,"N")=$$ISCHILD(LVL(LVL),ENAME,LVL(LVL,"N"))
- +10 if 'LVL(LVL,"N")
- DO ERROR(24,ENAME)
- +11 DO ATTRIBS(ENAME,.ATTR)
- DO CBK("STARTELEMENT",ENAME,.ATTR)
- DO WS()
- +12 ;*89 Check for more data
- DO READ
- +13 SET END=$$NEXT("/")
- SET LVL=LVL+1
- +14 MERGE LVL(LVL)=ERR
- +15 SET LVL(LVL)=ENAME
- SET LVL(LVL,"N")=1
- +16 IF LVL=1
- Begin DoDot:2
- +17 IF $DATA(LVL(0))#2
- IF LVL(0)'=ENAME
- DO ERROR(15,ENAME)
- QUIT
- +18 IF '$DATA(LVL(-1))
- SET LVL(-1)=""
- +19 IF '$TEST
- DO ERROR(45,ENAME)
- End DoDot:2
- End DoDot:1
- +20 IF END
- Begin DoDot:1
- +21 IF LVL>0
- IF $GET(LVL(LVL))=ENAME
- Begin DoDot:2
- +22 if '$$ISCHILD(ENAME,"*",LVL(LVL,"N"))
- DO ERROR(25)
- +23 DO CBK("ENDELEMENT",ENAME)
- +24 KILL LVL(LVL)
- +25 SET LVL=LVL-1
- End DoDot:2
- +26 IF '$TEST
- DO ERROR(5,ENAME)
- End DoDot:1
- +27 IF $$NEXT(">",3)
- +28 QUIT
- +29 ; State 5: Internal or external DTD
- 5 NEW X,Y
- +1 DO DOPARAM
- +2 if $$COMMENT
- QUIT
- +3 IF CS
- IF $$NEXT("]]>")
- SET CS=CS-1
- QUIT
- +4 IF $$NEXT("]")
- Begin DoDot:1
- +5 SET ST=6
- +6 DO WS()
- +7 IF $$NEXT(">",3)
- End DoDot:1
- QUIT
- +8 if '$$NEXT("<!",3)
- QUIT
- +9 SET X=$SELECT($$NEXT("["):"[",1:$$NAME(2))
- +10 if '$LENGTH(X)
- QUIT
- +11 IF $GET(DTD(X))
- SET ST=$$WS(X'="[")
- SET ST=DTD(X)
- +12 IF '$TEST
- DO ERROR(16,X)
- +13 QUIT
- +14 ; State 6: Check for external DTD
- 6 SET ST=2
- +1 if OPTION'["V"
- QUIT
- +2 IF $GET(DTD)'=""
- Begin DoDot:1
- +3 DO OPNDOC(DTD,,"]>")
- DO 0
- +4 SET ST=5
- SET DTD=""
- End DoDot:1
- QUIT
- +5 if CS
- DO ERROR(42)
- +6 QUIT
- +7 ; State 8: End of DTD declaration
- 8 DO WS()
- +1 IF $$NEXT(">",3)
- +2 SET ST=5
- +3 QUIT
- +4 ; State 20: DTD ENTITY declaration
- 20 NEW SYS,PUB,ENAME,TYP,DUP,Z
- +1 IF $$NEXT("%")
- IF $$WS(1)
- SET TYP=2
- +2 IF '$TEST
- SET TYP=1
- +3 SET ENAME=$$NAME(2)
- +4 if '$LENGTH(ENAME)
- QUIT
- +5 SET ST=8
- SET ENAME=$SELECT(TYP=2:"%",1:"")_ENAME
- SET DUP=$DATA(^TMP(ID,$JOB,"ENT",ENAME))
- +6 DO NOFWD("UNP",ENAME)
- if DUP
- DO ERROR(18,ENAME)
- DO WS(1)
- +7 IF $$SYSPUB(.SYS,.PUB)
- Begin DoDot:1
- +8 DO WS()
- +9 IF TYP=1
- IF $$NEXT("NDATA")
- Begin DoDot:2
- +10 DO WS(1)
- +11 SET Z=$$NAME(2)
- +12 if '$LENGTH(Z)
- QUIT
- +13 DO FWD("NOT",Z)
- +14 if 'DUP
- SET ^TMP(ID,$JOB,"ENT",ENAME)=""
- SET ^TMP(ID,$JOB,"UNP",ENAME)=Z
- End DoDot:2
- +15 IF '$TEST
- if 'DUP
- Begin DoDot:2
- +16 SET Z=$$EXTRNL(SYS,PUB)
- +17 if $LENGTH(Z)
- SET ^TMP(ID,$JOB,"ENT",ENAME)=Z
- End DoDot:2
- End DoDot:1
- +18 IF '$TEST
- Begin DoDot:1
- +19 SET Z=$$VALUE(1,TYP)
- +20 if 'DUP
- DO SETENT(ENAME,Z)
- End DoDot:1
- +21 QUIT
- +22 ; State 30: DTD ELEMENT declaration
- +23 ; Builds a parse tree for child elements
- 30 NEW STK,ELEMENT,CHILD,START,END,MIXED,X,Z
- +1 DO DOPARAM
- +2 SET ELEMENT=$$NAME(2)
- SET ST=8
- +3 if '$LENGTH(ELEMENT)
- QUIT
- +4 if '$$WS(1)
- QUIT
- +5 IF $DATA(^TMP(ID,$JOB,"ELE",ELEMENT))
- DO ERROR(20,ELEMENT)
- QUIT
- +6 DO NOFWD("ELE",ELEMENT)
- +7 SET Z=$SELECT($$NEXT("EMPTY"):1,$$NEXT("ANY"):2,1:0)
- SET ^TMP(ID,$JOB,"ELE",ELEMENT)=Z
- +8 if Z
- QUIT
- +9 SET STK=0
- SET MIXED=0
- SET START=1
- SET END=2
- +10 ; Check for opening parenthesis
- LPAREN DO DOPARAM
- +1 IF MIXED<2
- Begin DoDot:1
- +2 FOR
- DO WS()
- if '$$NEXT("(",$SELECT(STK
- QUIT
- SET STK(STK)=START
- SET STK=STK+1
- End DoDot:1
- +3 ; Element name, parameter entity, or #PCDATA
- +4 DO DOPARAM
- +5 IF 'MIXED
- IF $$NEXT("#PCDATA")
- SET CHILD="#PCDATA"
- SET MIXED=2
- +6 IF '$TEST
- SET CHILD=$$NAME(2)
- SET MIXED=$SELECT('MIXED:1,MIXED=2:3,1:MIXED)
- if '$LENGTH(CHILD)
- QUIT
- DO FWD("ELE",CHILD)
- +7 IF $DATA(STK(-1,CHILD))
- DO ERROR(23,CHILD)
- QUIT
- +8 SET STK(-1,CHILD)=""
- SET ^TMP(ID,$JOB,"ELE",ELEMENT,START,CHILD)=END
- +9 if CHILD="#PCDATA"
- SET ^(END)=""
- +10 if MIXED>1
- GOTO SEQOPR
- +11 ; Check for repetition modifier
- REPMOD SET X=$SELECT($$NEXT("*",$SELECT(MIXED=3:3,1:0)):2,MIXED>1:0,$$NEXT("+"):1,$$NEXT("?"):3,1:0)
- +1 if X=1
- SET ^TMP(ID,$JOB,"ELE",ELEMENT,END,START)=""
- +2 if X=2
- SET ^TMP(ID,$JOB,"ELE",ELEMENT,END,START)=""
- SET ^TMP(ID,$JOB,"ELE",ELEMENT,START,END)=""
- +3 if X=3
- SET ^TMP(ID,$JOB,"ELE",ELEMENT,START,END)=""
- +4 ; Check for sequence operator
- SEQOPR DO WS()
- +1 SET X=$SELECT($$NEXT("|"):2,MIXED=2:0,$$NEXT(","):1,1:0)
- +2 IF X
- Begin DoDot:1
- +3 if '$DATA(STK(STK,0))
- SET STK(STK,0)=X
- +4 if STK(STK,0)'=X
- DO ERROR(22,$EXTRACT(",|",X))
- +5 if X=1
- SET START=END
- SET END=END+1
- End DoDot:1
- GOTO LPAREN
- +6 DO WS()
- +7 IF '$$NEXT(")",$SELECT(STK:3,1:0))
- Begin DoDot:1
- +8 SET ^TMP(ID,$JOB,"ELE",ELEMENT,END,"*")=-1
- End DoDot:1
- QUIT
- +9 IF 'STK
- DO ERROR(21)
- QUIT
- +10 KILL STK(STK)
- +11 SET STK=STK-1
- SET START=STK(STK)
- +12 GOTO REPMOD
- +13 ; State 40: DTD ATTLIST declaration
- 40 NEW ELEMENT,ATTRIB,TYPE,DFLT,DUP,X,Y
- +1 DO DOPARAM
- +2 SET ELEMENT=$$NAME(2)
- +3 if '$LENGTH(ELEMENT)
- QUIT
- +4 if '$$WS(1)
- QUIT
- +5 DO FWD("ELE",ELEMENT)
- +6 ; Attribute name
- ATTNAME DO DOPARAM
- +1 SET ATTRIB=$$NAME(2)
- +2 if '$LENGTH(ATTRIB)
- QUIT
- +3 SET DUP=$DATA(^TMP(ID,$JOB,"ATT",ELEMENT,ATTRIB))
- +4 if DUP
- DO ERROR(4,ATTRIB)
- DO WS(1)
- +5 ; Attribute type
- +6 SET TYPE=$$FNDTKN("TYP")
- +7 IF 'TYPE
- DO ERROR(33)
- QUIT
- +8 if 'DUP
- SET ^TMP(ID,$JOB,"ATT",ELEMENT,ATTRIB)=TYPE
- +9 DO WS(TYPE'=1)
- if TYPE=8
- DO NOTN
- if TYPE=1
- DO ENUM
- DO WS()
- +10 ; Default modifier
- +11 SET DFLT=$$FNDTKN("MOD")
- +12 if 'DUP
- SET $PIECE(^TMP(ID,$JOB,"ATT",ELEMENT,ATTRIB),"^",2)=DFLT
- SET Y=$GET(^("#ID"))
- +13 ; If ID type
- IF TYPE=5
- Begin DoDot:1
- +14 if DFLT=3
- DO ERROR(34)
- +15 IF '$LENGTH(Y)
- if 'DUP
- SET ^TMP(ID,$JOB,"ATT",ELEMENT,"#ID")=ATTRIB
- +16 IF '$TEST
- DO ERROR(35,Y)
- End DoDot:1
- +17 ; Default value
- +18 IF DFLT=3!'DFLT
- Begin DoDot:1
- +19 if DFLT
- DO WS(1)
- +20 SET X=$$VALUE(1)
- +21 if DUP
- QUIT
- +22 SET $PIECE(^TMP(ID,$JOB,"ATT",ELEMENT,ATTRIB),"^",3)=X
- +23 DO CHKVAL(ELEMENT,ATTRIB,X)
- End DoDot:1
- +24 ; Next attribute or end of declaration
- +25 DO WS()
- +26 if '$$NEXT(">")
- GOTO ATTNAME
- +27 SET ST=5
- +28 QUIT
- +29 ; Search for a token of the specified group
- +30 ; GRP=Group id
- +31 ; Returns token id within group or 0 if none found
- FNDTKN(GRP) ;
- +1 NEW TKN
- +2 SET TKN=""
- +3 FOR
- SET TKN=$ORDER(^TMP(ID,$JOB,GRP,TKN),-1)
- if $$NEXT(TKN)
- QUIT
- +4 QUIT $SELECT($LENGTH(TKN):^TMP(ID,$JOB,GRP,TKN),1:0)
- +5 ; Enumerated attribute type
- ENUM FOR
- DO WS()
- SET X=$$NAMETKN(3)
- if '$LENGTH(X)
- QUIT
- Begin DoDot:1
- +1 if TYPE=8
- DO FWD("NOT",X)
- +2 SET ^TMP(ID,$JOB,"ATT",ELEMENT,ATTRIB,X)=""
- +3 DO WS()
- End DoDot:1
- if '$$NEXT("|")
- QUIT
- +4 IF $$NEXT(")",3)
- +5 QUIT
- +6 ; NOTATION attribute type
- NOTN if $$NEXT("(",3)
- DO ENUM
- +1 QUIT
- +2 ; State 50: DTD NOTATION declaration
- 50 NEW NAME,SYS,PUB,DUP
- +1 SET NAME=$$NAME(3)
- SET ST=8
- +2 if '$LENGTH(NAME)
- QUIT
- +3 if '$$WS(1)
- QUIT
- +4 SET DUP=$DATA(^TMP(ID,$JOB,"NOT",NAME))
- +5 DO NOFWD("NOT",NAME)
- if DUP
- DO ERROR(48,NAME)
- +6 IF '$$SYSPUB(.SYS,.PUB,1)
- DO ERROR(39)
- QUIT
- +7 if DUP
- QUIT
- +8 SET ^TMP(ID,$JOB,"NOT",NAME,1)=SYS
- SET ^(2)=PUB
- +9 DO CBK("NOTATION",NAME,SYS,PUB)
- +10 QUIT
- +11 ; State 60: Conditional sections
- 60 NEW CSTYPE,CSCNT,DLM
- +1 DO DOPARAM
- +2 SET CSTYPE=$SELECT($$NEXT("INCLUDE"):1,$$NEXT("IGNORE"):2,1:0)
- SET ST=5
- +3 IF 'CSTYPE
- DO ERROR(41)
- QUIT
- +4 IF DOCSTK=1
- DO ERROR(44)
- QUIT
- +5 DO WS()
- +6 if '$$NEXT("[",3)
- QUIT
- +7 IF CSTYPE=1
- SET CS=CS+1
- QUIT
- +8 SET CSCNT=1
- SET DLM=""
- +9 FOR
- Begin DoDot:1
- +10 IF $LENGTH(DLM)
- IF $$NEXT(DLM)
- SET DLM=""
- +11 IF '$TEST
- IF $LENGTH(DLM)
- SET CPOS=CPOS+1
- +12 IF '$TEST
- IF $$NEXT(QT)
- SET DLM=QT
- +13 IF '$TEST
- IF $$NEXT("'")
- SET DLM="'"
- +14 IF '$TEST
- IF $$NEXT("<![")
- SET CSCNT=CSCNT+1
- +15 IF '$TEST
- IF $$NEXT("]]>")
- SET CSCNT=CSCNT-1
- +16 IF '$TEST
- SET CPOS=CPOS+1
- +17 if CPOS>LLEN
- DO READ
- End DoDot:1
- if 'CSCNT!EOD
- QUIT
- +18 if CSCNT
- DO ERROR(42)
- +19 QUIT
- +20 ;Local Functions moved from MXMLPRSE
- +21 ; Execute event callback (if defined)
- +22 ; EVT=Event name
- +23 ; Pn=Parameters
- CBK(EVT,P1,P2,P3,P4) ;
- +1 if EOD<0
- QUIT
- +2 NEW EN,PNUM
- +3 SET EN=$GET(CBK(EVT))
- +4 if EN=""
- QUIT
- +5 SET PNUM=^TMP(ID,$JOB,"CBK",EVT)
- +6 DO @(EN_$PIECE("(.P1,.P2,.P3,.P4",",",1,PNUM)_$SELECT('PNUM:"",1:")"))
- +7 QUIT
- +8 ; Save current document location for error reporting
- +9 ; See EPOS^MXMLPRSE
- EPOS SET ERR("XML")=XML
- SET ERR("POS")=CPOS
- SET ERR("LIN")=LPOS
- +1 QUIT
- +2 ; Check next characters
- +3 ; SEQ=character sequence
- +4 ; ERN=Error to signal if not found (optional)
- NEXT(SEQ,ERN) ;
- +1 IF SEQ=$EXTRACT(XML,CPOS,CPOS+$LENGTH(SEQ)-1)
- SET CPOS=CPOS+$LENGTH(SEQ)
- QUIT 1
- +2 if $GET(ERN)
- DO EPOS^MXMLPRSE
- DO ERROR(ERN,SEQ)
- +3 QUIT 0
- +4 ; Skip whitespace
- +5 ; ERN=Error to signal if not found (optional)
- +6 ; Optional return value =1 if whitespace found, 0 if not.
- WS(ERN) NEW CHR,FND
- +1 DO EPOS^MXMLPRSE
- +2 SET FND=0
- +3 FOR
- if CPOS>LLEN
- DO READ
- SET CHR=$EXTRACT(XML,CPOS)
- if WS'[CHR!EOD
- QUIT
- Begin DoDot:1
- +4 SET ERN=0
- SET CPOS=CPOS+1
- SET FND=1
- End DoDot:1
- +5 if $GET(ERN)
- DO ERROR(ERN)
- +6 if $QUIT
- QUIT FND
- +7 QUIT
- +8 ; Shortcuts to functions/procedures defined elsewhere
- ATTRIBS(X,Y) DO ATTRIBS^MXMLPRSE(.X,.Y)
- QUIT
- CDATA() QUIT $$CDATA^MXMLPRSE
- CHKVAL(X,Y,Z) DO CHKVAL^MXMLPRS1(.X,.Y,.Z)
- QUIT
- DOPARAM GOTO DOPARAM^MXMLPRSE
- ENTITY(X) QUIT $$ENTITY^MXMLPRSE(.X)
- ERROR(X,Y) DO ERROR^MXMLPRSE(.X,.Y)
- QUIT
- EXTRNL(X,Y,Z) QUIT $$EXTRNL^MXMLPRSE(.X,.Y,.Z)
- FWD(X,Y) DO FWD^MXMLPRS1(.X,.Y)
- QUIT
- ISCHILD(X,Y,Z) QUIT $$ISCHILD^MXMLPRS1(.X,.Y,.Z)
- NAME(X) QUIT $$NAME^MXMLPRSE(.X)
- NAMETKN(X) QUIT $$NAMETKN^MXMLPRSE(.X)
- NOFWD(X,Y) DO NOFWD^MXMLPRS1(.X,.Y)
- QUIT
- OPNDOC(X,Y,Z) DO OPNDOC^MXMLPRSE(.X,.Y,.Z)
- QUIT
- PI() QUIT $$PI^MXMLPRSE
- SETENT(X,Y) DO SETENT^MXMLPRSE(.X,.Y)
- QUIT
- SYSPUB(X,Y,Z) if $QUIT
- QUIT $$SYSPUB^MXMLPRSE(.X,.Y,.Z)
- +1 DO SYSPUB^MXMLPRSE(.X,.Y)
- QUIT
- READ GOTO READ^MXMLPRSE
- VALUE(X,Y) QUIT $$VALUE^MXMLPRSE(.X,.Y)