Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MXMLPRS0

MXMLPRS0.m

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