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