- MXMLPRS1 ;SAIC/DKM - XML Parser ;12/04/2002 15:55
- ;;7.3;TOOLKIT;**58,67**;Apr 25, 1995
- ;=================================================================
- ; Initialize tables
- INIT N X,Y,Z
- F X=0:1 S Y=$P($T(ENTITIES+X),";;",2,99) Q:'$L(Y) D
- .D SETENT^MXMLPRSE($P(Y,";"),$P(Y,";",2,99))
- F X=0:1 S Y=$P($T(DTDTAG+X),";;",2,99) Q:'$L(Y) D
- .S DTD($P(Y,";"))=$P(Y,";",2)
- F X=0:1 S Y=$P($T(TYPE+X),";;",2,99) Q:'$L(Y) D
- .S ^TMP(ID,$J,"TYP",$P(Y,";",2))=+Y
- F X=0:1 S Y=$P($T(MOD+X),";;",2,99) Q:'$L(Y) D
- .S ^TMP(ID,$J,"MOD",$P(Y,";",2))=+Y
- F X=0:1 S Y=$P($T(REF+X),";;",2,99) Q:'$L(Y) D
- .S ^TMP(ID,$J,"REF",$P(Y,";",2))=+Y
- F X=0:1 S Y=$P($T(CBKARGS+X),";;",2,99) Q:'$L(Y) D
- .S ^TMP(ID,$J,"CBK",$P(Y,";",2))=+Y
- F X=0:1 S Y=$P($T(PROLOG+X),";;",2,99) Q:'$L(Y) D
- .S Z=$P(Y,";"),^TMP(ID,$J,"ATT","?xml",Z)="1^"_$S('X:1,1:2)
- .F S Y=$P(Y,";",2,99) Q:'$L(Y) S ^TMP(ID,$J,"ATT","?xml",Z,$P(Y,";"))=""
- Q
- ; Search parse tree for child element (CHILD) under parent element
- ; (ELEMENT) starting at specified node (NODE).
- ; Returns next node # in parse tree or 0
- ; If validation is disabled, the function always returns 1.
- ; If parent element is marked as EMPTY, 0 is returned.
- ; If parent element is marked as ANY, 1 is returned.
- ISCHILD(ELEMENT,CHILD,NODE) ;
- N TRN
- S TRN=+$G(^TMP(ID,$J,"ELE",ELEMENT),2)
- Q $S(OPTION'["V"!'NODE:1,TRN=1:CHILD="*",TRN=2:1,1:$$IC(NODE))
- IC(NODE) N X,Y
- S X=+$G(^TMP(ID,$J,"ELE",ELEMENT,NODE,CHILD)),Y=0
- I 'X D
- .F S Y=$O(^TMP(ID,$J,"ELE",ELEMENT,NODE,Y)) Q:'Y D Q:X
- ..S:'$D(TRN(NODE,Y)) TRN(NODE,Y)="",X=$$IC(Y)
- Q X
- ; Check attribute value for validity
- CHKVAL(ENAME,ANAME,VALUE) ;
- N TYPE,X,Y,Z
- Q:'$L(VALUE)
- I $D(^TMP(ID,$J,"ATT",ENAME,ANAME))>1 D:'$D(^(ANAME,VALUE)) ERROR(38,VALUE) Q
- S TYPE=+$G(^TMP(ID,$J,"ATT",ENAME,ANAME))
- Q:'TYPE
- I TYPE=5 D Q ; ID type
- .I '$$ISNAME(VALUE) D ERROR(38,VALUE) Q
- .I '$D(^TMP(ID,$J,"ID",VALUE)) D
- ..S ^(VALUE)=""
- ..D NOFWD("ID",VALUE)
- .E D ERROR(28,VALUE)
- I TYPE=9!(TYPE=10) D Q ; ENTITY/ENTITIES type
- .S X=$S(TYPE=9:" ",1:" ")
- .F Z=1:1:$L(VALUE,X) D FWD("UNP",$P(VALUE,X,Z))
- I TYPE=3!(TYPE=4) D Q ; NMTOKEN/NMTOKENS type
- .S X=$S(TYPE=3:" ",1:" ")
- .F Z=1:1:$L(VALUE,X) D
- ..S Y=$P(VALUE,X,Z)
- ..D:'$$ISNMTKN(Y) ERROR(38,Y)
- I TYPE=6!(TYPE=7) D Q ; IDREF/IDREFS type
- .S X=$S(TYPE=6:" ",1:" ")
- .F Z=1:1:$L(VALUE,X) D
- ..S Y=$P(VALUE,X,Z)
- ..I '$$ISNAME(Y) D ERROR(38,Y) Q
- ..D FWD("ID",Y)
- Q
- ; Return true if valid name
- ISNAME(VALUE) ;
- Q VALUE?1(1A,1"_",1":").(1AN,1".",1"-",1"_",1":")
- ; Return true if valid name token
- ISNMTKN(VALUE) ;
- Q VALUE?1.(1AN,1".",1"-",1"_",1":")
- ; Log a forward reference
- FWD(TYPE,VALUE) ;
- Q:'$L(VALUE)
- Q:$D(^TMP(ID,$J,TYPE,VALUE))
- N Z
- S Z=$O(^TMP(ID,$J,"REF",TYPE,VALUE,""),-1)+1
- M ^(Z)=ERR
- Q
- ; Resolve forward reference
- NOFWD(TYPE,VALUE) ;
- K ^TMP(ID,$J,"REF",TYPE,VALUE)
- Q
- ; Signal unresolved references
- UNRESLV N X,Y,Z,E
- F X=1:1:LVL D
- .K ERR
- .M ERR=LVL(X)
- .D ERROR(8,LVL(X))
- S X=""
- F S X=$O(^TMP(ID,$J,"REF",X)),Y="" Q:'$L(X) D ; Look for IDREF w/o corresponding ID value
- .S E=^(X)
- .F S Y=$O(^TMP(ID,$J,"REF",X,Y)),Z=0 Q:'$L(Y) D
- ..F S Z=$O(^TMP(ID,$J,"REF",X,Y,Z)) Q:'Z D
- ...K ERR
- ...M ERR=^(Z)
- ...D ERROR(E,Y)
- Q
- ; Log error
- ERROR(X,Y) D ERROR^MXMLPRSE(.X,.Y) Q
- ; Predefined general entities
- ; Format=entity name;entity value
- ENTITIES ;;amp;&
- ;;lt;<
- ;;gt;>
- ;;quot;"
- ;;apos;'
- ;;
- ; Callback events
- ; Format=#args;event type
- CBKARGS ;;0;STARTDOCUMENT
- ;;0;ENDDOCUMENT
- ;;3;DOCTYPE
- ;;1;CHARACTERS
- ;;2;STARTELEMENT
- ;;1;ENDELEMENT
- ;;3;NOTATION
- ;;2;PI
- ;;1;COMMENT
- ;;3;EXTERNAL
- ;;1;ERROR
- ;;
- ; Prolog attributes
- ; Format=attribute name;val1;val2;...;valn
- PROLOG ;;version;1.0
- ;;encoding;UTF-8;utf-8
- ;;standalone;no;yes
- ;;
- ; Recognized DTD tags
- ; Format=tag name;state
- DTDTAG ;;ENTITY;20
- ;;ELEMENT;30
- ;;ATTLIST;40
- ;;NOTATION;50
- ;;[;60
- ;;
- ; Attribute types
- ; Format=identifier;type
- TYPE ;;1;(
- ;;2;CDATA
- ;;3;NMTOKEN
- ;;4;NMTOKENS
- ;;5;ID
- ;;6;IDREF
- ;;7;IDREFS
- ;;8;NOTATION
- ;;9;ENTITY
- ;;10;ENTITIES
- ;;
- ; Default modifiers
- ; Format=identifier;modifier
- MOD ;;1;#REQUIRED
- ;;2;#IMPLIED
- ;;3;#FIXED
- ;;
- ; Forward references
- ; Format=type;error #;type
- REF ;;49;UNP
- ;;46;NOT
- ;;26;ELE
- ;;47;ID
- ;;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMXMLPRS1 4599 printed Feb 18, 2025@23:36:43 Page 2
- MXMLPRS1 ;SAIC/DKM - XML Parser ;12/04/2002 15:55
- +1 ;;7.3;TOOLKIT;**58,67**;Apr 25, 1995
- +2 ;=================================================================
- +3 ; Initialize tables
- INIT NEW X,Y,Z
- +1 FOR X=0:1
- SET Y=$PIECE($TEXT(ENTITIES+X),";;",2,99)
- if '$LENGTH(Y)
- QUIT
- Begin DoDot:1
- +2 DO SETENT^MXMLPRSE($PIECE(Y,";"),$PIECE(Y,";",2,99))
- End DoDot:1
- +3 FOR X=0:1
- SET Y=$PIECE($TEXT(DTDTAG+X),";;",2,99)
- if '$LENGTH(Y)
- QUIT
- Begin DoDot:1
- +4 SET DTD($PIECE(Y,";"))=$PIECE(Y,";",2)
- End DoDot:1
- +5 FOR X=0:1
- SET Y=$PIECE($TEXT(TYPE+X),";;",2,99)
- if '$LENGTH(Y)
- QUIT
- Begin DoDot:1
- +6 SET ^TMP(ID,$JOB,"TYP",$PIECE(Y,";",2))=+Y
- End DoDot:1
- +7 FOR X=0:1
- SET Y=$PIECE($TEXT(MOD+X),";;",2,99)
- if '$LENGTH(Y)
- QUIT
- Begin DoDot:1
- +8 SET ^TMP(ID,$JOB,"MOD",$PIECE(Y,";",2))=+Y
- End DoDot:1
- +9 FOR X=0:1
- SET Y=$PIECE($TEXT(REF+X),";;",2,99)
- if '$LENGTH(Y)
- QUIT
- Begin DoDot:1
- +10 SET ^TMP(ID,$JOB,"REF",$PIECE(Y,";",2))=+Y
- End DoDot:1
- +11 FOR X=0:1
- SET Y=$PIECE($TEXT(CBKARGS+X),";;",2,99)
- if '$LENGTH(Y)
- QUIT
- Begin DoDot:1
- +12 SET ^TMP(ID,$JOB,"CBK",$PIECE(Y,";",2))=+Y
- End DoDot:1
- +13 FOR X=0:1
- SET Y=$PIECE($TEXT(PROLOG+X),";;",2,99)
- if '$LENGTH(Y)
- QUIT
- Begin DoDot:1
- +14 SET Z=$PIECE(Y,";")
- SET ^TMP(ID,$JOB,"ATT","?xml",Z)="1^"_$SELECT('X:1,1:2)
- +15 FOR
- SET Y=$PIECE(Y,";",2,99)
- if '$LENGTH(Y)
- QUIT
- SET ^TMP(ID,$JOB,"ATT","?xml",Z,$PIECE(Y,";"))=""
- End DoDot:1
- +16 QUIT
- +17 ; Search parse tree for child element (CHILD) under parent element
- +18 ; (ELEMENT) starting at specified node (NODE).
- +19 ; Returns next node # in parse tree or 0
- +20 ; If validation is disabled, the function always returns 1.
- +21 ; If parent element is marked as EMPTY, 0 is returned.
- +22 ; If parent element is marked as ANY, 1 is returned.
- ISCHILD(ELEMENT,CHILD,NODE) ;
- +1 NEW TRN
- +2 SET TRN=+$GET(^TMP(ID,$JOB,"ELE",ELEMENT),2)
- +3 QUIT $SELECT(OPTION'["V"!'NODE:1,TRN=1:CHILD="*",TRN=2:1,1:$$IC(NODE))
- IC(NODE) NEW X,Y
- +1 SET X=+$GET(^TMP(ID,$JOB,"ELE",ELEMENT,NODE,CHILD))
- SET Y=0
- +2 IF 'X
- Begin DoDot:1
- +3 FOR
- SET Y=$ORDER(^TMP(ID,$JOB,"ELE",ELEMENT,NODE,Y))
- if 'Y
- QUIT
- Begin DoDot:2
- +4 if '$DATA(TRN(NODE,Y))
- SET TRN(NODE,Y)=""
- SET X=$$IC(Y)
- End DoDot:2
- if X
- QUIT
- End DoDot:1
- +5 QUIT X
- +6 ; Check attribute value for validity
- CHKVAL(ENAME,ANAME,VALUE) ;
- +1 NEW TYPE,X,Y,Z
- +2 if '$LENGTH(VALUE)
- QUIT
- +3 IF $DATA(^TMP(ID,$JOB,"ATT",ENAME,ANAME))>1
- if '$DATA(^(ANAME,VALUE))
- DO ERROR(38,VALUE)
- QUIT
- +4 SET TYPE=+$GET(^TMP(ID,$JOB,"ATT",ENAME,ANAME))
- +5 if 'TYPE
- QUIT
- +6 ; ID type
- IF TYPE=5
- Begin DoDot:1
- +7 IF '$$ISNAME(VALUE)
- DO ERROR(38,VALUE)
- QUIT
- +8 IF '$DATA(^TMP(ID,$JOB,"ID",VALUE))
- Begin DoDot:2
- +9 SET ^(VALUE)=""
- +10 DO NOFWD("ID",VALUE)
- End DoDot:2
- +11 IF '$TEST
- DO ERROR(28,VALUE)
- End DoDot:1
- QUIT
- +12 ; ENTITY/ENTITIES type
- IF TYPE=9!(TYPE=10)
- Begin DoDot:1
- +13 SET X=$SELECT(TYPE=9:" ",1:" ")
- +14 FOR Z=1:1:$LENGTH(VALUE,X)
- DO FWD("UNP",$PIECE(VALUE,X,Z))
- End DoDot:1
- QUIT
- +15 ; NMTOKEN/NMTOKENS type
- IF TYPE=3!(TYPE=4)
- Begin DoDot:1
- +16 SET X=$SELECT(TYPE=3:" ",1:" ")
- +17 FOR Z=1:1:$LENGTH(VALUE,X)
- Begin DoDot:2
- +18 SET Y=$PIECE(VALUE,X,Z)
- +19 if '$$ISNMTKN(Y)
- DO ERROR(38,Y)
- End DoDot:2
- End DoDot:1
- QUIT
- +20 ; IDREF/IDREFS type
- IF TYPE=6!(TYPE=7)
- Begin DoDot:1
- +21 SET X=$SELECT(TYPE=6:" ",1:" ")
- +22 FOR Z=1:1:$LENGTH(VALUE,X)
- Begin DoDot:2
- +23 SET Y=$PIECE(VALUE,X,Z)
- +24 IF '$$ISNAME(Y)
- DO ERROR(38,Y)
- QUIT
- +25 DO FWD("ID",Y)
- End DoDot:2
- End DoDot:1
- QUIT
- +26 QUIT
- +27 ; Return true if valid name
- ISNAME(VALUE) ;
- +1 QUIT VALUE?1(1A,1"_",1":").(1AN,1".",1"-",1"_",1":")
- +2 ; Return true if valid name token
- ISNMTKN(VALUE) ;
- +1 QUIT VALUE?1.(1AN,1".",1"-",1"_",1":")
- +2 ; Log a forward reference
- FWD(TYPE,VALUE) ;
- +1 if '$LENGTH(VALUE)
- QUIT
- +2 if $DATA(^TMP(ID,$JOB,TYPE,VALUE))
- QUIT
- +3 NEW Z
- +4 SET Z=$ORDER(^TMP(ID,$JOB,"REF",TYPE,VALUE,""),-1)+1
- +5 MERGE ^(Z)=ERR
- +6 QUIT
- +7 ; Resolve forward reference
- NOFWD(TYPE,VALUE) ;
- +1 KILL ^TMP(ID,$JOB,"REF",TYPE,VALUE)
- +2 QUIT
- +3 ; Signal unresolved references
- UNRESLV NEW X,Y,Z,E
- +1 FOR X=1:1:LVL
- Begin DoDot:1
- +2 KILL ERR
- +3 MERGE ERR=LVL(X)
- +4 DO ERROR(8,LVL(X))
- End DoDot:1
- +5 SET X=""
- +6 ; Look for IDREF w/o corresponding ID value
- FOR
- SET X=$ORDER(^TMP(ID,$JOB,"REF",X))
- SET Y=""
- if '$LENGTH(X)
- QUIT
- Begin DoDot:1
- +7 SET E=^(X)
- +8 FOR
- SET Y=$ORDER(^TMP(ID,$JOB,"REF",X,Y))
- SET Z=0
- if '$LENGTH(Y)
- QUIT
- Begin DoDot:2
- +9 FOR
- SET Z=$ORDER(^TMP(ID,$JOB,"REF",X,Y,Z))
- if 'Z
- QUIT
- Begin DoDot:3
- +10 KILL ERR
- +11 MERGE ERR=^(Z)
- +12 DO ERROR(E,Y)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 QUIT
- +14 ; Log error
- ERROR(X,Y) DO ERROR^MXMLPRSE(.X,.Y)
- QUIT
- +1 ; Predefined general entities
- +2 ; Format=entity name;entity value
- ENTITIES ;;amp;&
- +1 ;;lt;<
- +2 ;;gt;>
- +3 ;;quot;"
- +4 ;;apos;'
- +5 ;;
- +6 ; Callback events
- +7 ; Format=#args;event type
- CBKARGS ;;0;STARTDOCUMENT
- +1 ;;0;ENDDOCUMENT
- +2 ;;3;DOCTYPE
- +3 ;;1;CHARACTERS
- +4 ;;2;STARTELEMENT
- +5 ;;1;ENDELEMENT
- +6 ;;3;NOTATION
- +7 ;;2;PI
- +8 ;;1;COMMENT
- +9 ;;3;EXTERNAL
- +10 ;;1;ERROR
- +11 ;;
- +12 ; Prolog attributes
- +13 ; Format=attribute name;val1;val2;...;valn
- PROLOG ;;version;1.0
- +1 ;;encoding;UTF-8;utf-8
- +2 ;;standalone;no;yes
- +3 ;;
- +4 ; Recognized DTD tags
- +5 ; Format=tag name;state
- DTDTAG ;;ENTITY;20
- +1 ;;ELEMENT;30
- +2 ;;ATTLIST;40
- +3 ;;NOTATION;50
- +4 ;;[;60
- +5 ;;
- +6 ; Attribute types
- +7 ; Format=identifier;type
- TYPE ;;1;(
- +1 ;;2;CDATA
- +2 ;;3;NMTOKEN
- +3 ;;4;NMTOKENS
- +4 ;;5;ID
- +5 ;;6;IDREF
- +6 ;;7;IDREFS
- +7 ;;8;NOTATION
- +8 ;;9;ENTITY
- +9 ;;10;ENTITIES
- +10 ;;
- +11 ; Default modifiers
- +12 ; Format=identifier;modifier
- MOD ;;1;#REQUIRED
- +1 ;;2;#IMPLIED
- +2 ;;3;#FIXED
- +3 ;;
- +4 ; Forward references
- +5 ; Format=type;error #;type
- REF ;;49;UNP
- +1 ;;46;NOT
- +2 ;;26;ELE
- +3 ;;47;ID
- +4 ;;