| 1 |
wakaba |
1.1 |
|
| 2 |
|
|
=head1 NAME
|
| 3 |
|
|
|
| 4 |
wakaba |
1.12 |
Message::Markup::XML::Parser --- manakai: Simple XML parser
|
| 5 |
wakaba |
1.1 |
|
| 6 |
|
|
=head1 DESCRIPTION
|
| 7 |
|
|
|
| 8 |
wakaba |
1.12 |
This is a simple XML parser intended to be used with Message::Markup::XML.
|
| 9 |
|
|
After parsing of the XML document, this module returns a Message::Markup::XML
|
| 10 |
wakaba |
1.1 |
object so that you can handle XML document with that module (and other modules
|
| 11 |
|
|
implementing same interface).
|
| 12 |
|
|
|
| 13 |
wakaba |
1.12 |
This module is part of manakai.
|
| 14 |
wakaba |
1.1 |
|
| 15 |
|
|
=cut
|
| 16 |
|
|
|
| 17 |
wakaba |
1.12 |
package Message::Markup::XML::Parser;
|
| 18 |
wakaba |
1.1 |
use strict;
|
| 19 |
wakaba |
1.14 |
our $VERSION = do{my @r=(q$Revision: 1.13 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
|
| 20 |
wakaba |
1.6 |
use Char::Class::XML qw!InXML_NameStartChar InXMLNameChar InXMLChar
|
| 21 |
|
|
InXML_deprecated_noncharacter InXML_unicode_xml_not_suitable!;
|
| 22 |
wakaba |
1.12 |
require Message::Markup::XML;
|
| 23 |
|
|
require Message::Markup::XML::Error;
|
| 24 |
|
|
*_raise_error = \&Message::Markup::XML::Error::raise;
|
| 25 |
wakaba |
1.6 |
our %NS;
|
| 26 |
wakaba |
1.12 |
*NS = \%Message::Markup::XML::NS;
|
| 27 |
wakaba |
1.1 |
|
| 28 |
|
|
=head1 METHODS
|
| 29 |
|
|
|
| 30 |
|
|
WARNING: This module is under construction. Interface of this module is not yet fixed.
|
| 31 |
|
|
|
| 32 |
|
|
=cut
|
| 33 |
|
|
|
| 34 |
w |
1.10 |
our %xml_re;
|
| 35 |
wakaba |
1.1 |
# [1] document = prolog element *Misc
|
| 36 |
|
|
# [2] Char = %x09 / %x0A / %x0D / U+0020-U+D7FF / U+E000-U+FFFD / U+10000-U+10FFFF ;; 1.0
|
| 37 |
|
|
# [2] Char = %x09 / %x0A / %x0D / %x20-7E / U+0085 / U+00A0-U+D7FF / U+E000-U+FFFD
|
| 38 |
|
|
# / U+10000-U+10FFFF ;; 1.1
|
| 39 |
|
|
# [3] s = 1*(%x20 / %x09 / %x0D / %x0A)
|
| 40 |
wakaba |
1.6 |
$xml_re{s} = qr/[\x09\x0A\x0D\x20]+/s;
|
| 41 |
w |
1.8 |
$xml_re{_s__chars} = qr/\x09\x0A\x0D\x20/s;
|
| 42 |
wakaba |
1.1 |
# [4] NameChar = Letter / Digit / "." / "-" / "_" / ":" / CombiningChar / Extender ;; 1.0
|
| 43 |
|
|
# [4] NameStartChar = ":" / ALPHA / "_" / U+00C0-U+02FF / U+0370-U+037D
|
| 44 |
|
|
# / U+037F-U+1FFF / U+200C-U+200D / U+2070-U+218F
|
| 45 |
|
|
# / U+2C00-U+2FEF / U+3001-U+D7FF / U+F900-U+EFFFF ;; 1.1
|
| 46 |
|
|
# [4a] NameChar = NameStartChar / "-" / "." / DIGIT / U+00B7 / U+0300-U+036F
|
| 47 |
|
|
# / U+203F-U+2040 ;; 1.1
|
| 48 |
|
|
# $xml_re{NameChar} = qr/[A-Za-z0-9._:-]|[^\x00-\x7F]/;
|
| 49 |
wakaba |
1.4 |
#$xml_re{NameChar} = qr/\p{InXMLNameChar}/;
|
| 50 |
wakaba |
1.1 |
# [5] Name = (Letter / "_" / ":") *NameChar ;; 1.0
|
| 51 |
|
|
# [5] Name = NameStartChar *NameChar ;; 1.1
|
| 52 |
|
|
# $xml_re{Name} = qr/(?:[A-Z_:]|[^\x00-\x7F])(?:$xml_re{NameChar})*/;
|
| 53 |
|
|
$xml_re{Name} = qr/\p{InXML_NameStartChar}\p{InXMLNameChar}*/;
|
| 54 |
|
|
# [6] Names = Name *(S Name) ;; 1.0 FE & 1.0 FE-errata (2000-09-27) & 1.0 SE
|
| 55 |
|
|
# [6] Names = Name *(%x20 Name) ;; 1.0 FE-errata (2000-04-09) & 1.0 SE-errata
|
| 56 |
wakaba |
1.4 |
#$xml_re{Names} = qr/$xml_re{Name}(?:$xml_re{s}$xml_re{Name})*/s;
|
| 57 |
wakaba |
1.1 |
# [7] Nmtoken = 1*NameChar
|
| 58 |
|
|
#$xml_re{Nmtoken} = qr/(?:$xml_re{NameChar})+/;
|
| 59 |
wakaba |
1.4 |
#$xml_re{Nmtoken} = qr/\p{InXMLNameChar}+/;
|
| 60 |
wakaba |
1.1 |
# [8] Nmtokens = Nmtoken *(S Nmtoken) ;; 1.0 FE & 1.0 FE-errata (2000-09-27) & 1.0 SE
|
| 61 |
|
|
# [8] Nmtokens = Nmtoken *(%x20 Nmtoken) ;; 1.0 FE-errata (2000-04-09) & 1.0 SE-errata
|
| 62 |
wakaba |
1.4 |
#$xml_re{Nmtokens} = qr/$xml_re{Nmtoken}(?:$xml_re{s}$xml_re{Nmtoken})*/s;
|
| 63 |
wakaba |
1.1 |
# [9] EntityValue = <"> *((Char - ("%" / "&" / <">)) / PEReference / Reference) <">
|
| 64 |
|
|
# / "'" *((Char - ("%" / "&" / "'")) / PEReference / Reference) "'"
|
| 65 |
|
|
# [10] AttValue = <"> *((Char - ("<" / "&" / <">)) / Reference) <">
|
| 66 |
|
|
# / "'" *((Char - ("<" / "&" / "'")) / Reference) "'"
|
| 67 |
|
|
$xml_re{__AttValue_simple} = qr/"[^"]*"|'[^']*'/s;
|
| 68 |
|
|
# [11] SystemLiteral = <"> *(Char - <">) <"> / "'" *(Char - "'") "'"
|
| 69 |
wakaba |
1.4 |
#$xml_re{SystemLiteral} = qr/"[^"]*"|'[^']*'/;
|
| 70 |
wakaba |
1.1 |
# [12] PublicLiteral = <"> *PubidChar <"> / "'" *(PubidChar - "'") "'"
|
| 71 |
|
|
# [13] PubidChar = %x20 / %x0D / %x0A / ALPHA / DIGIT / "-" / "'" / "(" / ")"
|
| 72 |
|
|
# / "+" / "," / "." / "/" / ":" / "=" / "?" / ";" / "!" / "*"
|
| 73 |
|
|
# / "#" / "@" / "$" / "_" / "%"
|
| 74 |
wakaba |
1.6 |
#$xml_re{PubidChar} = qr[[\x0D\x0A\x20!\x24#%'()+*,./0-9:;=?\x40A-Z_a-z-]];
|
| 75 |
|
|
#$xml_re{__non_PubidChar} = qr[[^\x0D\x0A\x20!\x24#%'()+*,./0-9:;=?\x40A-Z_a-z-]];
|
| 76 |
wakaba |
1.4 |
#$xml_re{__PubidChar2} = qr[[\x0D\x0A\x20!\x24#%()+*,./0-9:;=?\x40A-Z_a-z-]];
|
| 77 |
|
|
#$xml_re{PublicLiteral} = qr/"(?:$xml_re{PubidChar})*"|'(?:$xml_re{__PubidChar2})*'/;
|
| 78 |
wakaba |
1.1 |
# [14] CharData = *(Char - ("<" / "&")) - (*(Char - ("<" / "&")) "]]>" *(Char - ("<" / "&")))
|
| 79 |
wakaba |
1.4 |
#$xml_re{CharData} = qr/(?:(?!\]\]>)[^<&])*/s;
|
| 80 |
wakaba |
1.1 |
$xml_re{__CharDataP} = qr/(?:(?!\]\]>)[^<&])+/s;
|
| 81 |
|
|
# [15] Comment = "<!--" *((Char - "-") / ("-" (Char - "-")))) "-->"
|
| 82 |
|
|
$xml_re{Comment_M} = qr/<!--((?:(?!--).)*)-->/s;
|
| 83 |
|
|
# [16] PI = "<?" PITarget [S (*Char - (*Char "?>" *Char))] "?>"
|
| 84 |
|
|
$xml_re{PI_M} = qr/<\?($xml_re{Name})(?:$xml_re{s}((?:(?!\?>).)*))?\?>/s;
|
| 85 |
wakaba |
1.4 |
$xml_re{_xml_PI_M} = qr/<\?xml(?:$xml_re{s}((?:(?!\?>).)*))?\?>/s;
|
| 86 |
wakaba |
1.1 |
# [17] PITarget = Name - "xml"
|
| 87 |
|
|
# [18] CDSect = CDStart CData CDEnd
|
| 88 |
|
|
# [19] CDStart = '<![CDATA['
|
| 89 |
|
|
# [20] CDATA = (*Char - (*Char "]]>" *Char))
|
| 90 |
|
|
# [21] CDEnd = "]]>"
|
| 91 |
|
|
$xml_re{CDSect_M} = qr/<!\[CDATA\[((?:(?!\]\]>).)*)\]\]>/s;
|
| 92 |
|
|
# [22] prolog = [XMLDecl] *Misc [doctypedecl *Misc]
|
| 93 |
|
|
# [23] XMLDecl = '<?xml' VersionInfo [EncodingDecl] [SDDecl] [S] "?>"
|
| 94 |
|
|
# [24] VersionInfo = S 'version' Eq ("'" VersionNum "'" / <"> VersionNum <">)
|
| 95 |
|
|
# [25] Eq = [S] "=" [S]
|
| 96 |
|
|
# [26] VersionNum = 1*(ALPHA / DIGIT / "_" / "." / ":" / "-") ;; 1.0 FE & 1.0 SE
|
| 97 |
|
|
# [26] VersionNum = "1.0" ;; 1.0 SE-errata
|
| 98 |
|
|
# [26] VersionNum = "1.1" ;; 1.1
|
| 99 |
|
|
# [27] Misc = Comment / PI / S
|
| 100 |
|
|
# [28] doctypedecl = '<!DOCTYPE' S Name [S ExternalID] [S]
|
| 101 |
|
|
# ["[" *(markupdecl / PEReference / S) "]" [S]] ">" ;; 1.0 FE
|
| 102 |
|
|
# [28] doctypedecl = '<!DOCTYPE' S Name [S ExternalID] [S] ["[" *(markupdecl / DeclSep) "]" [S]] ">"
|
| 103 |
|
|
# ;; 1.0 FE-errata & 1.0 SE
|
| 104 |
|
|
# [28] doctypedecl = '<!DOCTYPE' S Name [S ExternalID] [S] ["[" intSubset "]" [S]] ">"
|
| 105 |
|
|
# ;; 1.0 SE-errata
|
| 106 |
wakaba |
1.6 |
#$xml_re{__doctypedecl_start_simple_M} = qr/(<!DOCTYPE$xml_re{s})($xml_re{Name})($xml_re{s}SYSTEM$xml_re{s}$xml_re{__AttValue_simple}|$xml_re{s}PUBLIC$xml_re{s}$xml_re{__AttValue_simple}$xml_re{s}$xml_re{__AttValue_simple})?/s;
|
| 107 |
wakaba |
1.1 |
# [28a] DeclSep = PEReference / S ;; 1.0 FE-errata & 1.0 SE
|
| 108 |
|
|
# [28b] intSubset = *(markupdecl / DeclSep) ;; 1.0 SE-errata
|
| 109 |
|
|
# [29] markupdecl = elementdecl / AttlistDecl / EntityDecl / NotationDecl / PI / Comment
|
| 110 |
|
|
# [30] extSubset = [TextDecl] extSubsetDecl
|
| 111 |
|
|
# [31] extSubsetDecl = *(markupdecl / conditionalSect / PEReference / S) ;; 1.0 FE
|
| 112 |
|
|
# [31] extSubsetDecl = *(markupdecl / conditionalSect / DeclSep) ;; 1.0 FE-errata & 1.0 SE
|
| 113 |
|
|
# [32] SDDecl = S 'standalone' Eq ("'" ('yes' / 'no') "'" / <"> ('yes' / 'no') <">)
|
| 114 |
|
|
# [33] LanguageID = Langcode *("-" Subcode) ;; 1.0 FE (removed by 1.0 SE)
|
| 115 |
|
|
# [34] Langcode = ISO639Cocde / IanaCode / UserCode ;; 1.0 FE (ditto)
|
| 116 |
|
|
# [35] ISO639Code = 2ALPHA ;; 1.0 FE (ditto)
|
| 117 |
|
|
# [36] IanaCode = "i-" 1*ALPHA ;; 1.0 FE (ditto)
|
| 118 |
|
|
# [37] UserCode = "x-" 1*ALPHA ;; 1.0 FE (ditto)
|
| 119 |
|
|
# [38] Subcode = 1*ALPHA ;; 1.0 FE (ditto)
|
| 120 |
|
|
# [39] element = EmptyElemTag / STag content ETag
|
| 121 |
|
|
# [40] STag = "<" Name *(S Attribute) [S] ">"
|
| 122 |
|
|
# [41] Attribute = Name Eq AttValue
|
| 123 |
|
|
$xml_re{Attribute} = qr/$xml_re{Name}(?:$xml_re{s})?=(?:$xml_re{s})?$xml_re{__AttValue_simple}/s;
|
| 124 |
|
|
$xml_re{Attribute_M} = qr/($xml_re{Name})(?:$xml_re{s})?=(?:$xml_re{s})?($xml_re{__AttValue_simple})/s;
|
| 125 |
wakaba |
1.4 |
#$xml_re{STag} = qr/<$xml_re{Name}(?:$xml_re{s}$xml_re{Attribute})*(?:$xml_re{s})?>/s;
|
| 126 |
wakaba |
1.1 |
# [42] ETag = "</" Name [S] ">"
|
| 127 |
|
|
$xml_re{ETag_M} = qr!</($xml_re{Name})(?:$xml_re{s})?>!s;
|
| 128 |
|
|
# [43] content = *(element / CharData / Reference / CDSect / PI / Comment) ;; 1.0 FE
|
| 129 |
|
|
# [43] content = [CharData] *((element / Reference / CDSect / PI / Comment) [CharData])
|
| 130 |
|
|
# ;; 1.0 FE-errata & 1.0 SE
|
| 131 |
|
|
# [44] EmptyElemTag = "<" Name *(S Attribute) [S] "/>"
|
| 132 |
wakaba |
1.4 |
#$xml_re{__STag_or_EmptyElemTag} = qr!<$xml_re{Name}(?:$xml_re{s}$xml_re{Attribute})*(?:$xml_re{s})?/?>!s;
|
| 133 |
wakaba |
1.1 |
$xml_re{__STag_or_EmptyElemTag_simple} = qr!<$xml_re{ame}(?:$xml_re{s}|$xml_re{Name}|$xml_re{__AttValue_simple}|=)*/?>!s;
|
| 134 |
|
|
# [45] elementdecl = '<!ELEMENT' S Name S contentspec [S] ">"
|
| 135 |
|
|
# [46] contentspec = 'EMPTY' / 'ANY' / Mixed / children
|
| 136 |
wakaba |
1.4 |
#$xml_re{__contentspec_simple} = qr/(?:$xml_re{Name}|\#PCDATA|[()|,?*+]|$xml_re{s})/s;
|
| 137 |
wakaba |
1.1 |
# [47] children = (choice / seq) ["?" / "*" / "+"]
|
| 138 |
|
|
# [48] cp = (Name / choice / seq) ["?" / "*" / "+"]
|
| 139 |
|
|
# [49] choice = "(" [S] cp *([S] "|" [S] cp) [S] ")" ;; 1.0 FE
|
| 140 |
|
|
# [49] choice = "(" [S] cp 1*([S] "|" [S] cp) [S] ")" ;; 1.0 FE-errata & 1.0 SE
|
| 141 |
|
|
# [50] seq = "(" [S] cp *([S] "," [S] cp) [S] ")"
|
| 142 |
|
|
# [51] Mixed = "(" [S] '#PCDATA' *([S] "|" [S] Name) [S] ")*"
|
| 143 |
|
|
# / "(" [S] '#PCDATA' [S] ")"
|
| 144 |
|
|
#$xml_re{seq} = qr/\($xml_re{cp}(?:(?:$xml_re{s})?,(?:$xml_re{s})?$xml_re{cp})*(?:$xml_re{s})?\)/;
|
| 145 |
|
|
#$xml_re{cp} = qr/(?:$xml_re{Name}|$xml_re{choice}|$xml_re{seq})[?*+]/;
|
| 146 |
|
|
#$xml_re{choice} = qr/\($xml_re{cp}(?:(?:$xml_re{s})?\|(?:$xml_re{s})?$xml_re{cp})+(?:$xml_re{s})?\)/;
|
| 147 |
|
|
#$xml_re{children} = qr/(?:$xml_re{choice}|$xml_re{seq})[?*+]/;
|
| 148 |
|
|
#$xml_re{Mixed} = qr/(?:\((?:$xml_re{s})?\#PCDATA(?:$xml_re{s})?(?:(?:$xml_re{s})?|(?:$xml_re{s})?$xml_re{Name})*(?:$xml_re{s})?\)|\((?:$xml_re{s})?\#PCDATA(?:$xml_re{s})?\))/;
|
| 149 |
|
|
#$xml_re{contentspec} = qr/(?:EMPTY|ANY|$xml_re{Mixed}|$xml_re{children})/;
|
| 150 |
|
|
# [52] AttlistDecl = '<!ATTLIST' S Name *AttDef [S] ">"
|
| 151 |
|
|
# [53] AttDef = S Name S AttType S DefaultDecl
|
| 152 |
|
|
# [54] AttType = StringType / TokenizedType / EnumeratedType
|
| 153 |
|
|
# [55] StringType = 'CDATA'
|
| 154 |
|
|
# [56] TokenizedType = 'ID' / 'IDREF' / 'IDREFS' / 'ENTITY' / 'ENTITIES' / 'NMTOKEN' / 'NMTOKENS'
|
| 155 |
|
|
# [57] EnumeratedType = NotationType / Enumeration
|
| 156 |
|
|
# [58] NotationType = 'NOTATION' S "(" [S] Name *([S] "|" [S] Name) [S] ")"
|
| 157 |
|
|
# [59] Enumeration = "(" [S] Nmtoken *([S] "|" [S] Nmtoken) [S} ")"
|
| 158 |
|
|
# [60] DefaultDecl = '#REQUIRED' / '#IMPLIED' / ['#FIXED' S] AttValue
|
| 159 |
|
|
# [61] conditionalSect = includeSect / ignoreSect
|
| 160 |
|
|
# [62] includeSect = "<![" [S} 'INCLUDE' [S] "[" extSubsetDecl "]]>"
|
| 161 |
|
|
# [63] ignoreSect = "<![" [S] 'IGNORE' [S] "[" *ignoreSectContents "]]>"
|
| 162 |
|
|
# [64] ignoreSectContents = Ignore *("<![" ignoreSectContents "]]>" Ignore)
|
| 163 |
|
|
# [65] Ignore = *Char - (*Char ("<![" / "]]>") *Char)
|
| 164 |
|
|
# [66] CharRef = '&#' 1*DIGIT ";" / '&#x' 1*HEXDIGIT ";"
|
| 165 |
|
|
$xml_re{CharRef} = qr/&#[0-9]+;|&#x[0-9A-Fa-f]+;/;
|
| 166 |
|
|
# [67] Reference = EntityRef / CharRef
|
| 167 |
|
|
# [68] EntityRef = "&" Name ";"
|
| 168 |
|
|
$xml_re{EntityRef} = qr/&$xml_re{Name};/;
|
| 169 |
|
|
$xml_re{EntityRef_M} = qr/&($xml_re{Name});/;
|
| 170 |
|
|
$xml_re{Reference} = qr/$xml_re{EntityRef}|$xml_re{CharRef}/;
|
| 171 |
wakaba |
1.4 |
#$xml_re{AttValue} = qr/"(?:$xml_re{Reference}|[^&<"])*"|'(?:$xml_re{Reference}|[^&<'])*'/s;
|
| 172 |
wakaba |
1.1 |
# [69] PEReference = "%" Name ";"
|
| 173 |
|
|
$xml_re{PEReference} = qr/%(?:$xml_re{Name});/;
|
| 174 |
|
|
$xml_re{PEReference_M} = qr/%($xml_re{Name});/;
|
| 175 |
|
|
$xml_re{__elementdecl_simple} = qr/<!ELEMENT(?:$xml_re{s}|$xml_re{PEReference}|$xml_re{Name}|\#PCDATA|[()|,?*+])+>/s;
|
| 176 |
wakaba |
1.5 |
$xml_re{__AttlistDecl_simple} = qr/<!ATTLIST(?:$xml_re{PEReference}|$xml_re{Name}|[#()|]|$xml_re{s}|$xml_re{__AttValue_simple})*>/s;
|
| 177 |
wakaba |
1.1 |
# [70] EntityDecl = GEDecl / PEDecl
|
| 178 |
wakaba |
1.6 |
#$xml_re{__EntityDecl_simple} = qr/<!ENTITY(?:$xml_re{__AttValue_simple}|[^"'>])*>/s;
|
| 179 |
wakaba |
1.1 |
# [71] GEDecl = '<!ENTITY' S Name S EntityDef [S] ">"
|
| 180 |
|
|
# [72] PEDecl = '<!ENTITY' S "%" S Name S PEDef [S] ">"
|
| 181 |
|
|
# [73] EntityDef = EntityValue / ExternalID [NDataDecl]
|
| 182 |
|
|
# [74] PEDef = EntityValue / ExternalID
|
| 183 |
|
|
# [75] ExternalID = 'SYSTEM' S SystemLiteral / 'PUBLIC' S PublicLiteral S SystemLiteral
|
| 184 |
|
|
# [76] NDataDecl = S 'NDATA' S Name
|
| 185 |
|
|
# [77] TextDecl = '?xml' [VersionInfo] EncodingDecl [S] "?>"
|
| 186 |
|
|
# [78] extParsedEnt = [TextDecl] content
|
| 187 |
|
|
# [79] extPE ;; 1.0 FE (removed by errata)
|
| 188 |
|
|
# [80] EncodingDecl = S 'encoding' Eq (<"> EncName <"> / "'" EncName "'")
|
| 189 |
|
|
# [81] EncName = ALPHA *(ALPHA / DIGIT / "." / "_" / "-")
|
| 190 |
|
|
# [82] NotationDecl = '<!NOTATION' S Name S (ExternalID / PublicID) [S] ">"
|
| 191 |
wakaba |
1.6 |
#$xml_re{__NotationDecl_simple} = qr/<!NOTATION(?:$xml_re{__AttValue_simple}|[^"'>])*>/s;
|
| 192 |
wakaba |
1.1 |
# [83] PublicID = 'PUBLIC' S PubidLiteral
|
| 193 |
|
|
# [84] Letter = BaseChar / Ideographic
|
| 194 |
|
|
# [85] Basechar = ...
|
| 195 |
|
|
# [86] Ideographic = ...
|
| 196 |
|
|
# [87] CombiningChar = ...
|
| 197 |
|
|
# [88] Digit = ...
|
| 198 |
|
|
# [89] Extender = U+00B7 / U+02D0 / U+02D1 / U+0387 / U+0640 / U+0E46 / U+0EC6
|
| 199 |
|
|
# / U+3005 / U+3031-U+3035 / U+309D / U+309E / U+30FC-U+30FE
|
| 200 |
|
|
## [84]-[89] removed by 1.1
|
| 201 |
|
|
|
| 202 |
|
|
# [XMLNames]
|
| 203 |
|
|
# [1] NSAttName = PrefixedAttName / DefaultAttName
|
| 204 |
|
|
# [2] PrefixedAttName = 'xmlns:' NCName
|
| 205 |
|
|
# [3] DefaultAttName = 'xmlns'
|
| 206 |
|
|
# [4] NCName = (Letter / "_") *NCNameChar ;; 1.0
|
| 207 |
|
|
# [4] NCName = NCNameStartChar *NCNameChar ;; 1.1
|
| 208 |
|
|
# [5] NCNameChar = Letter / Digit / "." / "-" / "_" / CombiningChar / Extender ;; 1.0
|
| 209 |
|
|
# [5] NCNameChar = NameChar - ":" ;; 1.1
|
| 210 |
|
|
# [5a] NCNameStartChar = NameStartChar - ":" ;; 1.1
|
| 211 |
|
|
# [6] QName = [Prefix ":"] LocalPart ;; 1.0
|
| 212 |
|
|
# [6] QName = PrefixedName / UnprefixedName ;; 1.1
|
| 213 |
|
|
# [6a] PrefixedName = Prefix ":" LocalPart ;; 1.1
|
| 214 |
|
|
# [6b] UnprefixedName = LocalPart ;; 1.1
|
| 215 |
|
|
# [7] Prefix = NCName
|
| 216 |
|
|
# [8] LocalPart = NCName
|
| 217 |
|
|
# [9] STag = "<" QName *(S Attribute) [S] ">"
|
| 218 |
wakaba |
1.4 |
#$xml_re{__NCSTag} = qr/<$xml_re{QName}(?:$xml_re{s}$xml_re{Attribute})*(?:$xml_re{s})?>/s;
|
| 219 |
wakaba |
1.1 |
# [10] ETag = "</" QName [S] ">"
|
| 220 |
wakaba |
1.4 |
#$xml_re{__NCETag} = qr!</$xml_re{QName}(?:$xml_re{s})?>!s;
|
| 221 |
wakaba |
1.1 |
# [11] EmptyElemTag = "<" QName *(S Attribute) [S] "/>"
|
| 222 |
|
|
# [12] Attribute = NSAttName Eq AttValue / QName Eq AttValue
|
| 223 |
|
|
# [13] doctypedecl = '<!DOCTYPE' S QName [S ExternalID] [S]
|
| 224 |
|
|
# ["[" *(markupdecl / PEReference / S) "]" [S]] ">"
|
| 225 |
|
|
# [14] elementdecl = '<!ELEMENT' S QName S contentspec [S] ">"
|
| 226 |
|
|
# [15] cp = (QName / choice / sep) ["?" / "*" / "+"]
|
| 227 |
|
|
# [16] Mixed = "(" [S] '#PCDATA' *([S] "|" [S] QName) [S] ")*" / "(" [S] '#PCDATA' [S] ")"
|
| 228 |
|
|
# [17] AttlistDecl = '<!ATTLIST' S QName *AttDef [S] ">"
|
| 229 |
|
|
# [18] AttDef = S (QName / NSAttName) S AttType S DefaultDecl
|
| 230 |
|
|
# [19] Name = NameStartChar *NameChar ;; 1.1 draft
|
| 231 |
|
|
# [20] NameChar = {XML1.1}.NameChar ;; 1.1 draft
|
| 232 |
|
|
# [21] NameStartChar = {XML1.1}.NameStartChar ;; 1.1 draft
|
| 233 |
|
|
|
| 234 |
|
|
|
| 235 |
wakaba |
1.4 |
sub new ($;%) {
|
| 236 |
wakaba |
1.7 |
my $class = shift;
|
| 237 |
|
|
my $self = bless {@_}, $class;
|
| 238 |
wakaba |
1.4 |
$self;
|
| 239 |
wakaba |
1.1 |
}
|
| 240 |
|
|
|
| 241 |
wakaba |
1.7 |
sub parse_text ($$;$%) {
|
| 242 |
|
|
my ($self, $s, $o, %opt) = @_;
|
| 243 |
wakaba |
1.6 |
$o ||= {line => 0, pos => 0, entity_type => 'document_entity',
|
| 244 |
wakaba |
1.7 |
uri => $self->{option}->{document_entity_uri}};
|
| 245 |
wakaba |
1.12 |
my $r = Message::Markup::XML->new (type => '#document');
|
| 246 |
wakaba |
1.7 |
$r->base_uri ($self->{option}->{document_entity_base_uri})
|
| 247 |
|
|
if defined $self->{option}->{document_entity_base_uri};
|
| 248 |
|
|
unless ($opt{entMan}) {
|
| 249 |
|
|
$opt{entMan} = $r->_get_entity_manager;
|
| 250 |
|
|
$opt{entMan}->option (uri_resolver => $self->{option}->{uri_resolver});
|
| 251 |
|
|
$opt{entMan}->option (error_handler => $self->{option}->{error_handler});
|
| 252 |
|
|
} else {
|
| 253 |
|
|
$opt{entMan}->set_root_node ($r);
|
| 254 |
|
|
}
|
| 255 |
|
|
$r->flag (smxp__entity_manager => $opt{entMan});
|
| 256 |
wakaba |
1.6 |
|
| 257 |
|
|
## Line-break normalization
|
| 258 |
|
|
$s =~ s/\x0D\x0A/\x0A/g;
|
| 259 |
|
|
$s =~ tr/\x0D/\x0A/;
|
| 260 |
|
|
|
| 261 |
wakaba |
1.2 |
## NOTE: Even if there are more than one non-XML-Char, error is raised only one time.
|
| 262 |
|
|
$self->_warn_char_val ($self->_make_clone_of ($o), $s);
|
| 263 |
wakaba |
1.6 |
if ($s =~ s/^($xml_re{_xml_PI_M})//s) { # <?xml?>
|
| 264 |
|
|
my ($data, $all) = ($2, $1);
|
| 265 |
|
|
$self->_clp (_____ => $o);
|
| 266 |
|
|
if (length ($data)) {
|
| 267 |
|
|
$self->_clp (_ => $o); # <?xml* *ver...?>
|
| 268 |
|
|
$self->_parse_xml_declaration ($r->append_new_node (type => '#pi',
|
| 269 |
|
|
local_name => 'xml'), $data, $o);
|
| 270 |
|
|
} else {
|
| 271 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_XML_DECLARE_NO_ATTR');
|
| 272 |
|
|
$r->append_new_node (type => '#pi', local_name => 'xml')
|
| 273 |
|
|
->set_attribute (version => '1.0');
|
| 274 |
|
|
}
|
| 275 |
|
|
$self->_clp (__ => $o);
|
| 276 |
wakaba |
1.1 |
}
|
| 277 |
wakaba |
1.14 |
$self->_parse_document_entity ($r, \$s, $o, %opt);
|
| 278 |
wakaba |
1.5 |
wantarray ? ($r, $o) : $r;
|
| 279 |
|
|
}
|
| 280 |
|
|
|
| 281 |
|
|
sub _parse_document_entity ($$\$$;%) {
|
| 282 |
|
|
my ($self, $c, $s, $o, %opt) = @_;
|
| 283 |
|
|
$o->{entity_type} = 'document_entity';
|
| 284 |
|
|
my %occur;
|
| 285 |
w |
1.9 |
my $entMan = $opt{entMan};
|
| 286 |
wakaba |
1.14 |
my $no_doctype = sub {
|
| 287 |
|
|
my ($o) = @_;
|
| 288 |
|
|
$self->_raise_error ($o, c => $c, type => 'WARN_DOCTYPE_NOT_FOUND');
|
| 289 |
|
|
if ($opt{alt_dtd_external_subset}) {
|
| 290 |
|
|
my $D = $c->append_new_node (type => '#declaration', namespace_uri => $NS{SGML}.'doctype');
|
| 291 |
|
|
$opt{entMan}->set_doctype_node ($D);
|
| 292 |
|
|
$D->set_attribute (SYSTEM => $opt{alt_dtd_external_subset});
|
| 293 |
|
|
$self->_raise_error ($o, type => 'MSG_EXTERNAL_DTD_SUBSET_USED',
|
| 294 |
|
|
t => [$opt{alt_dtd_external_subset}]);
|
| 295 |
|
|
$self->_parse_dtd_external_subset ($o, $D, \%opt);
|
| 296 |
|
|
}
|
| 297 |
|
|
};
|
| 298 |
wakaba |
1.5 |
while ($$s) {
|
| 299 |
wakaba |
1.6 |
if ($$s =~ /^<$xml_re{Name}/) { # <element/>
|
| 300 |
wakaba |
1.14 |
&$no_doctype ($o) unless $occur{doctype};
|
| 301 |
|
|
$self->_parse_element_content ($c, $s, $o, entMan => $opt{entMan});
|
| 302 |
wakaba |
1.5 |
$occur{element} = 1; $occur{pi} = 0;
|
| 303 |
|
|
} elsif ($$s =~ s/^($xml_re{s})//s) { # s
|
| 304 |
|
|
$c->append_text ($1);
|
| 305 |
|
|
$self->_clp ($1 => $o);
|
| 306 |
|
|
} elsif ($$s =~ s/^<!DOCTYPE//) {
|
| 307 |
|
|
my $D = $c->append_new_node (type => '#declaration', namespace_uri => $NS{SGML}.'doctype');
|
| 308 |
wakaba |
1.6 |
$entMan->set_doctype_node ($D);
|
| 309 |
wakaba |
1.5 |
$self->_clp (_________ => $o);
|
| 310 |
wakaba |
1.6 |
if ($$s =~ s/^($xml_re{s}($xml_re{Name}))//s) {
|
| 311 |
|
|
$D->set_attribute (qname => $2);
|
| 312 |
|
|
$occur{doctype} = $2;
|
| 313 |
|
|
$self->_clp ($1 => $o);
|
| 314 |
wakaba |
1.2 |
} else {
|
| 315 |
wakaba |
1.5 |
$occur{doctype} = 1;
|
| 316 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_DOCTYPE_NAME_NOT_FOUND', c => $D);
|
| 317 |
wakaba |
1.1 |
}
|
| 318 |
wakaba |
1.5 |
my $have_sysid = 0;
|
| 319 |
|
|
if ($$s =~ s/^($xml_re{s}PUBLIC)//s) {
|
| 320 |
|
|
$self->_clp ($1 => $o);
|
| 321 |
|
|
if ($$s =~ s/^($xml_re{s})($xml_re{__AttValue_simple})//s) {
|
| 322 |
|
|
$self->_clp ($1 => $o);
|
| 323 |
|
|
my $pid = $2; $pid = substr ($pid, 1, length ($pid) - 2);
|
| 324 |
|
|
$D->set_attribute (PUBLIC => $entMan->check_public_id ($o, $pid));
|
| 325 |
|
|
$self->_clp ($2 => $o);
|
| 326 |
|
|
$have_sysid = 1;
|
| 327 |
|
|
} else {
|
| 328 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_DOCTYPE_PID_LITERAL_NOT_FOUND', c => $D);
|
| 329 |
|
|
}
|
| 330 |
|
|
} elsif ($$s =~ s/^($xml_re{s}SYSTEM)//s) {
|
| 331 |
|
|
$self->_clp ($1 => $o);
|
| 332 |
|
|
$have_sysid = 2;
|
| 333 |
|
|
}
|
| 334 |
|
|
if ($have_sysid) {
|
| 335 |
|
|
if ($$s =~ s/^($xml_re{s})($xml_re{__AttValue_simple})//s) {
|
| 336 |
|
|
$self->_clp ($1 => $o);
|
| 337 |
|
|
$entMan ||= $c->_get_entity_manager;
|
| 338 |
|
|
my $sid = $2; $sid = substr ($sid, 1, length ($sid) - 2);
|
| 339 |
|
|
$D->set_attribute (SYSTEM => $entMan->check_system_id ($o, $sid));
|
| 340 |
|
|
$self->_clp ($2 => $o);
|
| 341 |
|
|
} elsif ($have_sysid) {
|
| 342 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_DOCTYPE_SYSID_LITERAL_NOT_FOUND', c => $D);
|
| 343 |
|
|
$D->set_attribute (SYSTEM => $NS{internal_invalid_sysid}) if $have_sysid == 1;
|
| 344 |
|
|
undef $have_sysid if $have_sysid == 2;
|
| 345 |
|
|
}
|
| 346 |
|
|
}
|
| 347 |
wakaba |
1.14 |
if ($opt{alt_dtd_external_subset}) {
|
| 348 |
|
|
$D->remove_attribute ('PUBLIC');
|
| 349 |
|
|
$D->set_attribute (SYSTEM => $opt{alt_dtd_external_subset});
|
| 350 |
|
|
$self->_raise_error ($o, type => 'MSG_EXTERNAL_DTD_SUBSET_USED',
|
| 351 |
|
|
t => [$opt{alt_dtd_external_subset}]);
|
| 352 |
|
|
$have_sysid = 1;
|
| 353 |
|
|
}
|
| 354 |
wakaba |
1.5 |
## dso for the internal subset
|
| 355 |
w |
1.8 |
if ($$s =~ s/^((?:$xml_re{s})?\[)//s) {
|
| 356 |
wakaba |
1.5 |
$self->_clp ($1 => $o);
|
| 357 |
w |
1.8 |
$self->_parse_dtd ($D, $s, $o, return_with_dsc => 1, validate_notation_declared => 1,
|
| 358 |
wakaba |
1.14 |
entMan => $opt{entMan});
|
| 359 |
wakaba |
1.5 |
## dsc and mdo is processed by _parse_dtd
|
| 360 |
|
|
} elsif ($$s =~ s/^((?:$xml_re{s})?>)//s) {
|
| 361 |
|
|
$self->_clp ($1 => $o);
|
| 362 |
wakaba |
1.1 |
} else {
|
| 363 |
wakaba |
1.5 |
$self->_raise_error ($o, type => 'SYNTAX_END_OF_MARKUP_NOT_FOUND', c => $D, t => $D);
|
| 364 |
|
|
}
|
| 365 |
|
|
## Read and parse the external subset
|
| 366 |
wakaba |
1.14 |
$self->_parse_dtd_external_subset ($o, $D, \%opt) if $have_sysid;
|
| 367 |
wakaba |
1.5 |
} elsif ($$s =~ s/^$xml_re{PI_M}//s) { # <?pi?> ## TODO: pi parsing
|
| 368 |
|
|
## PI before DOCTYPE declaration
|
| 369 |
wakaba |
1.2 |
my ($target, $data, $all) = ($1, $2, $&);
|
| 370 |
|
|
if ($target eq 'xml') {
|
| 371 |
wakaba |
1.4 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_XML_DECLARE_POSITION');
|
| 372 |
wakaba |
1.1 |
} else {
|
| 373 |
wakaba |
1.5 |
$c->append_new_node (type => '#pi', local_name => $target, value => $data)
|
| 374 |
|
|
->flag (smxp__src_pos => $self->_make_clone_of ($o));
|
| 375 |
|
|
$self->_clp ($all => $o);
|
| 376 |
wakaba |
1.1 |
}
|
| 377 |
wakaba |
1.5 |
$occur{pi} = 1;
|
| 378 |
|
|
} elsif ($$s =~ s/^$xml_re{Comment_M}//s) { # <!-- --> ## TODO: parse comment
|
| 379 |
wakaba |
1.2 |
$c->append_new_node (type => '#comment', value => $1);
|
| 380 |
wakaba |
1.5 |
$self->_clp ($& => $o);
|
| 381 |
|
|
$occur{comment} = 1;
|
| 382 |
wakaba |
1.1 |
} else {
|
| 383 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_INVALID_CHAR', t => substr ($$s, 0, 10));
|
| 384 |
wakaba |
1.5 |
substr ($$s, 0, 1) = '';
|
| 385 |
wakaba |
1.1 |
}
|
| 386 |
wakaba |
1.5 |
} # $$s
|
| 387 |
|
|
|
| 388 |
|
|
unless ($occur{element}) {
|
| 389 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ROOT_ELEMENT_NOT_FOUND',
|
| 390 |
|
|
t => $occur{doctype} eq '1' ? '#IMPLIED' : $occur{doctype});
|
| 391 |
wakaba |
1.14 |
&$no_doctype ($o) unless $occur{doctype};
|
| 392 |
wakaba |
1.1 |
}
|
| 393 |
wakaba |
1.5 |
if ($occur{element} && $occur{doctype}) {
|
| 394 |
|
|
my $root;
|
| 395 |
|
|
for (@{$c->child_nodes}) {
|
| 396 |
|
|
if ($_->node_type eq '#element') {
|
| 397 |
|
|
$root = $_->qname;
|
| 398 |
|
|
last;
|
| 399 |
wakaba |
1.2 |
}
|
| 400 |
wakaba |
1.1 |
}
|
| 401 |
wakaba |
1.5 |
unless ($root eq $occur{doctype}) {
|
| 402 |
|
|
$self->_raise_error ($o, type => 'VC_ROOT_ELEMENT_TYPE', c => $c,
|
| 403 |
|
|
t => [$occur{doctype}, $root]);
|
| 404 |
|
|
}
|
| 405 |
wakaba |
1.1 |
}
|
| 406 |
|
|
}
|
| 407 |
|
|
|
| 408 |
wakaba |
1.14 |
sub _parse_dtd_external_subset ($$$$) {
|
| 409 |
|
|
my ($self, $o, $D, $opt) = @_;
|
| 410 |
|
|
my $xsub = $D->set_attribute ('external-subset');
|
| 411 |
|
|
my $o2 = $self->_make_clone_of ($o);
|
| 412 |
|
|
$o2->{entity_type} = 'dtd_external_subset';
|
| 413 |
|
|
$o2->{line} = 0; $o2->{pos} = 0;
|
| 414 |
|
|
my $ext_ent = $opt->{entMan}->get_external_entity ($self, $D, $o2);
|
| 415 |
|
|
if ($ext_ent->{error}->{no_data}) { ## can't be retrived
|
| 416 |
|
|
$self->_raise_error ($o, type => 'ERR_EXT_ENTITY_NOT_FOUND', c => $D,
|
| 417 |
|
|
t => ['<!DOCTYPE>', $o2->{uri}, $ext_ent->{error}->{reason_text}]);
|
| 418 |
|
|
} else {
|
| 419 |
|
|
$xsub->base_uri ($ext_ent->{base_uri});
|
| 420 |
|
|
my $ev = $ext_ent->{text};
|
| 421 |
|
|
$self->_parse_dtd ($xsub, \$ev, $o2, entMan => $opt->{entMan});
|
| 422 |
|
|
$xsub->flag (smxp__ref_expanded => 1);
|
| 423 |
|
|
}
|
| 424 |
|
|
}
|
| 425 |
|
|
|
| 426 |
|
|
sub _parse_element_content ($$$$;%) {
|
| 427 |
wakaba |
1.5 |
my ($self, $c, $s, $o, %opt) = @_;
|
| 428 |
wakaba |
1.2 |
my $c_initial = overload::StrVal ($c);
|
| 429 |
|
|
while ($$s) {
|
| 430 |
wakaba |
1.6 |
if ($$s =~ m:^<[^!?/]:) {
|
| 431 |
|
|
if ($c->node_type eq '#document' && $self->_is_brother_of_root_element ($c)) {
|
| 432 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_DATA_OUT_OF_ROOT_ELEMENT',
|
| 433 |
|
|
t => substr ($$s, 0, 10));
|
| 434 |
wakaba |
1.2 |
}
|
| 435 |
w |
1.9 |
$c = $self->_parse_start_tag ($c, $s, $o, entMan => $opt{entMan});
|
| 436 |
wakaba |
1.2 |
} elsif ($$s =~ s/^$xml_re{ETag_M}//s) {
|
| 437 |
|
|
my $ename = $1;
|
| 438 |
wakaba |
1.6 |
if ($ename eq $c->flag ('smxp__original_qname') || $ename eq $c->qname) {
|
| 439 |
wakaba |
1.2 |
$c = $c->{parent};
|
| 440 |
|
|
} else { ## Element type name does not match
|
| 441 |
|
|
my $o_etn = $self->_make_clone_of ($o);
|
| 442 |
|
|
$o_etn->{pos} += 2;
|
| 443 |
wakaba |
1.6 |
$self->_raise_error ($o_etn, c => $c, type => 'WFC_ELEMENT_TYPE_MATCH',
|
| 444 |
|
|
t => [$ename, $c->qname]);
|
| 445 |
wakaba |
1.2 |
}
|
| 446 |
|
|
_count_lp ($&, $o);
|
| 447 |
wakaba |
1.6 |
} elsif (($c->node_type eq '#document') && ($$s =~ s/^($xml_re{s})//s)) {
|
| 448 |
|
|
$c->append_text ($1);
|
| 449 |
|
|
$self->_clp ($1 => $o);
|
| 450 |
|
|
} elsif ($$s =~ s/^($xml_re{__CharDataP})//s) {
|
| 451 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_DATA_OUT_OF_ROOT_ELEMENT', t => $1)
|
| 452 |
|
|
if $c->node_type eq '#document';
|
| 453 |
|
|
$c->append_text ($1);
|
| 454 |
|
|
$self->_clp ($1 => $o);
|
| 455 |
wakaba |
1.2 |
} elsif ($$s =~ s/^($xml_re{Reference})//s) { ## &foo; | Ӓ | ካ
|
| 456 |
|
|
my $entity_ref = $1;
|
| 457 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_DATA_OUT_OF_ROOT_ELEMENT',
|
| 458 |
|
|
t => $entity_ref) if $c->node_type eq '#document';
|
| 459 |
wakaba |
1.2 |
my $eref = $self->_parse_reference ($c, $entity_ref, $o);
|
| 460 |
wakaba |
1.6 |
unless (index ($eref->{namespace_uri}, 'char') > -1) { ## General entity reference
|
| 461 |
w |
1.9 |
my $entity = $opt{entMan}->get_entity ($eref);
|
| 462 |
wakaba |
1.2 |
if (!$entity && {qw/< 1 > 1 & 1 " 1 ' 1/}->{$entity_ref}) {
|
| 463 |
|
|
$self->_raise_error ($o, c => $c, type => 'WARN_PREDEFINED_ENTITY_NOT_DECLARED',
|
| 464 |
|
|
t => $entity_ref);
|
| 465 |
w |
1.9 |
$entity = $opt{entMan}->get_entity ($eref);
|
| 466 |
wakaba |
1.2 |
}
|
| 467 |
|
|
if (!$entity) {
|
| 468 |
wakaba |
1.6 |
$self->_raise_error ($o, t => $entity_ref,
|
| 469 |
w |
1.9 |
type => ($opt{entMan}->is_standalone_document_1?'WF':'V')
|
| 470 |
|
|
.'C_ENTITY_DECLARED');
|
| 471 |
wakaba |
1.2 |
} else {
|
| 472 |
w |
1.9 |
if ($entity->flag ('smxp__declaration_may_not_be_read')) {
|
| 473 |
wakaba |
1.5 |
$self->_raise_error ($o, type => 'WARN_EXTERNALLY_DEFINED_ENTITY_REFERRED',
|
| 474 |
|
|
t => $entity_ref);
|
| 475 |
|
|
}
|
| 476 |
wakaba |
1.2 |
my $o2 = $self->_make_clone_of ($o);
|
| 477 |
|
|
if ($o2->{__entities}->{$entity_ref}) {
|
| 478 |
|
|
$self->_raise_error ($o, type => 'WFC_NO_RECURSION', t => $entity_ref);
|
| 479 |
|
|
} else {
|
| 480 |
wakaba |
1.4 |
$o2->{entity} = $entity_ref;
|
| 481 |
wakaba |
1.2 |
my $entity_value = $entity->get_attribute ('value');
|
| 482 |
|
|
if (ref $entity_value) {
|
| 483 |
|
|
$o2->{__entities}->{$entity_ref} = 1;
|
| 484 |
wakaba |
1.5 |
$o2->{uri} = $entity->flag ('smxp__uri_in_which_declaration_is');
|
| 485 |
wakaba |
1.4 |
$o2->{line} = 0; $o2->{pos} = 0;
|
| 486 |
wakaba |
1.2 |
my $ev = $entity_value->_entity_parameter_literal_value;
|
| 487 |
w |
1.9 |
$self->_parse_element_content ($eref, \$ev, $o2, entMan => $opt{entMan});
|
| 488 |
wakaba |
1.2 |
$eref->flag (smxp__ref_expanded => 1);
|
| 489 |
wakaba |
1.4 |
} else { ## External entity
|
| 490 |
|
|
$o2->{entity_type} = 'external_general_parsed_entity';
|
| 491 |
w |
1.9 |
my $ext_ent = $opt{entMan}->get_external_entity ($self, $entity, $o2);
|
| 492 |
wakaba |
1.4 |
if ($ext_ent->{NDATA}) { ## non-parsed entity
|
| 493 |
wakaba |
1.6 |
$self->_raise_error ($o, type => 'WFC_PARSED_ENTITY',
|
| 494 |
|
|
c => $entity, t => $entity_ref);
|
| 495 |
wakaba |
1.4 |
} elsif ($ext_ent->{error}->{no_data}) { ## parsed entity but can't be retrived
|
| 496 |
|
|
$self->_raise_error ($o, type => 'ERR_EXT_ENTITY_NOT_FOUND', c => $entity,
|
| 497 |
|
|
t => [$entity_ref, $o2->{uri},
|
| 498 |
|
|
$ext_ent->{error}->{reason_text}]);
|
| 499 |
|
|
} else { ## parsed entity
|
| 500 |
|
|
$o2->{__entities}->{$entity_ref} = 1;
|
| 501 |
|
|
$eref->base_uri ($ext_ent->{base_uri});
|
| 502 |
|
|
my $ev = $ext_ent->{text};
|
| 503 |
w |
1.9 |
$self->_parse_element_content ($eref, \$ev, $o2, entMan => $opt{entMan});
|
| 504 |
wakaba |
1.4 |
$eref->flag (smxp__ref_expanded => 1);
|
| 505 |
|
|
}
|
| 506 |
wakaba |
1.2 |
}
|
| 507 |
|
|
}
|
| 508 |
|
|
}
|
| 509 |
|
|
} # if &foo;
|
| 510 |
wakaba |
1.6 |
} elsif ($$s =~ s/^($xml_re{CDSect_M})//s) {
|
| 511 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_DATA_OUT_OF_ROOT_ELEMENT', t => '<![')
|
| 512 |
|
|
if $c->node_type eq '#document';
|
| 513 |
|
|
$c->append_new_node (type => '#section', value => $2)
|
| 514 |
wakaba |
1.5 |
->set_attribute (status => 'CDATA');
|
| 515 |
wakaba |
1.6 |
$self->_clp ($1 => $o);
|
| 516 |
|
|
} elsif ($$s =~ s/^$xml_re{Comment_M}//s) { ## TODO:
|
| 517 |
wakaba |
1.2 |
$c->append_new_node (type => '#comment', value => $1);
|
| 518 |
|
|
_count_lp ($&, $o);
|
| 519 |
wakaba |
1.6 |
} elsif ($$s =~ s/^($xml_re{PI_M})//s) { ## TODO: warn unless declared
|
| 520 |
|
|
my ($target, $data, $all) = ($2, $3, $1);
|
| 521 |
wakaba |
1.2 |
if ($target eq 'xml') {
|
| 522 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_XML_DECLARE_POSITION');
|
| 523 |
wakaba |
1.2 |
} else {
|
| 524 |
wakaba |
1.6 |
$c->append_new_node (type => '#pi', local_name => $target, value => $data);
|
| 525 |
|
|
$self->_clp ($all => $o);
|
| 526 |
wakaba |
1.2 |
}
|
| 527 |
|
|
} else {
|
| 528 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_INVALID_CHAR', t => substr ($$s, 0, 10));
|
| 529 |
wakaba |
1.2 |
substr ($$s, 0, 1) = '';
|
| 530 |
|
|
}
|
| 531 |
|
|
} # while $s
|
| 532 |
|
|
while ($c_initial ne overload::StrVal ($c)) {
|
| 533 |
|
|
if (ref $c->{parent}) {
|
| 534 |
|
|
if ($c->node_type eq '#element') {
|
| 535 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_END_TAG_NOT_FOUND', t => $c);
|
| 536 |
|
|
}
|
| 537 |
|
|
$c = $c->{parent};
|
| 538 |
|
|
} else {
|
| 539 |
|
|
last;
|
| 540 |
|
|
}
|
| 541 |
|
|
}
|
| 542 |
|
|
}
|
| 543 |
|
|
|
| 544 |
wakaba |
1.6 |
sub _parse_start_tag ($$\$$;%) {
|
| 545 |
|
|
my ($self, $c, $s, $o, %opt) = @_;
|
| 546 |
w |
1.9 |
my ($type_pfx, $type_lname, $type_qname);
|
| 547 |
wakaba |
1.6 |
## Element type name (general identifier)
|
| 548 |
|
|
if ($$s =~ s/^<($xml_re{Name})//) {
|
| 549 |
w |
1.9 |
$type_qname = $1;
|
| 550 |
wakaba |
1.6 |
if (substr ($type_qname, 0, 1) eq ':' || substr ($type_qname, -1, 1) eq ':') {
|
| 551 |
|
|
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_NAME_IS_QNNAME', t => $type_qname);
|
| 552 |
|
|
$type_qname =~ tr/:/_/;
|
| 553 |
|
|
}
|
| 554 |
|
|
$self->_clp ('<'.$type_qname => $o);
|
| 555 |
|
|
($type_pfx, $type_lname) = $self->_ns_parse_qname ($type_qname);
|
| 556 |
|
|
if ($type_pfx && $type_lname !~ /^\p{InXML_NameStartChar}/) {
|
| 557 |
|
|
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_LNAME_IS_NCNNAME', t => $type_lname);
|
| 558 |
|
|
$type_lname = '_' . $type_lname;
|
| 559 |
|
|
}
|
| 560 |
|
|
$c = $c->append_new_node (type => '#element', local_name => $type_lname);
|
| 561 |
|
|
$c->flag (smxp__original_qname => $type_qname);
|
| 562 |
|
|
} else {
|
| 563 |
|
|
$self->_clp (_ => $o);
|
| 564 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_INVALID_CHAR', t => substr ($$s, 0, 10));
|
| 565 |
|
|
$$s =~ s/^<//;
|
| 566 |
|
|
return $c;
|
| 567 |
|
|
}
|
| 568 |
|
|
|
| 569 |
w |
1.9 |
my $defattr = $opt{entMan}->get_attr_definitions (qname => $type_qname);
|
| 570 |
wakaba |
1.6 |
## Attribute spec list
|
| 571 |
|
|
my @attr;
|
| 572 |
|
|
my %defined_attr;
|
| 573 |
|
|
while ($$s) {
|
| 574 |
|
|
if ($$s =~ s/^($xml_re{s})($xml_re{Name})//s) {
|
| 575 |
|
|
my $attr_qname = $2;
|
| 576 |
|
|
my ($attr_pfx, $attr_lname);
|
| 577 |
|
|
my $ignore = 0;
|
| 578 |
|
|
## Isn't already defined? Is valid QName?
|
| 579 |
|
|
if ($defined_attr{$attr_qname}) {
|
| 580 |
|
|
$self->_raise_error ($o, c => $c, type => 'WFC_UNIQUE_ATT_SPEC', t => $attr_qname);
|
| 581 |
|
|
$ignore = 1;
|
| 582 |
|
|
} elsif (substr ($attr_qname, 0, 1) eq ':' || substr ($attr_qname, -1, 1) eq ':') {
|
| 583 |
|
|
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_NAME_IS_QNNAME', t => $attr_qname);
|
| 584 |
|
|
$defined_attr{$attr_qname} = 1;
|
| 585 |
|
|
$attr_qname =~ tr/:/_/; $defined_attr{$attr_qname} = 1;
|
| 586 |
|
|
($attr_pfx, $attr_lname) = (undef, $attr_qname);
|
| 587 |
|
|
} else {
|
| 588 |
|
|
$defined_attr{$attr_qname} = 1;
|
| 589 |
|
|
($attr_pfx, $attr_lname) = $self->_ns_parse_qname ($attr_qname);
|
| 590 |
|
|
}
|
| 591 |
|
|
$self->_clp ($1.$attr_qname => $o);
|
| 592 |
|
|
|
| 593 |
|
|
if ($attr_pfx && $attr_lname !~ /^\p{InXML_NameStartChar}/) {
|
| 594 |
|
|
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_LNAME_IS_NCNNAME', t => $attr_lname);
|
| 595 |
|
|
$attr_lname = '_' . $attr_lname;
|
| 596 |
|
|
}
|
| 597 |
|
|
my $attr_node = ref ($c)->new (type => '#attribute', local_name => $attr_lname);
|
| 598 |
|
|
|
| 599 |
|
|
if ($$s =~ s/^($xml_re{s})//s) {
|
| 600 |
|
|
$self->_clp ($1);
|
| 601 |
|
|
}
|
| 602 |
|
|
if ($$s =~ s/^=//) {
|
| 603 |
|
|
$self->_clp (_ => $o);
|
| 604 |
|
|
if ($$s =~ s/^($xml_re{s})//s) {
|
| 605 |
|
|
$self->_clp ($1);
|
| 606 |
|
|
}
|
| 607 |
|
|
|
| 608 |
|
|
if ($$s =~ s/^($xml_re{__AttValue_simple})//s) {
|
| 609 |
|
|
next if $ignore;
|
| 610 |
|
|
my $pcdata = substr ($1, 1, length ($1) - 2);
|
| 611 |
|
|
$self->_clp (_ => $o);
|
| 612 |
w |
1.8 |
$self->_parse_attr_value_literal_data ($attr_node, \$pcdata, $o, entMan => $opt{entMan});
|
| 613 |
wakaba |
1.6 |
$self->_clp (_ => $o);
|
| 614 |
|
|
|
| 615 |
|
|
if ($attr_pfx eq 'xmlns') {
|
| 616 |
w |
1.11 |
$c->{ns_specified}->{$attr_lname} = $attr_node;
|
| 617 |
|
|
$attr_node->namespace_uri ($NS{xmlns});
|
| 618 |
|
|
$attr_node->{parent} = $c; ## Note: This code might be dangerous.
|
| 619 |
wakaba |
1.6 |
my $ns_name = $attr_node->inner_text;
|
| 620 |
|
|
$opt{entMan}->check_ns_uri ($o, $attr_lname => $ns_name) if length $ns_name;
|
| 621 |
w |
1.11 |
## TODO: XML Names 1.1 support
|
| 622 |
|
|
$ns_name = $c->resolve_relative_uri ($ns_name) if length ($ns_name) == 0;
|
| 623 |
wakaba |
1.6 |
$c->define_new_namespace ($attr_lname => $ns_name);
|
| 624 |
|
|
} elsif (!$attr_pfx && $attr_lname eq 'xmlns') {
|
| 625 |
w |
1.11 |
$c->{ns_specified}->{''} = $attr_node;
|
| 626 |
|
|
$attr_node->{parent} = $c; ## Note: This code might be dangerous.
|
| 627 |
wakaba |
1.6 |
my $ns_name = $attr_node->inner_text;
|
| 628 |
|
|
if (length ($ns_name) || lc (substr ($ns_name, 0, 3)) eq 'xml') {
|
| 629 |
|
|
$opt{entMan}->check_ns_uri ($o, '' => $ns_name);
|
| 630 |
|
|
} else {
|
| 631 |
|
|
$self->_raise_error ($o, type => 'WARN_XML_NS_URI_IS_RELATIVE', t => $attr_qname);
|
| 632 |
|
|
}
|
| 633 |
|
|
$c->define_new_namespace ('' => $ns_name);
|
| 634 |
|
|
} else {
|
| 635 |
|
|
push @attr, [$attr_pfx => $attr_lname, $attr_node];
|
| 636 |
|
|
}
|
| 637 |
|
|
} else {
|
| 638 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTR_LITERAL_NOT_FOUND', t => $attr_qname);
|
| 639 |
|
|
$attr_node->append_text ($attr_qname);
|
| 640 |
|
|
}
|
| 641 |
|
|
} else {
|
| 642 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTR_NAME_OMITTED', t => $attr_qname);
|
| 643 |
|
|
$attr_node->append_text ($attr_qname);
|
| 644 |
|
|
}
|
| 645 |
|
|
} elsif ($$s =~ s!^($xml_re{s})?(/)?>!!s) {
|
| 646 |
|
|
$self->_clp ($1.$2.'>');
|
| 647 |
|
|
$c->option (use_EmptyElemTag => 1) if $2;
|
| 648 |
|
|
last;
|
| 649 |
|
|
} elsif ($$s =~ m/^</) {
|
| 650 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_TAG_NOT_CLOSED', t => substr ($$s, 0, 10));
|
| 651 |
|
|
last;
|
| 652 |
|
|
} else {
|
| 653 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_INVALID_CHAR', t => substr ($$s, 0, 10));
|
| 654 |
|
|
substr ($$s, 0, 1) = '';
|
| 655 |
|
|
}
|
| 656 |
|
|
} ## while
|
| 657 |
|
|
|
| 658 |
w |
1.9 |
## Default attributes
|
| 659 |
|
|
for (keys %{$defattr->{attr}}) {
|
| 660 |
|
|
unless ($defined_attr{$_}) {
|
| 661 |
|
|
my $defval = $defattr->{attr}->{$_}->get_attribute ('default_value');
|
| 662 |
|
|
if ($defval) {
|
| 663 |
|
|
my ($attr_pfx, $attr_lname) = $self->_ns_parse_qname ($_);
|
| 664 |
|
|
if ($attr_pfx eq 'xmlns') {
|
| 665 |
w |
1.11 |
$c->{ns_specified}->{$attr_lname} = 0;
|
| 666 |
w |
1.9 |
my $ns_name = $defval->inner_text;
|
| 667 |
|
|
$opt{entMan}->check_ns_uri ($o, $attr_lname => $ns_name) if length $ns_name;
|
| 668 |
|
|
if ($defattr->{attr_may_not_be_read}->{$_}
|
| 669 |
|
|
&& $c->defined_namespace_prefix ($attr_lname) ne $ns_name) {
|
| 670 |
|
|
$self->_raise_error ($o, type => 'WARN_XMLNAMES_EXTERNAL_NS_ATTR',
|
| 671 |
|
|
t => [$attr_lname => $ns_name]);
|
| 672 |
|
|
}
|
| 673 |
w |
1.11 |
## TODO: XML Names 1.1 support
|
| 674 |
|
|
$ns_name = $c->resolve_relative_uri ($ns_name) if length ($ns_name) == 0;
|
| 675 |
w |
1.9 |
$c->define_new_namespace ($attr_lname => $ns_name);
|
| 676 |
|
|
} elsif (!$attr_pfx && $attr_lname eq 'xmlns') {
|
| 677 |
w |
1.11 |
$c->{ns_specified}->{''} = 0;
|
| 678 |
w |
1.9 |
my $ns_name = $defval->inner_text;
|
| 679 |
|
|
if (length ($ns_name) || lc (substr ($ns_name, 0, 3)) eq 'xml') {
|
| 680 |
|
|
$opt{entMan}->check_ns_uri ($o, '' => $ns_name);
|
| 681 |
|
|
} else {
|
| 682 |
|
|
$self->_raise_error ($o, type => 'WARN_XML_NS_URI_IS_RELATIVE', t => $_);
|
| 683 |
|
|
}
|
| 684 |
|
|
if ($defattr->{attr_may_not_be_read}->{$_}
|
| 685 |
|
|
&& $c->defined_namespace_prefix ('') ne $ns_name) {
|
| 686 |
|
|
$self->_raise_error ($o, type => 'WARN_XMLNAMES_EXTERNAL_NS_ATTR',
|
| 687 |
|
|
t => ['#default' => $ns_name]);
|
| 688 |
|
|
}
|
| 689 |
|
|
$c->define_new_namespace ('' => $ns_name);
|
| 690 |
|
|
} else {
|
| 691 |
|
|
my $attr_node = ref ($c)->new (type => '#attribute', local_name => $attr_lname,
|
| 692 |
|
|
value => $defval->inner_text);
|
| 693 |
|
|
$attr_node->flag (smxp__is_dtd_default => 1);
|
| 694 |
|
|
if ($defattr->{attr_may_not_be_read}->{$_}) {
|
| 695 |
|
|
$self->_raise_error ($o, type => 'WARN_EXTERNAL_DEFAULT_ATTR', c => $c,
|
| 696 |
|
|
t => $_);
|
| 697 |
|
|
}
|
| 698 |
|
|
push @attr, [$attr_pfx => $attr_lname, $attr_node];
|
| 699 |
|
|
}
|
| 700 |
|
|
} # has default value
|
| 701 |
|
|
} # unspecified attr
|
| 702 |
|
|
}
|
| 703 |
|
|
|
| 704 |
wakaba |
1.6 |
## Namespace of element type name
|
| 705 |
|
|
{
|
| 706 |
|
|
my $uri = $c->defined_namespace_prefix ($type_pfx || '');
|
| 707 |
|
|
if (defined $uri) {
|
| 708 |
|
|
$c->namespace_uri ($uri);
|
| 709 |
|
|
} elsif (!$type_pfx) { ## Default
|
| 710 |
|
|
## <foo xmlns="">
|
| 711 |
|
|
$c->define_new_namespace ('' => '');
|
| 712 |
|
|
} else {
|
| 713 |
|
|
$self->_raise_error ($o, c => $c, type => 'NC_PREFIX_NOT_DEFINED', t => $type_pfx);
|
| 714 |
|
|
$c->namespace_uri ($NS{internal_ns_invalid}.$self->_uri_escape ($type_pfx));
|
| 715 |
|
|
}
|
| 716 |
|
|
}
|
| 717 |
w |
1.9 |
|
| 718 |
wakaba |
1.6 |
## Namespace of attribute name
|
| 719 |
|
|
my %ns_attr_defined;
|
| 720 |
|
|
for (@attr) {
|
| 721 |
|
|
unless ($_->[0]) { ## No prefix
|
| 722 |
|
|
$c->append_node ($_->[2]);
|
| 723 |
|
|
} else {
|
| 724 |
|
|
my $uri = $c->defined_namespace_prefix ($_->[0]);
|
| 725 |
|
|
if (defined $uri) {
|
| 726 |
|
|
if ($ns_attr_defined{$uri}->{$_->[1]}) {
|
| 727 |
|
|
$self->_raise_error ($o, c => $_->[2], type => 'NC_UNIQUE_ATT_SPEC',
|
| 728 |
|
|
t => [$_->[0].':'.$_->[1], $uri, $_->[1]]);
|
| 729 |
|
|
} else {
|
| 730 |
|
|
$_->[2]->namespace_uri ($uri);
|
| 731 |
|
|
$ns_attr_defined{$uri}->{$_->[1]} = 1;
|
| 732 |
|
|
$c->append_node ($_->[2]);
|
| 733 |
|
|
}
|
| 734 |
|
|
} else {
|
| 735 |
|
|
$self->_raise_error ($o, c => $_->[2], type => 'NC_PREFIX_NOT_DEFINED', t => $_->[0]);
|
| 736 |
|
|
$_->[1]->namespace_uri ($NS{internal_ns_invalid}.$self->_uri_escape ($_->[0]));
|
| 737 |
|
|
}
|
| 738 |
|
|
} # have prefix
|
| 739 |
|
|
}
|
| 740 |
|
|
$c->option ('use_EmptyElemTag') ? $c->parent_node : $c;
|
| 741 |
|
|
}
|
| 742 |
|
|
|
| 743 |
wakaba |
1.2 |
sub _parse_dtd ($$\$$;%) {
|
| 744 |
wakaba |
1.6 |
my ($self, $c, $s, $o, %opt) = @_;
|
| 745 |
wakaba |
1.2 |
my $c_initial = overload::StrVal ($c);
|
| 746 |
|
|
while ($$s) {
|
| 747 |
wakaba |
1.4 |
if ($$s =~ s/^($xml_re{PEReference_M})//s) {
|
| 748 |
|
|
my ($ref, $ename) = ($1, $2);
|
| 749 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_NAME_IS_NCNAME', t => $ref)
|
| 750 |
|
|
if index ($ename, ':') > -1;
|
| 751 |
w |
1.8 |
my $entity = $opt{entMan}->get_entity ($ename, namespace_uri => $NS{SGML}.'entity:parameter');
|
| 752 |
wakaba |
1.2 |
my $eref = $c->append_new_node (type => '#reference', local_name => $ename,
|
| 753 |
|
|
namespace_uri => $NS{SGML}.'entity:parameter');
|
| 754 |
wakaba |
1.6 |
if (!$entity) {
|
| 755 |
wakaba |
1.4 |
$self->_raise_error ($o, c => $c, type => 'VC_ENTITY_DECLARED', t => $ref);
|
| 756 |
wakaba |
1.2 |
} else {
|
| 757 |
|
|
my $o2 = $self->_make_clone_of ($o);
|
| 758 |
wakaba |
1.4 |
if ($o2->{__entities}->{$ref}) {
|
| 759 |
|
|
$self->_raise_error ($o, c => $c, type => 'WFC_NO_RECURSION', t => $ref);
|
| 760 |
wakaba |
1.2 |
} else {
|
| 761 |
wakaba |
1.4 |
$o2->{entity} = $ref;
|
| 762 |
wakaba |
1.2 |
my $entity_value = $entity->get_attribute ('value');
|
| 763 |
wakaba |
1.4 |
if (ref $entity_value) { ## Internal entity
|
| 764 |
|
|
$o2->{__entities}->{$ref} = 1;
|
| 765 |
wakaba |
1.5 |
$o2->{uri} = $entity->flag ('smxp__uri_in_which_declaration_is');
|
| 766 |
wakaba |
1.4 |
$o2->{line} = 0; $o2->{pos} = 0;
|
| 767 |
|
|
my $ev = $entity_value->_entity_parameter_literal_value;
|
| 768 |
w |
1.8 |
$self->_parse_dtd ($eref, \$ev, $o2, entMan => $opt{entMan});
|
| 769 |
wakaba |
1.2 |
$eref->flag (smxp__ref_expanded => 1);
|
| 770 |
wakaba |
1.4 |
} else { ## External entity
|
| 771 |
|
|
$o2->{entity_type} = 'external_parameter_entity';
|
| 772 |
w |
1.9 |
$c->root_node->flag (smxp__declaration_may_not_be_read => 1)
|
| 773 |
|
|
if !(index ($o->{entity_type}, 'external') > -1)
|
| 774 |
|
|
|| !$opt{entMan}->is_standalone_document;
|
| 775 |
w |
1.8 |
my $ext_ent = $opt{entMan}->get_external_entity ($self, $entity, $o2);
|
| 776 |
wakaba |
1.4 |
if ($ext_ent->{NDATA}) { ## non-parsed entity
|
| 777 |
|
|
$self->_raise_error ($o, type => 'WFC_PARSED_ENTITY', c => $entity, t => $ref);
|
| 778 |
|
|
} elsif ($ext_ent->{error}->{no_data}) { ## parsed entity but can't be retrived
|
| 779 |
|
|
$self->_raise_error ($o, type => 'ERR_EXT_ENTITY_NOT_FOUND', c => $entity,
|
| 780 |
|
|
t => [$ref, $o2->{uri}, $ext_ent->{error}->{reason_text}]);
|
| 781 |
wakaba |
1.6 |
## Don't process ENTITY/ATTLIST declaration any more
|
| 782 |
w |
1.8 |
$c->root_node->flag (smxp__stop_read_dtd => 1)
|
| 783 |
|
|
unless $opt{entMan}->is_standalone_document;
|
| 784 |
wakaba |
1.4 |
} else { ## parsed entity
|
| 785 |
|
|
$o2->{__entities}->{$ref} = 1;
|
| 786 |
|
|
$eref->base_uri ($ext_ent->{base_uri});
|
| 787 |
|
|
my $ev = $ext_ent->{text};
|
| 788 |
w |
1.8 |
$self->_parse_dtd ($eref, \$ev, $o2, entMan => $opt{entMan});
|
| 789 |
wakaba |
1.4 |
$eref->flag (smxp__ref_expanded => 1);
|
| 790 |
wakaba |
1.6 |
} # external parsed entity
|
| 791 |
|
|
} # external entity
|
| 792 |
wakaba |
1.2 |
} # not recursive
|
| 793 |
|
|
} # entity defined
|
| 794 |
wakaba |
1.6 |
$self->_clp ($ref => $o);
|
| 795 |
wakaba |
1.5 |
} elsif ($$s =~ s/^($xml_re{s})//s) {
|
| 796 |
|
|
$c->append_text ($1);
|
| 797 |
|
|
$self->_clp ($1 => $o);
|
| 798 |
wakaba |
1.6 |
} elsif ($$s =~ s/^($xml_re{Comment_M})//s) { ## TODO: reimple
|
| 799 |
|
|
$c->append_new_node (type => '#comment', value => $2);
|
| 800 |
|
|
$self->_clp ($1 => $o);
|
| 801 |
wakaba |
1.5 |
} elsif ($$s =~ m/^<!(?:ENTITY|NOTATION)(?:$xml_re{s}|%)/s) {
|
| 802 |
w |
1.8 |
$self->_parse_entity_declaration ($s, $c, $o, entMan => $opt{entMan});
|
| 803 |
|
|
} elsif ($$s =~ m/^<!ELEMENT(?:$xml_re{s}|%)/s) {
|
| 804 |
|
|
$self->_parse_element_declaration ($s, $c, $o, entMan => $opt{entMan});
|
| 805 |
|
|
} elsif ($$s =~ m/^<!ATTLIST(?:$xml_re{s}|%)/s) {
|
| 806 |
|
|
$self->_parse_attlist_declaration ($s, $c, $o, entMan => $opt{entMan});
|
| 807 |
wakaba |
1.5 |
## Markup section start (= mdo + mso)
|
| 808 |
|
|
} elsif ($$s =~ s/^<!\[//) {
|
| 809 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_MS_IN_INTERNAL_SUBSET')
|
| 810 |
|
|
if $o->{entity_type} eq 'document_entity';
|
| 811 |
wakaba |
1.5 |
$self->_clp (___ => $o);
|
| 812 |
|
|
## Status keyword list
|
| 813 |
|
|
if ($$s =~ s/^([^[]+)\[//s) {
|
| 814 |
|
|
my $skl = $1;
|
| 815 |
|
|
my $ms = $c->append_new_node (type => '#section');
|
| 816 |
|
|
my ($status, @params);
|
| 817 |
w |
1.8 |
my $t = $self->_parse_md_params ($ms->set_attribute ('status_list'), \$skl, $o,
|
| 818 |
|
|
entMan => $opt{entMan});
|
| 819 |
w |
1.11 |
if ($t =~ /^(?:$xml_re{s})?(IGNORE|INCLUDE)(?:$xml_re{s})?$/s) {
|
| 820 |
wakaba |
1.6 |
$status = $1;
|
| 821 |
|
|
} else {
|
| 822 |
|
|
$self->_raise_error ($o, c => $ms, type => 'SYNTAX_MS_INVALID_STATUS_STRING', t => $t);
|
| 823 |
|
|
$status = index ($t, 'IGNORE') > -1 ? 'IGNORE' : 'INCLUDE';
|
| 824 |
wakaba |
1.5 |
}
|
| 825 |
wakaba |
1.6 |
$self->_clp ('[' => $o);
|
| 826 |
|
|
$self->_raise_error ($o, c => $ms, type => 'SYNTAX_MS_NO_STATUS_KEYWORD') unless $status;
|
| 827 |
wakaba |
1.5 |
$ms->set_attribute (status => ($status || 'INCLUDE'));
|
| 828 |
wakaba |
1.6 |
## Content and markup section end
|
| 829 |
wakaba |
1.5 |
if ($status eq 'INCLUDE') {
|
| 830 |
w |
1.8 |
$self->_parse_dtd ($ms, $s, $o, return_with_mse => 1, entMan => $opt{entMan});
|
| 831 |
wakaba |
1.5 |
} else {
|
| 832 |
|
|
$self->_parse_ignored_marked_section ($ms, $s, $o);
|
| 833 |
|
|
}
|
| 834 |
wakaba |
1.6 |
} else { ## Fatal error: Status keyword not found
|
| 835 |
wakaba |
1.5 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_MS_NO_STATUS');
|
| 836 |
wakaba |
1.6 |
## Note: parse as a section is stopped (following is parsed as DTD)
|
| 837 |
wakaba |
1.5 |
}
|
| 838 |
|
|
## Markup section end (= msc + mdc)
|
| 839 |
|
|
} elsif ($opt{return_with_mse} && $$s =~ s/^\]\]>//) {
|
| 840 |
|
|
$self->_clp (___ => $o);
|
| 841 |
|
|
last;
|
| 842 |
wakaba |
1.6 |
## DOCTYPE declaration end
|
| 843 |
|
|
} elsif ($opt{return_with_dsc} && $$s =~ s/^(\](?:$xml_re{s})?>)//s) {
|
| 844 |
|
|
$self->_clp ($1 => $o);
|
| 845 |
wakaba |
1.2 |
$c = $c->{parent};
|
| 846 |
wakaba |
1.3 |
last;
|
| 847 |
wakaba |
1.6 |
} elsif ($$s =~ s/^($xml_re{PI_M})//s) {
|
| 848 |
|
|
my ($target, $data, $all) = ($2, $3, $1);
|
| 849 |
wakaba |
1.2 |
if ($target eq 'xml') {
|
| 850 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_XML_DECLARE_POSITION');
|
| 851 |
wakaba |
1.2 |
} else {
|
| 852 |
wakaba |
1.5 |
$c->append_new_node (type => '#pi', local_name => $target, value => $data)
|
| 853 |
|
|
->flag (smxp__src_pos => $self->_make_clone_of ($o));
|
| 854 |
wakaba |
1.6 |
## Notation declared warning is checked after rest of the DTD is read
|
| 855 |
wakaba |
1.2 |
}
|
| 856 |
wakaba |
1.6 |
$self->_clp ($all => $o);
|
| 857 |
wakaba |
1.2 |
} else {
|
| 858 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_INVALID_CHAR', t => substr ($$s, 0, 10));
|
| 859 |
wakaba |
1.2 |
substr ($$s, 0, 1) = '';
|
| 860 |
wakaba |
1.6 |
$self->_clp (_ => $o);
|
| 861 |
wakaba |
1.2 |
}
|
| 862 |
|
|
} # while $$s
|
| 863 |
wakaba |
1.5 |
while (overload::StrVal ($c_initial) ne overload::StrVal ($c)) {
|
| 864 |
wakaba |
1.2 |
if (ref $c->{parent}) {
|
| 865 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_END_OF_MARKUP_NOT_FOUND', t => $c);
|
| 866 |
|
|
$c = $c->{parent};
|
| 867 |
|
|
} else {
|
| 868 |
|
|
last;
|
| 869 |
|
|
}
|
| 870 |
wakaba |
1.3 |
} # while
|
| 871 |
wakaba |
1.5 |
}
|
| 872 |
|
|
|
| 873 |
wakaba |
1.2 |
|
| 874 |
w |
1.8 |
sub _parse_attr_value_literal_data ($$\$$;%) {
|
| 875 |
|
|
my ($self, $c, $s, $o, %opt) = @_;
|
| 876 |
|
|
my $rt = '';
|
| 877 |
|
|
while ($$s) {
|
| 878 |
|
|
if ($$s =~ s/^&#(?:x([0-9A-Fa-f]+)|([0-9]+));//) {
|
| 879 |
|
|
my $char = chr (defined $1 ? hex $1 : 0 + $2);
|
| 880 |
|
|
$self->_warn_char_val ($o, $char, ref => 1);
|
| 881 |
|
|
$c->append_new_node (type => '#reference', value => ord $char,
|
| 882 |
|
|
namespace_uri => $NS{SGML}.'char:ref'.(defined $1?':hex':''));
|
| 883 |
|
|
$rt .= $char;
|
| 884 |
|
|
} elsif ($$s =~ s/^(&($xml_re{Name});)//) {
|
| 885 |
|
|
my ($ename, $entity_ref) = ($2, $1);
|
| 886 |
|
|
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_NAME_IS_NCNAME', t => $ename)
|
| 887 |
|
|
if index ($ename, ':') > -1;
|
| 888 |
|
|
my $eref_node = $c->append_new_node (type => '#reference', local_name => $ename,
|
| 889 |
|
|
namespace_uri => $NS{SGML}.'entity');
|
| 890 |
|
|
my $entity = $opt{entMan}->get_entity ($ename, dont_use_predefined_entities => 1);
|
| 891 |
|
|
if (!$entity && {qw/< 1 > 1 & 1 " 1 ' 1/}->{$entity_ref}) {
|
| 892 |
|
|
$self->_raise_error ($o, c => $eref_node, type => 'WARN_PREDEFINED_ENTITY_NOT_DECLARED',
|
| 893 |
|
|
t => $entity_ref);
|
| 894 |
|
|
$entity = $opt{entMan}->get_entity ($ename);
|
| 895 |
wakaba |
1.1 |
}
|
| 896 |
w |
1.8 |
if (!$entity) {
|
| 897 |
|
|
$self->_raise_error ($o, c => $eref_node,
|
| 898 |
|
|
type => ($opt{entMan}->is_standalone_document_1?
|
| 899 |
|
|
'WF':'V').'C_ENTITY_DECLARED',
|
| 900 |
|
|
t => $entity_ref);
|
| 901 |
|
|
$rt .= $entity_ref;
|
| 902 |
wakaba |
1.1 |
} else {
|
| 903 |
w |
1.8 |
my $o2 = $self->_make_clone_of ($o);
|
| 904 |
|
|
if ($o2->{__entities}->{$entity_ref}) {
|
| 905 |
|
|
$self->_raise_error ($o, c => $eref_node, type => 'WFC_NO_RECURSION', t => $entity_ref);
|
| 906 |
|
|
$rt .= $entity_ref;
|
| 907 |
wakaba |
1.2 |
} else {
|
| 908 |
w |
1.8 |
my $entity_value = $entity->get_attribute ('value');
|
| 909 |
|
|
if (ref $entity_value) {
|
| 910 |
|
|
$o2->{__entities}->{$entity_ref} = 1;
|
| 911 |
|
|
$o2->{uri} = $entity->flag ('smxp__uri_in_which_declaration_is');
|
| 912 |
|
|
$o2->{entity} = $entity_ref; $o2->{line} = 0; $o2->{pos} = 0;
|
| 913 |
|
|
my $ev = $entity_value->_entity_parameter_literal_value;
|
| 914 |
|
|
$rt .= $self->_parse_attr_value_literal_data ($eref_node, \$ev, $o2,
|
| 915 |
|
|
entMan => $opt{entMan});
|
| 916 |
|
|
$eref_node->flag (smxp__ref_expanded => 1);
|
| 917 |
wakaba |
1.2 |
} else {
|
| 918 |
w |
1.8 |
$self->_raise_error ($o, type => 'WFC_NO_EXTERNAL_ENTITY_REFERENCE',
|
| 919 |
|
|
c => $eref_node, t => $entity_ref);
|
| 920 |
|
|
$rt .= $entity_ref;
|
| 921 |
wakaba |
1.2 |
}
|
| 922 |
w |
1.8 |
} # ref recursive?
|
| 923 |
|
|
} # entity declared or not declared
|
| 924 |
|
|
$self->_clp ($entity_ref => $o);
|
| 925 |
|
|
} elsif ($$s =~ s/^([^&<]+)//s) {
|
| 926 |
|
|
my $tt = $1;
|
| 927 |
|
|
$tt =~ tr/\x09\x0A\x0D/\x20\x20\x20/;
|
| 928 |
|
|
$c->append_text ($tt);
|
| 929 |
|
|
$rt .= $tt;
|
| 930 |
|
|
$self->_clp ($tt => $o);
|
| 931 |
wakaba |
1.2 |
} elsif ($$s =~ s/^<//) {
|
| 932 |
w |
1.8 |
$self->_raise_error ($o, c => $c, type => 'WFC_NO_LE_IN_ATTRIBUTE_VALUE');
|
| 933 |
|
|
$rt .= '<';
|
| 934 |
wakaba |
1.1 |
} else {
|
| 935 |
w |
1.8 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_INVALID_CHAR', t => substr ($$s, 0, 10));
|
| 936 |
|
|
$rt .= substr ($$s, 0, 1);
|
| 937 |
wakaba |
1.2 |
substr ($$s, 0, 1) = '';
|
| 938 |
wakaba |
1.1 |
}
|
| 939 |
w |
1.8 |
} # $$s
|
| 940 |
w |
1.9 |
## Note: Implementation of normalize for non-CDATA attribute values should be done
|
| 941 |
|
|
## out of this module.
|
| 942 |
|
|
#if ({qw/ID 1 IDREF 1 IDREFS 1 NMTOKEN 1 NMTOKENS 1
|
| 943 |
|
|
# NOTATION 1 NOTATIONS 1/}->{$opt{attr_type}}) {
|
| 944 |
|
|
# $rt =~ s/\x20\x20+/\x20/g;
|
| 945 |
|
|
# $rt =~ s/^\x20+//; $rt =~ s/\x20+$//;
|
| 946 |
|
|
#}
|
| 947 |
w |
1.8 |
$rt;
|
| 948 |
wakaba |
1.1 |
}
|
| 949 |
wakaba |
1.2 |
|
| 950 |
wakaba |
1.5 |
sub _parse_rpdata ($$\$$;%) {
|
| 951 |
|
|
my ($self, $c, $s, $o, %opt) = @_;
|
| 952 |
wakaba |
1.6 |
my $entMan = $opt{entMan} || $c->root_node->flag ('smxp__entity_manager');
|
| 953 |
|
|
my $tt = '';
|
| 954 |
wakaba |
1.2 |
while ($$s) {
|
| 955 |
|
|
if ($$s =~ s/^($xml_re{PEReference_M})//) {
|
| 956 |
|
|
my ($ref, $ename) = ($1, $2);
|
| 957 |
wakaba |
1.6 |
$self->_raise_error ($o, type => 'WFC_PE_IN_INTERNAL_SUBSET', t => $ref)
|
| 958 |
|
|
if $o->{entity_type} eq 'document_entity';
|
| 959 |
|
|
$self->_raise_error ($o, type => 'NS_SYNTAX_NAME_IS_NCNAME', t => $ref)
|
| 960 |
|
|
if index ($ename, ':') > -1;
|
| 961 |
wakaba |
1.2 |
my $eref = $c->append_new_node (type => '#reference', local_name => $ename,
|
| 962 |
|
|
namespace_uri => $NS{SGML}.'entity:parameter');
|
| 963 |
wakaba |
1.5 |
unless ($opt{dont_resolve_entity_ref}) {
|
| 964 |
|
|
my $entity = $entMan->get_entity ($ename, namespace_uri => $NS{SGML}.'entity:parameter');
|
| 965 |
|
|
if (!$entity) {
|
| 966 |
|
|
$self->_raise_error ($o, c => $c, type => 'VC_ENTITY_DECLARED', t => $ref);
|
| 967 |
wakaba |
1.2 |
} else {
|
| 968 |
wakaba |
1.5 |
my $o2 = $self->_make_clone_of ($o);
|
| 969 |
|
|
if ($o2->{__entities}->{$ref}) {
|
| 970 |
|
|
$self->_raise_error ($o, c => $c, type => 'WFC_NO_RECURSION', t => $ref);
|
| 971 |
wakaba |
1.6 |
} elsif (defined $entity->flag ('smxp__entity_replacement_text_rpdata')) {
|
| 972 |
|
|
my $ev = $entity->flag ('smxp__entity_replacement_text_rpdata');
|
| 973 |
|
|
$eref->append_text ($ev);
|
| 974 |
|
|
$tt .= $ev;
|
| 975 |
wakaba |
1.5 |
} else {
|
| 976 |
|
|
$o2->{entity} = $ref;
|
| 977 |
|
|
my $entity_value = $entity->get_attribute ('value');
|
| 978 |
|
|
if (ref $entity_value) { ## Internal entity
|
| 979 |
wakaba |
1.4 |
$o2->{__entities}->{$ref} = 1;
|
| 980 |
wakaba |
1.5 |
$o2->{uri} = $entity->flag ('smxp__uri_in_which_declaration_is');
|
| 981 |
|
|
$o2->{line} = 0; $o2->{pos} = 0;
|
| 982 |
|
|
my $ev = $entity_value->_entity_parameter_literal_value;
|
| 983 |
wakaba |
1.6 |
$ev = $self->_parse_rpdata ($eref, \$ev, $o2, entMan => $entMan);
|
| 984 |
|
|
$entity->flag (smxp__entity_replacement_text_rpdata => $ev);
|
| 985 |
|
|
$tt .= $ev;
|
| 986 |
wakaba |
1.5 |
} else { ## External entity
|
| 987 |
|
|
$o2->{entity_type} = 'external_parameter_entity';
|
| 988 |
w |
1.9 |
$c->root_node->flag (smxp__declaration_may_not_be_read => 1)
|
| 989 |
|
|
if !(index ($o->{entity_type}, 'external') > -1)
|
| 990 |
|
|
|| !$opt{entMan}->is_standalone_document;
|
| 991 |
wakaba |
1.5 |
my $ext_ent = $entMan->get_external_entity ($self, $entity, $o2);
|
| 992 |
|
|
if ($ext_ent->{NDATA}) { ## non-parsed entity
|
| 993 |
|
|
$self->_raise_error ($o, type => 'WFC_PARSED_ENTITY', c => $entity, t => $ref);
|
| 994 |
|
|
} elsif ($ext_ent->{error}->{no_data}) { ## parsed entity but can't be retrived
|
| 995 |
|
|
$self->_raise_error ($o, type => 'ERR_EXT_ENTITY_NOT_FOUND', c => $entity,
|
| 996 |
|
|
t => [$ref, $o2->{uri}, $ext_ent->{error}->{reason_text}]);
|
| 997 |
wakaba |
1.6 |
$c->root_node->flag (smxp__stop_read_dtd => 1)
|
| 998 |
|
|
unless $entMan->is_standalone_document;
|
| 999 |
wakaba |
1.5 |
} else { ## parsed entity
|
| 1000 |
|
|
$o2->{__entities}->{$ref} = 1;
|
| 1001 |
|
|
my $ev = $ext_ent->{text};
|
| 1002 |
wakaba |
1.6 |
$ev = $self->_parse_rpdata ($eref, \$ev, $o2, entMan => $entMan);
|
| 1003 |
|
|
$entity->flag (smxp__entity_replacement_text_rpdata => $ev);
|
| 1004 |
|
|
$tt .= $ev;
|
| 1005 |
wakaba |
1.5 |
$eref->flag (smxp__ref_expanded => 1);
|
| 1006 |
|
|
} # external parsed entity
|
| 1007 |
|
|
} # external entity
|
| 1008 |
|
|
} # not recursive
|
| 1009 |
|
|
} # entity defined
|
| 1010 |
|
|
} # read not stopped
|
| 1011 |
|
|
$self->_clp ($ref => $o);
|
| 1012 |
wakaba |
1.2 |
} elsif ($$s =~ s/^([^%]+)//) {
|
| 1013 |
wakaba |
1.3 |
my $t = $1; my $r = '';
|
| 1014 |
|
|
while ($t) {
|
| 1015 |
wakaba |
1.6 |
if ($t =~ s/^(&#(?:x([0-9A-Fa-f]+)|([0-9]+));)//) {
|
| 1016 |
|
|
for (chr ($2 ? hex ($2) : $3)) {
|
| 1017 |
|
|
$self->_warn_char_val ($o, $_, ref => 1);
|
| 1018 |
|
|
$r .= $_;
|
| 1019 |
w |
1.8 |
$c->append_new_node (type => '#reference', value => ord $_,
|
| 1020 |
|
|
namespace_uri => $NS{SGML}.'char:ref'.(defined $2 ? ':hex' : ''));
|
| 1021 |
wakaba |
1.6 |
}
|
| 1022 |
|
|
$self->_clp ($1 => $o);
|
| 1023 |
wakaba |
1.5 |
} elsif ($t =~ s/^(&($xml_re{Name});)//) {
|
| 1024 |
|
|
my ($entity_ref, $eref) = ($1, $2);
|
| 1025 |
|
|
$r .= $entity_ref;
|
| 1026 |
wakaba |
1.6 |
$self->_raise_error ($o, type => 'NS_SYNTAX_NAME_IS_NCNAME', c => $c, t => $entity_ref)
|
| 1027 |
|
|
if index ($eref, ':') > -1;
|
| 1028 |
wakaba |
1.5 |
my $entity = $entMan->get_entity ($eref);
|
| 1029 |
|
|
if ($entity && $entity->get_attribute ('NDATA')) {
|
| 1030 |
|
|
$self->_raise_error ($o, type => 'ERR_XML_NDATA_REF_IN_ENTITY_VALUE',
|
| 1031 |
|
|
c => $c, t => $entity_ref);
|
| 1032 |
|
|
## Note: this error is not raisen when the entity referred is declared after
|
| 1033 |
|
|
## the EntityValue occurs.
|
| 1034 |
|
|
## Note: this error was a fatal error, but refined by XML 1.0 SE Errata.
|
| 1035 |
wakaba |
1.3 |
}
|
| 1036 |
w |
1.8 |
$c->append_new_node (type => '#reference', namespace_uri => $NS{SGML}.'entity',
|
| 1037 |
|
|
local_name => $eref);
|
| 1038 |
wakaba |
1.5 |
$self->_clp ($entity_ref => $o);
|
| 1039 |
wakaba |
1.3 |
} elsif ($t =~ s/^&//) {
|
| 1040 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_INVALID_CHAR', c => $c, t => '&');
|
| 1041 |
|
|
$r .= '&';
|
| 1042 |
w |
1.8 |
$c->append_new_node (type => '#reference', namespace_uri => $NS{SGML}.'char:ref',
|
| 1043 |
|
|
value => 0x26);
|
| 1044 |
wakaba |
1.6 |
$self->_clp (_ => $o);
|
| 1045 |
wakaba |
1.3 |
} elsif ($t =~ s/^([^&]+)//s) {
|
| 1046 |
|
|
$r .= $1;
|
| 1047 |
w |
1.8 |
$c->append_new_node (type => '#text', value => $1);
|
| 1048 |
wakaba |
1.6 |
$self->_clp ($1 => $o);
|
| 1049 |
wakaba |
1.3 |
}
|
| 1050 |
|
|
}
|
| 1051 |
wakaba |
1.6 |
$tt .= $r;
|
| 1052 |
wakaba |
1.1 |
} else {
|
| 1053 |
wakaba |
1.6 |
$self->_raise_error ($o, type => 'SYNTAX_INVALID_CHAR', t => substr ($$s, 0, 10));
|
| 1054 |
wakaba |
1.2 |
substr ($$s, 0, 1) = '';
|
| 1055 |
wakaba |
1.6 |
$self->_clp (_ => $o);
|
| 1056 |
wakaba |
1.1 |
}
|
| 1057 |
wakaba |
1.6 |
} # while $$s
|
| 1058 |
|
|
$tt;
|
| 1059 |
wakaba |
1.1 |
}
|
| 1060 |
wakaba |
1.2 |
|
| 1061 |
wakaba |
1.6 |
sub _parse_md_params ($$\$$$;%) {
|
| 1062 |
|
|
my ($self, $c, $s, $o, %opt) = @_;
|
| 1063 |
|
|
my $entMan = $opt{entMan} || $c->root_node->flag ('smxp__entity_manager');
|
| 1064 |
|
|
my $t = '';
|
| 1065 |
|
|
while ($$s) {
|
| 1066 |
|
|
if ($$s =~ s/^($xml_re{PEReference_M})//) {
|
| 1067 |
|
|
my ($ref, $ename) = ($1, $2);
|
| 1068 |
|
|
$self->_raise_error ($o, c => $c, type => 'WFC_PE_IN_INTERNAL_SUBSET', t => $ref)
|
| 1069 |
|
|
if $o->{entity_type} eq 'document_entity';
|
| 1070 |
|
|
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_NAME_IS_NCNAME', t => $ref)
|
| 1071 |
|
|
if index ($ename, ':') > -1;
|
| 1072 |
|
|
my $eref = $c->append_new_node (type => '#reference', local_name => $ename,
|
| 1073 |
|
|
namespace_uri => $NS{SGML}.'entity:parameter');
|
| 1074 |
|
|
unless ($opt{dont_resolve_entity_ref}) {
|
| 1075 |
|
|
my $entity = $entMan->get_entity ($ename, namespace_uri => $NS{SGML}.'entity:parameter');
|
| 1076 |
|
|
if (!$entity) {
|
| 1077 |
|
|
$self->_raise_error ($o, c => $c, type => 'VC_ENTITY_DECLARED', t => $ref);
|
| 1078 |
|
|
} else {
|
| 1079 |
|
|
if ($o->{__entities}->{$ref}) {
|
| 1080 |
|
|
$self->_raise_error ($o, c => $c, type => 'WFC_NO_RECURSION', t => $ref);
|
| 1081 |
|
|
} elsif (defined $entity->flag ('smxp__entity_replacement_text_md_params')) {
|
| 1082 |
|
|
$t .= ' '.$entity->flag ('smxp__entity_replacement_text_md_params').' ';
|
| 1083 |
|
|
} else {
|
| 1084 |
|
|
my $o2 = $self->_make_clone_of ($o);
|
| 1085 |
|
|
$o2->{entity} = $ref;
|
| 1086 |
|
|
my $entity_value = $entity->get_attribute ('value');
|
| 1087 |
|
|
if (ref $entity_value) { ## Internal entity
|
| 1088 |
|
|
$o2->{__entities}->{$ref} = 1;
|
| 1089 |
|
|
$o2->{uri} = $entity->flag ('smxp__uri_in_which_declaration_is');
|
| 1090 |
|
|
$o2->{line} = 0; $o2->{pos} = 0;
|
| 1091 |
|
|
my $ev = $entity_value->_entity_parameter_literal_value;
|
| 1092 |
|
|
$ev = $self->_parse_md_params ($eref, \$ev, $o2, entMan => $entMan);
|
| 1093 |
|
|
$entity->flag (smxp__entity_replacement_text_md_params => $ev);
|
| 1094 |
|
|
$t .= ' '.$ev.' ';
|
| 1095 |
|
|
$eref->flag (smxp__ref_expanded => 1);
|
| 1096 |
|
|
} else { ## External entity
|
| 1097 |
|
|
$o2->{entity_type} = 'external_parameter_entity';
|
| 1098 |
w |
1.9 |
$c->root_node->flag (smxp__declaration_may_not_be_read => 1)
|
| 1099 |
|
|
if !(index ($o->{entity_type}, 'external') > -1)
|
| 1100 |
|
|
|| !$opt{entMan}->is_standalone_document;
|
| 1101 |
wakaba |
1.6 |
my $ext_ent = $entMan->get_external_entity ($self, $entity, $o2);
|
| 1102 |
|
|
if ($ext_ent->{NDATA}) { ## non-parsed entity
|
| 1103 |
|
|
$self->_raise_error ($o, type => 'WFC_PARSED_ENTITY', c => $entity, t => $ref);
|
| 1104 |
|
|
} elsif ($ext_ent->{error}->{no_data}) { ## parsed entity but can't be retrived
|
| 1105 |
|
|
$self->_raise_error ($o, type => 'ERR_EXT_ENTITY_NOT_FOUND', c => $entity,
|
| 1106 |
|
|
t => [$ref, $o2->{uri}, $ext_ent->{error}->{reason_text}]);
|
| 1107 |
|
|
$c->root_node->flag (smxp__stop_read_dtd => 1)
|
| 1108 |
w |
1.9 |
unless $opt{entMan}->is_standalone_document;
|
| 1109 |
wakaba |
1.6 |
} else { ## parsed entity
|
| 1110 |
|
|
$o2->{__entities}->{$ref} = 1;
|
| 1111 |
|
|
my $ev = $ext_ent->{text};
|
| 1112 |
w |
1.9 |
$ev = $self->_parse_md_params ($eref, \$ev, $o2, entMan => $opt{entMan});
|
| 1113 |
wakaba |
1.6 |
$entity->flag (smxp__entity_replacement_text_md_params => $ev);
|
| 1114 |
|
|
$t .= ' '.$ev.' ';
|
| 1115 |
|
|
$eref->flag (smxp__ref_expanded => 1);
|
| 1116 |
|
|
} # external parsed entity
|
| 1117 |
|
|
} # external entity
|
| 1118 |
|
|
} # not recursive
|
| 1119 |
|
|
} # entity defined
|
| 1120 |
|
|
} # not stopped
|
| 1121 |
|
|
$c->flag (smxp__defined_with_param_ref => 1);
|
| 1122 |
|
|
$self->_clp ($ref => $o);
|
| 1123 |
|
|
} elsif ($$s =~ s/^($xml_re{__AttValue_simple})//s) {
|
| 1124 |
|
|
my $all = $1;
|
| 1125 |
|
|
$t .= $all;
|
| 1126 |
|
|
$c->append_new_node (type => '#xml', value => $all); ## Note: is this safe?
|
| 1127 |
|
|
$self->_clp ($all => $o);
|
| 1128 |
w |
1.8 |
} elsif ($$s =~ s/^(\p{InXMLNameChar}+)//) {
|
| 1129 |
wakaba |
1.6 |
$c->append_text ($1);
|
| 1130 |
|
|
$t .= $1;
|
| 1131 |
|
|
$self->_clp ($1 => $o);
|
| 1132 |
w |
1.8 |
if ($$s =~ s/^([+*?])//) {
|
| 1133 |
|
|
$c->append_text ($1);
|
| 1134 |
|
|
$t .= $1;
|
| 1135 |
|
|
$self->_clp (_ => $o);
|
| 1136 |
|
|
}
|
| 1137 |
|
|
} elsif ($$s =~ s/^\(//) {
|
| 1138 |
|
|
$c->append_text ('(');
|
| 1139 |
|
|
my $grp = $c->append_new_node (type => '#element', namespace_uri => $NS{SGML}.'group');
|
| 1140 |
|
|
$t .= '('.$self->_parse_md_params ($grp, $s, $o, entMan => $entMan, return_by_grpc => 1);
|
| 1141 |
|
|
$c->flag (smxp__defined_with_param_ref => 1)
|
| 1142 |
|
|
if $grp->flag ('smxp__defined_with_param_ref');
|
| 1143 |
|
|
} elsif ($$s =~ s/^([%#,|])//) {
|
| 1144 |
wakaba |
1.6 |
$c->append_text ($1);
|
| 1145 |
|
|
$t .= $1;
|
| 1146 |
|
|
$self->_clp ($1 => $o);
|
| 1147 |
|
|
} elsif ($$s =~ s/^($xml_re{s})//s) {
|
| 1148 |
|
|
$c->append_text ($1);
|
| 1149 |
|
|
$t .= $1;
|
| 1150 |
|
|
$self->_clp ($1 => $o);
|
| 1151 |
|
|
} elsif ($opt{return_by_mdc} && $$s =~ s/^>//) { ## mdc
|
| 1152 |
|
|
$self->_clp (_ => $o);
|
| 1153 |
|
|
return $t;
|
| 1154 |
w |
1.8 |
} elsif (($opt{return_by_mdc}||$opt{return_by_grpc}) && $$s =~ m/^</) { ## maybe mdo
|
| 1155 |
wakaba |
1.6 |
$self->_raise_error ($o, type => 'SYNTAX_END_OF_MARKUP_NOT_FOUND', t => $c, c => $c);
|
| 1156 |
|
|
return $t;
|
| 1157 |
w |
1.8 |
} elsif ($opt{return_by_grpc} && $$s =~ s/^\)//) { ## grpc
|
| 1158 |
|
|
$self->_clp (_ => $o);
|
| 1159 |
|
|
$t .= ')';
|
| 1160 |
|
|
$c->parent_node->append_text (')');
|
| 1161 |
|
|
if ($$s =~ s/^([+*?])//) {
|
| 1162 |
|
|
$t .= $1;
|
| 1163 |
|
|
$c->parent_node->append_text ($1);
|
| 1164 |
|
|
$self->_clp (_ => $o);
|
| 1165 |
|
|
}
|
| 1166 |
|
|
return $t;
|
| 1167 |
wakaba |
1.6 |
} else {
|
| 1168 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_INVALID_CHAR', t => substr ($$s, 0, 10));
|
| 1169 |
|
|
substr ($$s, 0, 1) = '';
|
| 1170 |
|
|
$self->_clp (_ => $o);
|
| 1171 |
|
|
}
|
| 1172 |
|
|
} # while
|
| 1173 |
w |
1.8 |
if ($opt{return_by_grpc}) {
|
| 1174 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_GROUP_NOT_CLOSED');
|
| 1175 |
|
|
$t .= ')';
|
| 1176 |
|
|
}
|
| 1177 |
wakaba |
1.6 |
$t;
|
| 1178 |
|
|
}
|
| 1179 |
|
|
|
| 1180 |
wakaba |
1.2 |
sub _warn_char_val ($$$%) {
|
| 1181 |
|
|
my ($self, $o, $ch, %o) = @_;
|
| 1182 |
wakaba |
1.6 |
if ($ch =~ /^(.*?)(\P{InXMLChar})/) {
|
| 1183 |
|
|
$self->_clp ($1 => $o);
|
| 1184 |
|
|
$self->_raise_error ($o, type => (($o{ref}?'WFC':'SYNTAX').'_LEGAL_CHARACTER'), t => ord $2);
|
| 1185 |
|
|
} elsif ($ch =~ /^(.*?)(\p{InXML_deprecated_noncharacter})/) {
|
| 1186 |
|
|
$self->_clp ($1 => $o);
|
| 1187 |
|
|
$self->_raise_error ($o, type => 'WARN_UNICODE_NONCHARACTER', t => ord $2);
|
| 1188 |
|
|
} elsif ($ch =~ /^(.*?)(\p{Compat})/) {
|
| 1189 |
|
|
$self->_clp ($1 => $o);
|
| 1190 |
|
|
$self->_raise_error ($o, type => 'WARN_UNICODE_COMPAT_CHARACTER', t => ord $2);
|
| 1191 |
|
|
} elsif ($ch =~ /^(.*?)(\p{InXML_unicode_xml_not_suitable})/) {
|
| 1192 |
|
|
$self->_clp ($1 => $o);
|
| 1193 |
|
|
$self->_raise_error ($o, type => 'WARN_UNICODE_XML_NOT_SUITABLE_CHARACTER', t => ord $2);
|
| 1194 |
wakaba |
1.1 |
}
|
| 1195 |
|
|
}
|
| 1196 |
|
|
sub _parse_reference ($$$$) {
|
| 1197 |
|
|
my ($self, $c, $ref, $o) = @_;
|
| 1198 |
wakaba |
1.2 |
my $r;
|
| 1199 |
wakaba |
1.1 |
if ($ref =~ /$xml_re{EntityRef_M}/) { ## BUG: QName
|
| 1200 |
wakaba |
1.2 |
$r = $c->append_new_node (type => '#reference', local_name => $1,
|
| 1201 |
|
|
namespace_uri => $NS{SGML}.'entity');
|
| 1202 |
wakaba |
1.1 |
} elsif ($ref =~ /x([0-9A-Fa-f]+)/) {
|
| 1203 |
|
|
my $ch = hex $1;
|
| 1204 |
wakaba |
1.2 |
$self->_warn_char_val ($o, chr $ch, ref => 1);
|
| 1205 |
|
|
$r = $c->append_new_node (type => '#reference', value => $ch,
|
| 1206 |
wakaba |
1.6 |
namespace_uri => $NS{SGML}.'char:ref:hex');
|
| 1207 |
wakaba |
1.1 |
} elsif ($ref =~ /([0-9]+)/) {
|
| 1208 |
wakaba |
1.2 |
my $ch = 0+$1;
|
| 1209 |
|
|
$self->_warn_char_val ($o, chr $ch, ref => 1);
|
| 1210 |
|
|
$r = $c->append_new_node (type => '#reference', value => $ch,
|
| 1211 |
wakaba |
1.6 |
namespace_uri => $NS{SGML}.'char:ref');
|
| 1212 |
wakaba |
1.1 |
} else {
|
| 1213 |
|
|
$self->_raise_error ($o, type => 'UNKNOWN', t => $ref);
|
| 1214 |
|
|
}
|
| 1215 |
|
|
_count_lp ($ref, $o);
|
| 1216 |
wakaba |
1.2 |
$r;
|
| 1217 |
wakaba |
1.1 |
}
|
| 1218 |
wakaba |
1.4 |
|
| 1219 |
wakaba |
1.6 |
sub _parse_ignored_marked_section ($$\$$;%) {
|
| 1220 |
wakaba |
1.5 |
my ($self, $c, $s, $o) = @_;
|
| 1221 |
|
|
while ($$s) {
|
| 1222 |
|
|
if ($$s =~ s/^<!\[//) {
|
| 1223 |
|
|
$self->_clp (___ => $o);
|
| 1224 |
|
|
$self->_parse_ignored_marked_section ($c->append_new_node (type => '#section'), $s, $o);
|
| 1225 |
|
|
} elsif ($$s =~ s/^\]\]>//) {
|
| 1226 |
|
|
$self->_clp (___ => $o);
|
| 1227 |
|
|
return;
|
| 1228 |
|
|
} elsif ($$s =~ s/^((?:(?!<!\[|\]\]>).)+)//s) {
|
| 1229 |
|
|
$c->append_text ($1);
|
| 1230 |
|
|
$self->_clp ($1 => $o);
|
| 1231 |
|
|
}
|
| 1232 |
|
|
} # $$s
|
| 1233 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_END_OF_MARKUP_NOT_FOUND', t => $c);
|
| 1234 |
|
|
}
|
| 1235 |
|
|
|
| 1236 |
wakaba |
1.4 |
sub _parse_xml_or_text_declaration ($$\$$) {
|
| 1237 |
|
|
my ($self, $c, $s, $o) = @_;
|
| 1238 |
|
|
if ($$s =~ s/^$xml_re{_xml_PI_M}//s) {
|
| 1239 |
wakaba |
1.6 |
my $data = $1;
|
| 1240 |
|
|
$self->_clp (_____ => $o);
|
| 1241 |
|
|
if (length $data) {
|
| 1242 |
wakaba |
1.4 |
$self->_parse_xml_declaration ($c, $data, $o);
|
| 1243 |
|
|
} else {
|
| 1244 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_XML_DECLARE_NO_ATTR');
|
| 1245 |
|
|
}
|
| 1246 |
wakaba |
1.6 |
$self->_clp (__ => $o);
|
| 1247 |
wakaba |
1.4 |
}
|
| 1248 |
|
|
}
|
| 1249 |
wakaba |
1.1 |
sub _parse_xml_declaration ($$$$) {
|
| 1250 |
|
|
my ($self, $c, $attrs, $o) = @_;
|
| 1251 |
|
|
my $stage = 0; # 0: <?xml, 1: version="", 2: encoding="", 3: standalone="", 4: ?>
|
| 1252 |
|
|
$attrs = ' ' . $attrs;
|
| 1253 |
|
|
while ($attrs) {
|
| 1254 |
|
|
if ($attrs =~ s/^$xml_re{s}version(?:$xml_re{s})?=(?:$xml_re{s})?("[A-Za-z0-9_.:-]+"|'[A-Za-z0-9_.:-]+')//s) {
|
| 1255 |
|
|
my $version = substr ($1, 1, length ($1) - 2);
|
| 1256 |
|
|
if ($stage > 0) {
|
| 1257 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE', t => 'version');
|
| 1258 |
|
|
}
|
| 1259 |
wakaba |
1.4 |
$c->set_attribute (version => $version);
|
| 1260 |
|
|
## TODO: XML 1.1 support
|
| 1261 |
|
|
if ($version ne '1.0') {
|
| 1262 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_UNSUPPORTED_XML_VERSION', t => $version);
|
| 1263 |
wakaba |
1.1 |
}
|
| 1264 |
|
|
_count_lp ($&, $o); $stage++;
|
| 1265 |
|
|
} elsif ($attrs =~ s/^$xml_re{s}encoding(?:$xml_re{s})?=(?:$xml_re{s})?("[A-Za-z0-9_.-]+"|'[A-Za-z0-9_.:-]+')//s) {
|
| 1266 |
|
|
if ($stage > 2) {
|
| 1267 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE', t => 'encoding');
|
| 1268 |
|
|
} elsif ($stage == 0) { ## No version pseudo-attr
|
| 1269 |
|
|
if ($o->{entity_type} eq 'document_entity') {
|
| 1270 |
wakaba |
1.4 |
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE_NO_VERSION_ATTR');
|
| 1271 |
wakaba |
1.1 |
$c->set_attribute (version => '1.0');
|
| 1272 |
|
|
} else {
|
| 1273 |
wakaba |
1.4 |
$self->_raise_error ($o, c => $attrs, type => 'WARN_XML_DECLARE_NO_VERSION_ATTR');
|
| 1274 |
wakaba |
1.1 |
$o->{entity_type} = 'external_parsed_entity';
|
| 1275 |
|
|
}
|
| 1276 |
|
|
}
|
| 1277 |
|
|
$c->set_attribute (encoding => substr ($1, 1, length ($1) - 2));
|
| 1278 |
|
|
_count_lp ($&, $o); $stage = 2;
|
| 1279 |
|
|
} elsif ($attrs =~ s/^$xml_re{s}standalone(?:$xml_re{s})?=(?:$xml_re{s})?("(?:yes|no)"|'(?:yes|no)')//s) {
|
| 1280 |
wakaba |
1.4 |
if ($stage == 0) { ## 'version' or 'encoding' is expected
|
| 1281 |
|
|
if ($o->{entity_type} eq 'document_entity') { ## XML declaration
|
| 1282 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE_NO_VERSION_ATTR');
|
| 1283 |
|
|
$c->set_attribute (version => '1.0');
|
| 1284 |
|
|
} else { ## Text declaration
|
| 1285 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'WARN_XML_DECLARE_NO_VERSION_ATTR');
|
| 1286 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE_NO_ENCODING_ATTR');
|
| 1287 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE_STANDALONE_ATTR');
|
| 1288 |
|
|
}
|
| 1289 |
|
|
} elsif ($stage > 3) {
|
| 1290 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE', t => 'standalone');
|
| 1291 |
wakaba |
1.1 |
}
|
| 1292 |
|
|
$c->set_attribute (standalone => (substr ($1, 1, 1) eq 'y' ? 'yes' : 'no'));
|
| 1293 |
|
|
_count_lp ($&, $o); $stage = 3;
|
| 1294 |
|
|
} elsif ($attrs =~ s/^($xml_re{s})//s) {
|
| 1295 |
|
|
my $s = $1;
|
| 1296 |
|
|
if ($stage == 0) {
|
| 1297 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE_NO_ATTR');
|
| 1298 |
|
|
$c->set_attribute (version => '1.0');
|
| 1299 |
|
|
}
|
| 1300 |
|
|
_count_lp ($s, $o); $stage = 4;
|
| 1301 |
|
|
} else {
|
| 1302 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE', t => $attrs);
|
| 1303 |
|
|
_count_lp ($attrs, $o); undef $attrs;
|
| 1304 |
|
|
}
|
| 1305 |
|
|
} # while
|
| 1306 |
|
|
if ($stage == 0) {
|
| 1307 |
|
|
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE_NO_ATTR');
|
| 1308 |
|
|
$c->set_attribute (version => '1.0');
|
| 1309 |
wakaba |
1.7 |
} elsif ($stage == 1 && index ($o->{entity_type}, 'external') > -1) {
|
| 1310 |
wakaba |
1.4 |
$self->_raise_error ($o, c => $attrs, type => 'SYNTAX_XML_DECLARE_NO_ENCODING_ATTR');
|
| 1311 |
wakaba |
1.1 |
}
|
| 1312 |
|
|
}
|
| 1313 |
wakaba |
1.4 |
|
| 1314 |
wakaba |
1.6 |
sub _parse_entity_declaration ($\$$$;%) {
|
| 1315 |
|
|
my ($self, $s, $c, $o, %opt) = @_;
|
| 1316 |
wakaba |
1.2 |
my $p; ## notation ? 'n' : parameter entity ? '%' : undef;
|
| 1317 |
wakaba |
1.6 |
my $entMan = $opt{entMan} || $c->root_node->flag ('smxp__entity_manager');
|
| 1318 |
|
|
my $dont_process = $c->root_node->flag ('smxp__stop_read_dtd');
|
| 1319 |
wakaba |
1.2 |
my $e = $c->append_new_node (type => '#declaration');
|
| 1320 |
wakaba |
1.6 |
$e->flag (smxp__uri_in_which_declaration_is => $o->{uri});
|
| 1321 |
w |
1.9 |
$e->flag (smxp__declaration_may_not_be_read
|
| 1322 |
|
|
=> $c->root_node->flag ('smxp__declaration_may_not_be_read'));
|
| 1323 |
wakaba |
1.6 |
## Entity? or notation?
|
| 1324 |
wakaba |
1.5 |
if ($$s =~ s/^<!ENTITY//) {
|
| 1325 |
wakaba |
1.2 |
$e->namespace_uri ($NS{SGML}.'entity');
|
| 1326 |
wakaba |
1.5 |
$self->_clp (________ => $o);
|
| 1327 |
|
|
} else {
|
| 1328 |
|
|
$$s =~ s/^<!NOTATION//;
|
| 1329 |
wakaba |
1.2 |
$e->namespace_uri ($NS{SGML}.'notation');
|
| 1330 |
wakaba |
1.5 |
$self->_clp (__________ => $o); $p = 'n';
|
| 1331 |
wakaba |
1.1 |
}
|
| 1332 |
wakaba |
1.6 |
## Parameters
|
| 1333 |
|
|
my $t;
|
| 1334 |
|
|
$t = $self->_parse_md_params ($e, $s, $o, dont_resolve_entity_ref => $dont_process,
|
| 1335 |
|
|
return_by_mdc => 1, entMan => $entMan);
|
| 1336 |
wakaba |
1.5 |
$dont_process = $c->root_node->flag ('smxp__stop_read_dtd');
|
| 1337 |
|
|
unless ($dont_process) {
|
| 1338 |
wakaba |
1.6 |
my $o = $self->_make_clone_of ($o);
|
| 1339 |
|
|
my $is_internal = 1;
|
| 1340 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10))
|
| 1341 |
|
|
unless $t =~ s/^$xml_re{s}//s;
|
| 1342 |
|
|
if ($t =~ s/^%//) {
|
| 1343 |
|
|
if ($p eq 'n') {
|
| 1344 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_MD', t => '%');
|
| 1345 |
|
|
} else {
|
| 1346 |
|
|
$e->namespace_uri ($NS{SGML}.'entity:parameter'); $p = '%';
|
| 1347 |
|
|
}
|
| 1348 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10))
|
| 1349 |
|
|
unless $t =~ s/^$xml_re{s}//s;
|
| 1350 |
|
|
}
|
| 1351 |
|
|
my $ename;
|
| 1352 |
|
|
if ($t =~ s/^($xml_re{Name})//) {
|
| 1353 |
|
|
$ename = $1;
|
| 1354 |
wakaba |
1.5 |
if ($entMan->is_declared_entity ($ename, namespace_uri => $e->namespace_uri,
|
| 1355 |
|
|
dont_use_predefined_entities => 1,
|
| 1356 |
|
|
seek => 0)) {
|
| 1357 |
|
|
if ($p eq 'n') {
|
| 1358 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $e,
|
| 1359 |
wakaba |
1.5 |
type => 'VC_UNIQUE_NOTATION_NAME', t => $ename);
|
| 1360 |
|
|
} else {
|
| 1361 |
wakaba |
1.13 |
$self->_raise_error ($o, c => $e, t => $ename,
|
| 1362 |
|
|
type => 'WARN_UNIQUE_'.($p eq '%' ? 'PARAMETER_' : '').'ENTITY_NAME');
|
| 1363 |
wakaba |
1.2 |
}
|
| 1364 |
wakaba |
1.6 |
} else { ## Regist to entMan
|
| 1365 |
wakaba |
1.5 |
$entMan->is_declared_entity ($ename, namespace_uri => $e->namespace_uri,
|
| 1366 |
|
|
dont_use_predefined_entities => 1,
|
| 1367 |
w |
1.10 |
set_value => 1, seek => 0)
|
| 1368 |
wakaba |
1.5 |
}
|
| 1369 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_NAME_IS_NCNAME', t => $ename)
|
| 1370 |
|
|
if index ($ename, ':') > -1;
|
| 1371 |
wakaba |
1.5 |
$e->local_name ($ename);
|
| 1372 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10))
|
| 1373 |
|
|
unless $t =~ s/^$xml_re{s}//s;
|
| 1374 |
|
|
} else {
|
| 1375 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_MD_NAME_NOT_FOUND',
|
| 1376 |
|
|
t => substr ($t, 0, 10));
|
| 1377 |
|
|
}
|
| 1378 |
|
|
if ($t =~ s/^PUBLIC//) {
|
| 1379 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10))
|
| 1380 |
|
|
unless $t =~ s/^$xml_re{s}//s;
|
| 1381 |
|
|
unless ($t =~ s/^($xml_re{__AttValue_simple})//s) { ## TODO: new error
|
| 1382 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_MD_PID_NOT_FOUND',
|
| 1383 |
|
|
t => substr ($t, 0, 10));
|
| 1384 |
|
|
} else {
|
| 1385 |
|
|
$e->set_attribute (PUBLIC => $entMan->check_public_id
|
| 1386 |
|
|
($o, substr ($1, 1, length ($1) - 2)));
|
| 1387 |
|
|
my $f = $t =~ s/^$xml_re{s}//s ? 1 : 0;
|
| 1388 |
|
|
if ($t =~ s/^($xml_re{__AttValue_simple})//s) {
|
| 1389 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10))
|
| 1390 |
|
|
unless $f;
|
| 1391 |
|
|
$e->set_attribute (SYSTEM => $entMan->check_system_id
|
| 1392 |
|
|
($o, substr ($1, 1, length ($1) - 2)));
|
| 1393 |
|
|
} else {
|
| 1394 |
|
|
if ($p ne 'n') {
|
| 1395 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_MD_SYSID_NOT_FOUND',
|
| 1396 |
|
|
t => substr ($t, 0, 10));
|
| 1397 |
|
|
$e->set_attribute (SYSTEM => $NS{internal_invalid_sysid});
|
| 1398 |
wakaba |
1.3 |
}
|
| 1399 |
wakaba |
1.2 |
}
|
| 1400 |
wakaba |
1.6 |
}
|
| 1401 |
|
|
$is_internal = 0;
|
| 1402 |
|
|
} elsif ($t =~ s/^SYSTEM//) {
|
| 1403 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10))
|
| 1404 |
|
|
unless $t =~ s/^$xml_re{s}//s;
|
| 1405 |
|
|
if ($t =~ s/^($xml_re{__AttValue_simple})//s) {
|
| 1406 |
|
|
$e->set_attribute (SYSTEM => $entMan->check_system_id
|
| 1407 |
|
|
($o, substr ($1, 1, length ($1) - 2)));
|
| 1408 |
|
|
} else { ## TODO: error text
|
| 1409 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_MD_SYSID_NOT_FOUND',
|
| 1410 |
|
|
t => substr ($t, 0, 10));
|
| 1411 |
|
|
$e->set_attribute (SYSTEM => $NS{internal_invalid_sysid});
|
| 1412 |
|
|
}
|
| 1413 |
|
|
$is_internal = 0;
|
| 1414 |
|
|
} elsif ($p ne 'n' && $t =~ s/^($xml_re{__AttValue_simple})//s) { ## EntityValue (ENTITY only)
|
| 1415 |
|
|
## TOTO: $o
|
| 1416 |
|
|
my $ev = $1; $ev = substr ($ev, 1, length ($ev) - 2);
|
| 1417 |
|
|
$ev = $self->_parse_rpdata ($e->set_attribute ('value'), \$ev, $o);
|
| 1418 |
|
|
unless (defined $e->flag ('smxp__entity_replacement_text_rpdata')) {
|
| 1419 |
|
|
$e->flag (smxp__entity_replacement_text_rpdata => $ev);
|
| 1420 |
|
|
}
|
| 1421 |
wakaba |
1.5 |
if (($p ne '%') && {qw/lt 1 gt 1 amp 1 quot 1 apos 1/}->{$ename}) {
|
| 1422 |
wakaba |
1.6 |
## TODO: check when external entity too
|
| 1423 |
|
|
$self->_raise_error ($o, c => $e,
|
| 1424 |
|
|
type => 'FATAL_ERR_PREDEFINED_ENTITY', t => [$ename, $ev])
|
| 1425 |
|
|
unless {qw/lt|< 1 gt|>> 1 amp|& 1 apos|' 1 quot|" 1
|
| 1426 |
|
|
lt|< 1 gt|> 1 amp|& 1 apos|' 1 quot|" 1
|
| 1427 |
|
|
gt|> 1 apos|' 1 quot|" 1
|
| 1428 |
|
|
/}->{$ename.'|'.lc ($ev)};
|
| 1429 |
wakaba |
1.5 |
}
|
| 1430 |
wakaba |
1.6 |
}
|
| 1431 |
|
|
if ($t =~ s/^$xml_re{s}NDATA//s) {
|
| 1432 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10))
|
| 1433 |
|
|
unless $t =~ s/^$xml_re{s}//s;
|
| 1434 |
|
|
unless ($t =~ s/^($xml_re{Name})//s) {
|
| 1435 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10));
|
| 1436 |
|
|
} else {
|
| 1437 |
|
|
my $nname = $1;
|
| 1438 |
|
|
if ($p eq '%') { ## parameter entity
|
| 1439 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_PE_NDATA', t => $nname);
|
| 1440 |
|
|
} elsif ($is_internal) {
|
| 1441 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_KEYWORD', t => 'NDATA');
|
| 1442 |
|
|
} else {
|
| 1443 |
|
|
$e->set_attribute (NDATA => $nname)
|
| 1444 |
|
|
->flag (smxp__src_pos => $o);
|
| 1445 |
|
|
}
|
| 1446 |
wakaba |
1.5 |
}
|
| 1447 |
wakaba |
1.2 |
}
|
| 1448 |
wakaba |
1.6 |
$t =~ s/^$xml_re{s}//s;
|
| 1449 |
|
|
if (length $t) {
|
| 1450 |
|
|
$self->_raise_error ($o, c => $e, type => 'SYNTAX_INVALID_MD', t => $t);
|
| 1451 |
|
|
}
|
| 1452 |
wakaba |
1.5 |
} else { ## dont_process
|
| 1453 |
|
|
$c->flag (smxp__non_processed_declaration => 1);
|
| 1454 |
wakaba |
1.6 |
$self->_raise_error ($o, c => $c, type => 'WARN_ENTITY_DECLARATION_NOT_PROCESSED');
|
| 1455 |
wakaba |
1.1 |
}
|
| 1456 |
|
|
}
|
| 1457 |
|
|
|
| 1458 |
w |
1.8 |
sub _parse_element_declaration ($$$$;%) {
|
| 1459 |
|
|
my ($self, $s, $c, $o, %opt) = (@_);
|
| 1460 |
|
|
$c = $c->append_new_node (type => '#declaration', namespace_uri => $NS{SGML}.'element');
|
| 1461 |
|
|
unless ($$s =~ s/^<!ELEMENT//s) {
|
| 1462 |
|
|
$self->_raise_error ($o, type => 'UNKNOWN', c => $c, t => substr ($$s, 0, 10));
|
| 1463 |
|
|
return;
|
| 1464 |
|
|
}
|
| 1465 |
|
|
$self->_clp (_________ => $o);
|
| 1466 |
|
|
|
| 1467 |
|
|
my $t = $self->_parse_md_params ($c, $s, $o, entMan => $opt{entMan}, return_by_mdc => 1);
|
| 1468 |
|
|
|
| 1469 |
|
|
## Element type name
|
| 1470 |
|
|
if ($t =~ s/^($xml_re{s}($xml_re{Name}))//s) {
|
| 1471 |
|
|
my $type_qname = $2;
|
| 1472 |
|
|
if (substr ($type_qname, 0, 1) eq ':' || substr ($type_qname, -1, 1) eq ':') {
|
| 1473 |
|
|
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_NAME_IS_QNNAME', t => $type_qname);
|
| 1474 |
|
|
$type_qname =~ tr/:/_/;
|
| 1475 |
wakaba |
1.1 |
}
|
| 1476 |
w |
1.10 |
if ($opt{entMan}->is_declared_entity ($type_qname, namespace_uri => $NS{SGML}.'element',
|
| 1477 |
|
|
seek => 0)) {
|
| 1478 |
|
|
$self->_raise_error ($o, c => $c,
|
| 1479 |
|
|
type => 'VC_UNIQUE_ELEMENT_TYPE_NAME', t => $type_qname);
|
| 1480 |
|
|
} else { ## Regist to entMan
|
| 1481 |
|
|
$opt{entMan}->is_declared_entity ($type_qname, namespace_uri => $NS{SGML}.'element',
|
| 1482 |
w |
1.11 |
set_value => $c, seek => 0);
|
| 1483 |
w |
1.10 |
}
|
| 1484 |
w |
1.8 |
$c->set_attribute (qname => $type_qname);
|
| 1485 |
|
|
} else {
|
| 1486 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10));
|
| 1487 |
|
|
return;
|
| 1488 |
|
|
}
|
| 1489 |
|
|
|
| 1490 |
wakaba |
1.14 |
## No content model declaration
|
| 1491 |
|
|
$t =~ s/^$xml_re{s}//s;
|
| 1492 |
|
|
unless ($t) {
|
| 1493 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10));
|
| 1494 |
|
|
return;
|
| 1495 |
|
|
}
|
| 1496 |
|
|
|
| 1497 |
w |
1.8 |
## Content model
|
| 1498 |
|
|
my $delimited = 1;
|
| 1499 |
|
|
my $in_group = 0;
|
| 1500 |
|
|
my @grp_connector;
|
| 1501 |
|
|
my $is_pcdata;
|
| 1502 |
|
|
my $r = $c;
|
| 1503 |
|
|
while ($t) {
|
| 1504 |
|
|
if ($t =~ s/^$xml_re{s}//s) {
|
| 1505 |
|
|
#
|
| 1506 |
|
|
} elsif ($t =~ s/^($xml_re{Name})//) {
|
| 1507 |
|
|
my $name = $1;
|
| 1508 |
|
|
if ($in_group) {
|
| 1509 |
|
|
unless ($delimited) {
|
| 1510 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_NO_DELIMITER',
|
| 1511 |
|
|
t => $name);
|
| 1512 |
|
|
} else {
|
| 1513 |
|
|
$delimited = 0;
|
| 1514 |
|
|
}
|
| 1515 |
|
|
if (substr ($name, 0, 1) eq ':' || substr ($name, -1, 1) eq ':') {
|
| 1516 |
|
|
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_NAME_IS_QNNAME', t => $name);
|
| 1517 |
|
|
$name =~ tr/:/_/;
|
| 1518 |
|
|
}
|
| 1519 |
w |
1.11 |
my $enode = $c->append_new_node (type => '#element', namespace_uri => $NS{SGML}.'element',
|
| 1520 |
|
|
local_name => 'element');
|
| 1521 |
|
|
$enode->set_attribute (qname => $name);
|
| 1522 |
w |
1.8 |
if ($t =~ s/^([+*?])//) {
|
| 1523 |
w |
1.11 |
$enode->set_attribute (occurence => $1);
|
| 1524 |
w |
1.8 |
}
|
| 1525 |
|
|
} else {
|
| 1526 |
|
|
if ({qw/EMPTY 1 ANY 1/}->{$name}) {
|
| 1527 |
|
|
#
|
| 1528 |
|
|
} elsif ({qw/PCDATA 1 CDATA 1/}->{$name}) {
|
| 1529 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_SGML_KWD',
|
| 1530 |
|
|
t => $name);
|
| 1531 |
|
|
} else {
|
| 1532 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_UNKNOWN_KWD',
|
| 1533 |
|
|
t => $name);
|
| 1534 |
|
|
}
|
| 1535 |
|
|
$r->set_attribute (content => $name);
|
| 1536 |
|
|
last;
|
| 1537 |
|
|
} # out of group
|
| 1538 |
|
|
} elsif ($in_group && $t =~ s/^\#($xml_re{Name})//) {
|
| 1539 |
|
|
my $kwd = $1;
|
| 1540 |
|
|
unless ($delimited) {
|
| 1541 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_NO_DELIMITER',
|
| 1542 |
|
|
t => $kwd);
|
| 1543 |
|
|
} else {
|
| 1544 |
|
|
$delimited = 0;
|
| 1545 |
|
|
}
|
| 1546 |
|
|
if ($in_group > 1 || $grp_connector[$in_group]) {
|
| 1547 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_KWD_POSITION',
|
| 1548 |
|
|
t => $kwd);
|
| 1549 |
|
|
}
|
| 1550 |
|
|
if ($kwd ne 'PCDATA') {
|
| 1551 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_UNKNOWN_KWD',
|
| 1552 |
|
|
t => $kwd);
|
| 1553 |
|
|
} else {
|
| 1554 |
|
|
$is_pcdata = 1;
|
| 1555 |
|
|
$r->set_attribute (content => 'mixed');
|
| 1556 |
|
|
}
|
| 1557 |
|
|
} elsif ($in_group && $t =~ s/^([|,&])//) {
|
| 1558 |
|
|
my $connector = $1;
|
| 1559 |
|
|
if ($delimited) {
|
| 1560 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_INVALID_CONNECTOR',
|
| 1561 |
|
|
t => $connector.substr ($t, 0, 9));
|
| 1562 |
|
|
} else {
|
| 1563 |
|
|
$delimited = 1;
|
| 1564 |
|
|
}
|
| 1565 |
|
|
if ($connector eq '&') {
|
| 1566 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_SGML_CONNECTOR',
|
| 1567 |
|
|
t => $connector);
|
| 1568 |
|
|
$connector = ',';
|
| 1569 |
|
|
} elsif ($is_pcdata && $connector ne '|') {
|
| 1570 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_PCDATA_CONNECTOR',
|
| 1571 |
|
|
t => $connector);
|
| 1572 |
|
|
$connector = '|';
|
| 1573 |
|
|
}
|
| 1574 |
|
|
unless ($grp_connector[$in_group]) {
|
| 1575 |
|
|
$grp_connector[$in_group] = $connector;
|
| 1576 |
|
|
$c->set_attribute (connector => $connector);
|
| 1577 |
|
|
} elsif ($grp_connector[$in_group] ne $connector) {
|
| 1578 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_SAME_CONNECTOR',
|
| 1579 |
|
|
t => [$grp_connector[$in_group], $connector]);
|
| 1580 |
|
|
}
|
| 1581 |
|
|
} elsif ($t =~ s/^\(//) {
|
| 1582 |
|
|
unless ($delimited) {
|
| 1583 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_NO_DELIMITER',
|
| 1584 |
|
|
t => '('.substr ($t, 0, 9));
|
| 1585 |
|
|
}
|
| 1586 |
|
|
if ($is_pcdata) {
|
| 1587 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_MIXED_NESTED');
|
| 1588 |
|
|
} else {
|
| 1589 |
|
|
$c = $c->append_new_node (type => '#element', namespace_uri => $NS{SGML}.'element',
|
| 1590 |
|
|
local_name => 'group');
|
| 1591 |
|
|
}
|
| 1592 |
|
|
$in_group++;
|
| 1593 |
|
|
$grp_connector[$in_group] = undef;
|
| 1594 |
|
|
$delimited = 1;
|
| 1595 |
|
|
} elsif ($in_group && $t =~ s/^\)//) {
|
| 1596 |
|
|
if ($delimited) {
|
| 1597 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_INVALID_CONNECTOR',
|
| 1598 |
|
|
t => ')'.substr ($t, 0, 9));
|
| 1599 |
|
|
$delimited = 0;
|
| 1600 |
|
|
}
|
| 1601 |
|
|
if ($t =~ s/^([+*?])//) {
|
| 1602 |
|
|
my $occur = $1;
|
| 1603 |
|
|
if ($is_pcdata && $occur ne '*') {
|
| 1604 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_MIXED_OCCURENCE',
|
| 1605 |
|
|
t => $occur);
|
| 1606 |
|
|
}
|
| 1607 |
|
|
$c->set_attribute (occurence => $occur);
|
| 1608 |
|
|
} elsif ($is_pcdata && $grp_connector[$in_group]) {
|
| 1609 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_MIXED_OCCURENCE');
|
| 1610 |
|
|
}
|
| 1611 |
|
|
$c = $c->parent_node;
|
| 1612 |
|
|
$in_group--;
|
| 1613 |
|
|
last if !$in_group;
|
| 1614 |
|
|
} else {
|
| 1615 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10));
|
| 1616 |
|
|
substr ($t, 0, 1) = '';
|
| 1617 |
|
|
}
|
| 1618 |
|
|
} # $t
|
| 1619 |
|
|
if ($in_group) {
|
| 1620 |
wakaba |
1.14 |
## Note: Maybe this error will not happen since md_params parsing report it
|
| 1621 |
w |
1.8 |
$self->_raise_error ($o, c => $c, type => 'SYNTAX_ELEMENT_CMODEL_GROUP_NOT_CLOSED');
|
| 1622 |
|
|
}
|
| 1623 |
|
|
|
| 1624 |
|
|
if ($t =~ /[^$xml_re{_s__chars}]/) {
|
| 1625 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_INVALID_MD', t => $t);
|
| 1626 |
|
|
}
|
| 1627 |
wakaba |
1.1 |
}
|
| 1628 |
|
|
|
| 1629 |
|
|
|
| 1630 |
w |
1.8 |
sub _parse_attlist_declaration ($$$$;%) {
|
| 1631 |
|
|
my ($self, $s, $c, $o, %opt) = (@_);
|
| 1632 |
|
|
$c = $c->append_new_node (type => '#declaration', namespace_uri => $NS{SGML}.'attlist');
|
| 1633 |
w |
1.9 |
$c->flag (smxp__declaration_may_not_be_read
|
| 1634 |
|
|
=> $c->root_node->flag ('smxp__declaration_may_not_be_read'));
|
| 1635 |
w |
1.8 |
unless ($$s =~ s/^<!ATTLIST//s) {
|
| 1636 |
|
|
$self->_raise_error ($o, type => 'UNKNOWN', c => $c, t => substr ($$s, 0, 10));
|
| 1637 |
|
|
return;
|
| 1638 |
|
|
}
|
| 1639 |
|
|
$self->_clp (_________ => $o);
|
| 1640 |
|
|
|
| 1641 |
w |
1.9 |
my $dont_process = $c->root_node->flag ('smxp__stop_read_dtd');
|
| 1642 |
w |
1.8 |
my $t = $self->_parse_md_params ($c, $s, $o, entMan => $opt{entMan}, return_by_mdc => 1);
|
| 1643 |
w |
1.9 |
$dont_process = $c->root_node->flag ('smxp__stop_read_dtd');
|
| 1644 |
w |
1.8 |
|
| 1645 |
w |
1.9 |
unless ($dont_process) {
|
| 1646 |
|
|
## Element type name
|
| 1647 |
w |
1.10 |
my $type_qname;
|
| 1648 |
w |
1.9 |
if ($t =~ s/^($xml_re{s}($xml_re{Name}))//s) {
|
| 1649 |
w |
1.10 |
$type_qname = $2;
|
| 1650 |
w |
1.9 |
if (substr ($type_qname, 0, 1) eq ':' || substr ($type_qname, -1, 1) eq ':') {
|
| 1651 |
|
|
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_NAME_IS_QNNAME', t => $type_qname);
|
| 1652 |
|
|
$type_qname =~ tr/:/_/;
|
| 1653 |
|
|
}
|
| 1654 |
w |
1.10 |
if ($opt{entMan}->is_declared_entity ($type_qname, namespace_uri => $NS{SGML}.'attlist',
|
| 1655 |
|
|
dont_use_predefined_entities => 1,
|
| 1656 |
|
|
seek => 0)) {
|
| 1657 |
|
|
$self->_raise_error ($o, c => $c,
|
| 1658 |
|
|
type => 'WARN_XML_ATTLIST_AT_MOST_ONE_DECLARATION', t => $type_qname);
|
| 1659 |
|
|
} else { ## Regist to entMan
|
| 1660 |
|
|
$opt{entMan}->is_declared_entity ($type_qname, namespace_uri => $NS{SGML}.'attlist',
|
| 1661 |
|
|
dont_use_predefined_entities => 1,
|
| 1662 |
|
|
set_value => 1, seek => 0)
|
| 1663 |
|
|
}
|
| 1664 |
w |
1.9 |
$c->set_attribute (qname => $type_qname);
|
| 1665 |
|
|
} else {
|
| 1666 |
|
|
$self->_raise_error ($o, c => $c, type => 'SYNTAX_INVALID_MD', t => substr ($t, 0, 10));
|
| 1667 |
|
|
return;
|
| 1668 |
wakaba |
1.1 |
}
|
| 1669 |
w |
1.9 |
|
| 1670 |
|
|
## Definition
|
| 1671 |
|
|
my %defined;
|
| 1672 |
|
|
while ($t) {
|
| 1673 |
|
|
if ($t =~ s/^$xml_re{s}($xml_re{Name})//s) {
|
| 1674 |
|
|
my %attr = (name => $1, type => undef);
|
| 1675 |
|
|
if (substr ($attr{name}, 0, 1) eq ':' || substr ($attr{name}, -1, 1) eq ':') {
|
| 1676 |
|
|
$self->_raise_error ($o, c => $c, type => 'NS_SYNTAX_NAME_IS_QNNAME', t => $attr{name});
|
| 1677 |
|
|
$attr{name} =~ tr/:/_/;
|
| 1678 |
|
|
}
|
| 1679 |
|
|
if ($defined{$attr{name}}) {
|
| 1680 |
|
|
$self->_raise_error ($o, c => $c, type => 'WARN_XML_ATTLIST_AT_MOST_ONE_ATTR_DEF',
|
| 1681 |
|
|
t => $attr{name});
|
| 1682 |
|
|
} else {
|
| 1683 |
|
|
$defined{$attr{name}} = 1;
|
| 1684 |
|
|
}
|
| 1685 |
|
|
$attr{node} = $c->append_new_node (type => '#element', namespace_uri => $NS{XML}.'attlist',
|
| 1686 |
|
|
local_name => 'AttDef');
|
| 1687 |
|
|
$attr{node}->set_attribute (qname => $attr{name});
|
| 1688 |
|
|
if ($t =~ s/^$xml_re{s}//s) {
|
| 1689 |
w |
1.11 |
if ($t =~ s/^NOTATION//) {
|
| 1690 |
w |
1.9 |
$attr{type} = 'NOTATION';
|
| 1691 |
w |
1.11 |
unless ($t =~ s/^$xml_re{s}//s) {
|
| 1692 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_INVALID_MD', c => $c,
|
| 1693 |
|
|
t => substr ($t, 0, 10));
|
| 1694 |
|
|
}
|
| 1695 |
w |
1.8 |
}
|
| 1696 |
w |
1.9 |
if (!$attr{type} && $t =~ s/^([A-Za-z]+)//) { # attname type
|
| 1697 |
|
|
$attr{type} = $1;
|
| 1698 |
|
|
unless ({qw/CDATA 1 ID 1 IDREF 1 IDREFS 1 NMTOKEN 1 NMTOKENS 1
|
| 1699 |
|
|
ENTITY 1 ENTITIES 1/}->{$attr{type}}) {
|
| 1700 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTLIST_ATTDEF_UNKNOWN_TYPE',
|
| 1701 |
|
|
c => $c, t => $attr{type});
|
| 1702 |
|
|
}
|
| 1703 |
|
|
} elsif ($t =~ s/^\(([^)]+)\)//) { # attname (group)
|
| 1704 |
|
|
my $grp = $1;
|
| 1705 |
|
|
if (index ($grp, '(') > -1) {
|
| 1706 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTLIST_ATTDEF_NESTED_GROUP',
|
| 1707 |
|
|
c => $c, t => $grp);
|
| 1708 |
|
|
}
|
| 1709 |
|
|
if (index ($grp, '&') > -1 || index ($grp, ',') > -1) {
|
| 1710 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTLIST_ATTDEF_NON_BAR_CONNECTOR',
|
| 1711 |
|
|
c => $c, t => $grp);
|
| 1712 |
|
|
}
|
| 1713 |
|
|
if ($grp =~ s/([^\p{InXMLNameChar}$xml_re{_s__chars}|])//s) {
|
| 1714 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTLIST_ATTDEF_GROUP_INVALID_CHAR',
|
| 1715 |
w |
1.8 |
c => $c, t => $1);
|
| 1716 |
w |
1.9 |
$grp =~ s/([^\p{InXMLNameChar}$xml_re{_s__chars}|])//sg;
|
| 1717 |
|
|
} else {
|
| 1718 |
|
|
$grp =~ tr/\x09\x0A\x0D\x20//d; # $xml_re{_s__chars}
|
| 1719 |
|
|
if ($grp =~ /(^\||\|\||\|$)/) {
|
| 1720 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTLIST_ATTDEF_GROUP_INVALID_CONNECTOR',
|
| 1721 |
|
|
c => $c, t => $1);
|
| 1722 |
|
|
}
|
| 1723 |
|
|
}
|
| 1724 |
|
|
my @grp = grep {$_} split /\P{InXMLNameChar}+/, $grp;
|
| 1725 |
|
|
if ($attr{type}) { ## NOTATION
|
| 1726 |
|
|
for (@grp) {
|
| 1727 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTLIST_ATTDEF_GROUP_NOTATION_NAME',
|
| 1728 |
|
|
c => $c, t => $_)
|
| 1729 |
|
|
unless /^$xml_re{Name}$/;
|
| 1730 |
|
|
}
|
| 1731 |
|
|
} else {
|
| 1732 |
|
|
$attr{type} = 'enum';
|
| 1733 |
w |
1.8 |
}
|
| 1734 |
|
|
for (@grp) {
|
| 1735 |
w |
1.9 |
if ($attr{enum}->{$_}) {
|
| 1736 |
|
|
$self->_raise_error ($o, type => 'VC_NO_DUPLICATE_TOKENS', c => $c, t => $_);
|
| 1737 |
|
|
} else {
|
| 1738 |
|
|
$attr{enum}->{$_} = 1;
|
| 1739 |
|
|
$attr{node}->append_new_node (type => '#element',
|
| 1740 |
|
|
namespace_uri => $NS{XML}.'attlist',
|
| 1741 |
|
|
local_name => 'enum')
|
| 1742 |
|
|
->append_text ($_);
|
| 1743 |
|
|
}
|
| 1744 |
w |
1.8 |
}
|
| 1745 |
w |
1.11 |
} else { # attname #somewhat or attname NOTATION non-group
|
| 1746 |
w |
1.9 |
$self->_raise_error ($o, type => 'SYNTAX_INVALID_MD', c => $c, t => substr ($t, 0, 10));
|
| 1747 |
w |
1.11 |
$attr{type} ||= 'CDATA';
|
| 1748 |
w |
1.9 |
next;
|
| 1749 |
w |
1.8 |
}
|
| 1750 |
w |
1.9 |
$attr{node}->set_attribute (type => $attr{type});
|
| 1751 |
|
|
|
| 1752 |
|
|
## DefaultDecl
|
| 1753 |
|
|
if ($t =~ s/^$xml_re{s}\#FIXED//s) {
|
| 1754 |
|
|
$attr{deftype} = 'FIXED';
|
| 1755 |
|
|
$attr{node}->set_attribute (default_type => $attr{deftype});
|
| 1756 |
w |
1.8 |
}
|
| 1757 |
w |
1.9 |
if ($t =~ s/^$xml_re{s}//s) {
|
| 1758 |
|
|
if (!$attr{deftype} && $t =~ s/^\#([A-Za-z-]+)//) {
|
| 1759 |
|
|
$attr{deftype} = $1;
|
| 1760 |
|
|
unless ({qw/IMPLIED 1 REQUIRED 1/}->{$attr{deftype}}) {
|
| 1761 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTLIST_ATTDEF_UNKNOWN_DEFAULT', c => $c,
|
| 1762 |
|
|
t => '#'.$attr{deftype});
|
| 1763 |
|
|
}
|
| 1764 |
|
|
$attr{node}->set_attribute (default_type => $attr{deftype});
|
| 1765 |
|
|
} elsif ($t =~ s/^($xml_re{__AttValue_simple})//s) { # attname type "literal"
|
| 1766 |
|
|
$attr{defvalue} = $attr{node}->set_attribute ('default_value');
|
| 1767 |
|
|
my $pcdata = substr ($1, 1, length ($1) - 2);
|
| 1768 |
|
|
$self->_parse_attr_value_literal_data ($attr{defvalue}, \$pcdata, $o,
|
| 1769 |
|
|
entMan => $opt{entMan});
|
| 1770 |
|
|
} elsif ($attr{deftype}) { # deftype eq FIXED
|
| 1771 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTLIST_ATTDEF_FIXED_NO_LITERAL', c => $c,
|
| 1772 |
|
|
t => [$attr{name}, substr ($t, 0, 10)]);
|
| 1773 |
|
|
next;
|
| 1774 |
|
|
} else { # attname type $invalid
|
| 1775 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_INVALID_MD', c => $c,
|
| 1776 |
|
|
t => substr ($t, 0, 10));
|
| 1777 |
|
|
next;
|
| 1778 |
w |
1.8 |
}
|
| 1779 |
|
|
} elsif ($attr{deftype}) { # deftype eq FIXED
|
| 1780 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_ATTLIST_ATTDEF_FIXED_NO_LITERAL', c => $c,
|
| 1781 |
|
|
t => [$attr{name}, substr ($t, 0, 10)]);
|
| 1782 |
|
|
next;
|
| 1783 |
w |
1.9 |
} else { # attname type$invalid
|
| 1784 |
|
|
$self->_raise_error ($o, type => 'SYNTAX_INVALID_MD', c => $c, t => substr ($t, 0, 10));
|
| 1785 |
w |
1.8 |
next;
|
| 1786 |
|
|
}
|
| 1787 |
w |
1.9 |
} else { # attname#somewhat
|
| 1788 |
w |
1.8 |
$self->_raise_error ($o, type => 'SYNTAX_INVALID_MD', c => $c, t => substr ($t, 0, 10));
|
| 1789 |
|
|
next;
|
| 1790 |
|
|
}
|
| 1791 |
w |
1.9 |
} elsif ($t =~ s/$xml_re{s}$//s) {
|
| 1792 |
|
|
} else {
|
| 1793 |
w |
1.8 |
$self->_raise_error ($o, type => 'SYNTAX_INVALID_MD', c => $c, t => substr ($t, 0, 10));
|
| 1794 |
w |
1.9 |
substr ($t, 0, 1) = '';
|
| 1795 |
w |
1.8 |
}
|
| 1796 |
w |
1.9 |
} # $t
|
| 1797 |
w |
1.10 |
unless (scalar keys %defined) {
|
| 1798 |
|
|
$self->_raise_error ($o, c => $c, type => 'WARN_XML_ATTLIST_AT_LEAST_ONE_ATTR_DEF',
|
| 1799 |
|
|
t => $type_qname);
|
| 1800 |
|
|
}
|
| 1801 |
w |
1.9 |
} else { ## dont_process
|
| 1802 |
|
|
$c->flag (smxp__non_processed_declaration => 1);
|
| 1803 |
|
|
$self->_raise_error ($o, c => $c, type => 'WARN_ATTLIST_DECLARATION_NOT_PROCESSED');
|
| 1804 |
|
|
}
|
| 1805 |
wakaba |
1.1 |
}
|
| 1806 |
|
|
|
| 1807 |
|
|
sub _is_brother_of_root_element ($$) {
|
| 1808 |
|
|
my ($self, $c) = @_;
|
| 1809 |
|
|
for (@{$c->child_nodes}) {
|
| 1810 |
|
|
if ($_->node_type eq '#element') {
|
| 1811 |
|
|
return 1;
|
| 1812 |
|
|
}
|
| 1813 |
|
|
}
|
| 1814 |
|
|
return 0;
|
| 1815 |
|
|
}
|
| 1816 |
|
|
|
| 1817 |
wakaba |
1.5 |
## [internal] URI escaping unsafe characters
|
| 1818 |
|
|
## $s = $parser->_uri_escape ($s)
|
| 1819 |
|
|
sub _uri_escape ($$) {
|
| 1820 |
|
|
shift;
|
| 1821 |
|
|
my $s = shift; ## TODO: support utf8 flag
|
| 1822 |
|
|
$s =~ s/([^0-9A-Za-z_.-])/sprintf '%%%02X', ord $1/ge;
|
| 1823 |
|
|
$s;
|
| 1824 |
|
|
}
|
| 1825 |
|
|
|
| 1826 |
|
|
## [internal] Duplication of HASH reference
|
| 1827 |
|
|
## $ref = $parser->_make_clone_of ($ref)
|
| 1828 |
|
|
sub _make_clone_of ($$;%) {
|
| 1829 |
|
|
my ($self, $mother, %o) = @_;
|
| 1830 |
|
|
if (ref $mother eq 'HASH') {
|
| 1831 |
|
|
my $child = {};
|
| 1832 |
|
|
$o{m_vs_c}->{$mother} = $child;
|
| 1833 |
|
|
for (keys %$mother) {
|
| 1834 |
|
|
if (ref ($mother->{$_}) eq 'HASH') {
|
| 1835 |
|
|
$child->{$_} = $o{m_vs_c}->{$mother->{$_}} || $self->_make_clone_of ($mother->{$_});
|
| 1836 |
|
|
} elsif (index (ref ($mother->{$_}), 'URI') > -1) {
|
| 1837 |
|
|
$child->{$_} = $mother->{$_}->clone;
|
| 1838 |
|
|
## BUG: $mother->{$A} === $mother->{$B}, then two clones are created
|
| 1839 |
|
|
## BUG: if CODE, ARRAY, blessed,...
|
| 1840 |
|
|
} else {
|
| 1841 |
|
|
$child->{$_} = $mother->{$_};
|
| 1842 |
|
|
}
|
| 1843 |
|
|
}
|
| 1844 |
|
|
return $child;
|
| 1845 |
|
|
} else {
|
| 1846 |
|
|
## BUG: not supported
|
| 1847 |
|
|
}
|
| 1848 |
|
|
}
|
| 1849 |
|
|
|
| 1850 |
|
|
## [obsolete] [internal] Count up line/position
|
| 1851 |
|
|
## _count_lp ($string, $o)
|
| 1852 |
|
|
sub _count_lp ($$) {
|
| 1853 |
|
|
my ($s, $o) = @_;
|
| 1854 |
|
|
$s =~ s/[^\x0A\x0D]*(?:\x0D\x0A?|\x0A)/$o->{line}++;$o->{pos}=0;''/ges;
|
| 1855 |
|
|
$o->{pos} += length $s;
|
| 1856 |
|
|
}
|
| 1857 |
|
|
## [internal] Count up line/position
|
| 1858 |
|
|
## $self->_clp ($string, $o)
|
| 1859 |
|
|
sub _clp ($$$) {
|
| 1860 |
wakaba |
1.6 |
my (undef, $s => $o) = @_;
|
| 1861 |
|
|
$s =~ s/[^\x0A]*\x0A/$o->{line}++; $o->{pos} = 0; ''/ges;
|
| 1862 |
wakaba |
1.5 |
$o->{pos} += length $s;
|
| 1863 |
|
|
}
|
| 1864 |
|
|
|
| 1865 |
|
|
## [internal] Split QName into prefix and NCName
|
| 1866 |
|
|
## ($prefix or undef, $NCName) = $parser->_ns_parse_qname ($QName)
|
| 1867 |
|
|
sub _ns_parse_qname ($$) {
|
| 1868 |
wakaba |
1.6 |
my $qname = $_[1];
|
| 1869 |
wakaba |
1.5 |
if ($qname =~ /:/) {
|
| 1870 |
|
|
return split /:/, $qname, 2;
|
| 1871 |
|
|
} else {
|
| 1872 |
|
|
return (undef, $qname);
|
| 1873 |
|
|
}
|
| 1874 |
|
|
}
|
| 1875 |
|
|
|
| 1876 |
wakaba |
1.7 |
|
| 1877 |
|
|
sub option ($$;$) {
|
| 1878 |
|
|
my ($self, $name, $value) = @_;
|
| 1879 |
|
|
if (defined $value) {
|
| 1880 |
|
|
$self->{option}->{$name} = $value;
|
| 1881 |
|
|
}
|
| 1882 |
|
|
$self->{option}->{$name};
|
| 1883 |
|
|
}
|
| 1884 |
|
|
|
| 1885 |
|
|
sub flag ($$;$) {
|
| 1886 |
|
|
my ($self, $name, $value) = @_;
|
| 1887 |
|
|
if (defined $value) {
|
| 1888 |
|
|
$self->{flag}->{$name} = $value;
|
| 1889 |
|
|
}
|
| 1890 |
|
|
$self->{flag}->{$name};
|
| 1891 |
|
|
}
|
| 1892 |
|
|
|
| 1893 |
w |
1.9 |
=head1 FLAG NAMES DEFINED BY THIS MODULE
|
| 1894 |
|
|
|
| 1895 |
wakaba |
1.12 |
=head2 Flag for Message::Markup::XML instance
|
| 1896 |
w |
1.9 |
|
| 1897 |
|
|
=over 4
|
| 1898 |
|
|
|
| 1899 |
|
|
=item smxp__declaration_may_not_be_read = 1/0 (root node)
|
| 1900 |
|
|
|
| 1901 |
|
|
Whether after this flag is trued entity/attlist declarations may not
|
| 1902 |
|
|
be processed (bacause of declared in external entity or declared after
|
| 1903 |
|
|
some external entity reference) or not.
|
| 1904 |
|
|
|
| 1905 |
|
|
=item smxp__declaration_may_not_be_read = 1/0 (#declaration node)
|
| 1906 |
|
|
|
| 1907 |
|
|
Whether entity/attlist declaration may not be processed or not.
|
| 1908 |
|
|
|
| 1909 |
|
|
=item smxp__defined_with_param_ref = 1/0 (#declaration node)
|
| 1910 |
|
|
|
| 1911 |
|
|
Whether the declaration is defined with one or more parameter entity or not.
|
| 1912 |
|
|
|
| 1913 |
|
|
=item smxp__entity_manager = instance of entity manager (root node)
|
| 1914 |
|
|
|
| 1915 |
|
|
=item smxp__entity_replacement_text_md_params = semi-parsed text (Parameter entity #declaration node)
|
| 1916 |
|
|
|
| 1917 |
|
|
=item smxp__entity_replacement_text_rpdata = semi-parsed text (Parameter entity #declaration node)
|
| 1918 |
|
|
|
| 1919 |
|
|
=item smxp__is_dtd_default = 1/0 (#attribute node)
|
| 1920 |
|
|
|
| 1921 |
|
|
Whether the attribute (name and value) is not specified explicily in STag
|
| 1922 |
|
|
so completed from DTD's attlist declaration or not.
|
| 1923 |
|
|
|
| 1924 |
|
|
=item smxp__non_processed_declaration = 1/0 (Entity/attlist #declaration node)
|
| 1925 |
|
|
|
| 1926 |
|
|
Whether the declaration is not read 'cause of smxp__stop_read_dtd'ed or not.
|
| 1927 |
|
|
|
| 1928 |
|
|
=item smxp__original_qname = QName as specified in STag
|
| 1929 |
|
|
|
| 1930 |
|
|
(Only used to check STag-ETag matching.)
|
| 1931 |
|
|
|
| 1932 |
|
|
=item smxp__ref_expanded = 1/0 (#reference node)
|
| 1933 |
|
|
|
| 1934 |
|
|
Whether the reference is expanded or not
|
| 1935 |
|
|
|
| 1936 |
|
|
=item smxp__src_pos = "$o" object
|
| 1937 |
|
|
|
| 1938 |
|
|
Start position in source entity (is this flag obsolete??)
|
| 1939 |
|
|
|
| 1940 |
|
|
=item smxp__stop_read_dtd = 1/0 (root node)
|
| 1941 |
|
|
|
| 1942 |
|
|
Whether reading entity/attlist declaration is stopped 'cause of
|
| 1943 |
|
|
some of external entity required to interpret the DTD is not processed
|
| 1944 |
|
|
or not.
|
| 1945 |
|
|
|
| 1946 |
|
|
=item smxp__uri_in_which_declaration_is = uri (Entity #declaration node)
|
| 1947 |
|
|
|
| 1948 |
|
|
=cut
|
| 1949 |
|
|
|
| 1950 |
wakaba |
1.1 |
=head1 LICENSE
|
| 1951 |
|
|
|
| 1952 |
|
|
Copyright 2003 Wakaba <[email protected]>
|
| 1953 |
|
|
|
| 1954 |
|
|
This program is free software; you can redistribute it and/or
|
| 1955 |
|
|
modify it under the same terms as Perl itself.
|
| 1956 |
|
|
|
| 1957 |
|
|
=cut
|
| 1958 |
|
|
|
| 1959 |
wakaba |
1.14 |
1; # $Date: 2003/09/12 11:29:26 $
|
Parent Directory
| 
Revision Log