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