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