/[suikacvs]/messaging/manakai/lib/Message/Markup/XML/Parser.pm
Suika

Contents of /messaging/manakai/lib/Message/Markup/XML/Parser.pm

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.24 - (show annotations) (download)
Sun Sep 10 11:19:24 2006 UTC (19 years, 10 months ago) by wakaba
Branch: MAIN
CVS Tags: manakai-release-0-4-0, manakai-200612, HEAD
Changes since 1.23: +5 -5 lines 
++ manakai/bin/ChangeLog	10 Sep 2006 11:09:00 -0000
2006-09-10  Wakaba  <wakaba@suika.fam.cx>

	* daf.pl (--dtd-suffix, --create-dtd-driver): New options
	for DTD driver support.

++ manakai/lib/Message/Markup/ChangeLog	10 Sep 2006 11:12:09 -0000
2006-09-10  Wakaba  <wakaba@suika.fam.cx>

	* Atom.dis (Atom): The |mv:systemIdentifierBaseURI|
	property is set.  It is an empty value to allow to move
	DTD modules without modification.
	(Atom10): New DTD driver for ordinary Atom 1.0 documents.
	(AtomNameElement, AtomUriElement, AtomEmailElement): References
	for |Atom| module are added for |%ATOM.xmlns.attrib;|
	references in the |ATTLIST| declarations.
	(AtomContentElement): Content attribute definitions
	for |type| and |src| attributes are added.

	* Makefile (atom): Generate |Atom10| DTD driver.

++ manakai/lib/Message/Markup/XML/ChangeLog	10 Sep 2006 11:13:04 -0000
2006-09-10  Wakaba  <wakaba@suika.fam.cx>

	* Parser.pm: Comment out Unicode comparibility character
	checking clause since |\p{Compat}| regexp set is not
	supported in the current version of perl.

++ manakai/lib/manakai/ChangeLog	10 Sep 2006 11:19:19 -0000
2006-09-10  Wakaba  <wakaba@suika.fam.cx>

	* DISMarkup.dis (mv:systemIdentifierBaseURI): New property.
	(mv:XMLDTDAnyModule, mv:XMLDTDDriver): New resource types.

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