| 1 |
package Whatpm::XML::Parser; |
| 2 |
use strict; |
| 3 |
|
| 4 |
push our @ISA, 'Whatpm::HTML'; |
| 5 |
use Whatpm::HTML::Tokenizer qw/:token/; |
| 6 |
|
| 7 |
sub parse_char_string ($$$;$$) { |
| 8 |
#my ($self, $s, $doc, $onerror, $get_wrapper) = @_; |
| 9 |
my $self = shift; |
| 10 |
my $s = ref $_[0] ? $_[0] : \($_[0]); |
| 11 |
require Whatpm::Charset::DecodeHandle; |
| 12 |
my $input = Whatpm::Charset::DecodeHandle::CharString->new ($s); |
| 13 |
return $self->parse_char_stream ($input, @_[1..$#_]); |
| 14 |
} # parse_char_string |
| 15 |
|
| 16 |
sub parse_char_stream ($$$;$$) { |
| 17 |
my $self = ref $_[0] ? shift : shift->new; |
| 18 |
my $input = $_[0]; |
| 19 |
$self->{document} = $_[1]; |
| 20 |
@{$self->{document}->child_nodes} = (); |
| 21 |
|
| 22 |
## NOTE: |set_inner_html| copies most of this method's code |
| 23 |
|
| 24 |
$self->{confident} = 1 unless exists $self->{confident}; |
| 25 |
$self->{document}->input_encoding ($self->{input_encoding}) |
| 26 |
if defined $self->{input_encoding}; |
| 27 |
## TODO: |{input_encoding}| is needless? |
| 28 |
|
| 29 |
$self->{line_prev} = $self->{line} = 1; |
| 30 |
$self->{column_prev} = -1; |
| 31 |
$self->{column} = 0; |
| 32 |
$self->{set_nc} = sub { |
| 33 |
my $self = shift; |
| 34 |
|
| 35 |
my $char = ''; |
| 36 |
if (defined $self->{next_nc}) { |
| 37 |
$char = $self->{next_nc}; |
| 38 |
delete $self->{next_nc}; |
| 39 |
$self->{nc} = ord $char; |
| 40 |
} else { |
| 41 |
$self->{char_buffer} = ''; |
| 42 |
$self->{char_buffer_pos} = 0; |
| 43 |
|
| 44 |
my $count = $input->manakai_read_until |
| 45 |
($self->{char_buffer}, qr/[^\x00\x0A\x0D]/, $self->{char_buffer_pos}); |
| 46 |
if ($count) { |
| 47 |
$self->{line_prev} = $self->{line}; |
| 48 |
$self->{column_prev} = $self->{column}; |
| 49 |
$self->{column}++; |
| 50 |
$self->{nc} |
| 51 |
= ord substr ($self->{char_buffer}, $self->{char_buffer_pos}++, 1); |
| 52 |
return; |
| 53 |
} |
| 54 |
|
| 55 |
if ($input->read ($char, 1)) { |
| 56 |
$self->{nc} = ord $char; |
| 57 |
} else { |
| 58 |
$self->{nc} = -1; |
| 59 |
return; |
| 60 |
} |
| 61 |
} |
| 62 |
|
| 63 |
($self->{line_prev}, $self->{column_prev}) |
| 64 |
= ($self->{line}, $self->{column}); |
| 65 |
$self->{column}++; |
| 66 |
|
| 67 |
if ($self->{nc} == 0x000A) { # LF |
| 68 |
!!!cp ('j1'); |
| 69 |
$self->{line}++; |
| 70 |
$self->{column} = 0; |
| 71 |
} elsif ($self->{nc} == 0x000D) { # CR |
| 72 |
!!!cp ('j2'); |
| 73 |
## TODO: support for abort/streaming |
| 74 |
my $next = ''; |
| 75 |
if ($input->read ($next, 1) and $next ne "\x0A") { |
| 76 |
$self->{next_nc} = $next; |
| 77 |
} |
| 78 |
$self->{nc} = 0x000A; # LF # MUST |
| 79 |
$self->{line}++; |
| 80 |
$self->{column} = 0; |
| 81 |
} elsif ($self->{nc} == 0x0000) { # NULL |
| 82 |
!!!cp ('j4'); |
| 83 |
!!!parse-error (type => 'NULL'); |
| 84 |
$self->{nc} = 0xFFFD; # REPLACEMENT CHARACTER # MUST |
| 85 |
} |
| 86 |
}; |
| 87 |
|
| 88 |
$self->{read_until} = sub { |
| 89 |
#my ($scalar, $specials_range, $offset) = @_; |
| 90 |
return 0 if defined $self->{next_nc}; |
| 91 |
|
| 92 |
my $pattern = qr/[^$_[1]\x00\x0A\x0D]/; |
| 93 |
my $offset = $_[2] || 0; |
| 94 |
|
| 95 |
if ($self->{char_buffer_pos} < length $self->{char_buffer}) { |
| 96 |
pos ($self->{char_buffer}) = $self->{char_buffer_pos}; |
| 97 |
if ($self->{char_buffer} =~ /\G(?>$pattern)+/) { |
| 98 |
substr ($_[0], $offset) |
| 99 |
= substr ($self->{char_buffer}, $-[0], $+[0] - $-[0]); |
| 100 |
my $count = $+[0] - $-[0]; |
| 101 |
if ($count) { |
| 102 |
$self->{column} += $count; |
| 103 |
$self->{char_buffer_pos} += $count; |
| 104 |
$self->{line_prev} = $self->{line}; |
| 105 |
$self->{column_prev} = $self->{column} - 1; |
| 106 |
$self->{nc} = -1; |
| 107 |
} |
| 108 |
return $count; |
| 109 |
} else { |
| 110 |
return 0; |
| 111 |
} |
| 112 |
} else { |
| 113 |
my $count = $input->manakai_read_until ($_[0], $pattern, $_[2]); |
| 114 |
if ($count) { |
| 115 |
$self->{column} += $count; |
| 116 |
$self->{line_prev} = $self->{line}; |
| 117 |
$self->{column_prev} = $self->{column} - 1; |
| 118 |
$self->{nc} = -1; |
| 119 |
} |
| 120 |
return $count; |
| 121 |
} |
| 122 |
}; # $self->{read_until} |
| 123 |
|
| 124 |
my $onerror = $_[2] || sub { |
| 125 |
my (%opt) = @_; |
| 126 |
my $line = $opt{token} ? $opt{token}->{line} : $opt{line}; |
| 127 |
my $column = $opt{token} ? $opt{token}->{column} : $opt{column}; |
| 128 |
warn "Parse error ($opt{type}) at line $line column $column\n"; |
| 129 |
}; |
| 130 |
$self->{parse_error} = sub { |
| 131 |
$onerror->(line => $self->{line}, column => $self->{column}, @_); |
| 132 |
}; |
| 133 |
|
| 134 |
my $char_onerror = sub { |
| 135 |
my (undef, $type, %opt) = @_; |
| 136 |
!!!parse-error (layer => 'encode', |
| 137 |
line => $self->{line}, column => $self->{column} + 1, |
| 138 |
%opt, type => $type); |
| 139 |
}; # $char_onerror |
| 140 |
|
| 141 |
if ($_[3]) { |
| 142 |
$input = $_[3]->($input); |
| 143 |
$input->onerror ($char_onerror); |
| 144 |
} else { |
| 145 |
$input->onerror ($char_onerror) unless defined $input->onerror; |
| 146 |
} |
| 147 |
|
| 148 |
$self->_initialize_tokenizer; |
| 149 |
$self->_initialize_tree_constructor; |
| 150 |
$self->_construct_tree; |
| 151 |
$self->_terminate_tree_constructor; |
| 152 |
|
| 153 |
delete $self->{parse_error}; # remove loop |
| 154 |
|
| 155 |
return $self->{document}; |
| 156 |
} # parse_char_stream |
| 157 |
|
| 158 |
sub new ($) { |
| 159 |
my $class = shift; |
| 160 |
my $self = bless { |
| 161 |
level => {must => 'm', |
| 162 |
should => 's', |
| 163 |
warn => 'w', |
| 164 |
info => 'i', |
| 165 |
uncertain => 'u'}, |
| 166 |
}, $class; |
| 167 |
$self->{set_nc} = sub { |
| 168 |
$self->{nc} = -1; |
| 169 |
}; |
| 170 |
$self->{parse_error} = sub { |
| 171 |
# |
| 172 |
}; |
| 173 |
$self->{change_encoding} = sub { |
| 174 |
# if ($_[0] is a supported encoding) { |
| 175 |
# run "change the encoding" algorithm; |
| 176 |
# throw Whatpm::HTML::RestartParser (charset => $new_encoding); |
| 177 |
# } |
| 178 |
}; |
| 179 |
$self->{application_cache_selection} = sub { |
| 180 |
# |
| 181 |
}; |
| 182 |
|
| 183 |
$self->{is_xml} = 1; |
| 184 |
|
| 185 |
return $self; |
| 186 |
} # new |
| 187 |
|
| 188 |
sub _initialize_tree_constructor ($) { |
| 189 |
my $self = shift; |
| 190 |
## NOTE: $self->{document} MUST be specified before this method is called |
| 191 |
$self->{document}->strict_error_checking (0); |
| 192 |
## TODO: Turn mutation events off # MUST |
| 193 |
$self->{document}->dom_config |
| 194 |
->{'http://suika.fam.cx/www/2006/dom-config/strict-document-children'} |
| 195 |
= 0; |
| 196 |
$self->{document}->manakai_is_html (0); |
| 197 |
$self->{document}->set_user_data (manakai_source_line => 1); |
| 198 |
$self->{document}->set_user_data (manakai_source_column => 1); |
| 199 |
} # _initialize_tree_constructor |
| 200 |
|
| 201 |
sub _terminate_tree_constructor ($) { |
| 202 |
my $self = shift; |
| 203 |
$self->{document}->strict_error_checking (1); |
| 204 |
$self->{document}->dom_config |
| 205 |
->{'http://suika.fam.cx/www/2006/dom-config/strict-document-children'} |
| 206 |
= 1; |
| 207 |
## TODO: Turn mutation events on |
| 208 |
} # _terminate_tree_constructor |
| 209 |
|
| 210 |
## Tree construction stage |
| 211 |
|
| 212 |
|
| 213 |
## NOTE: Differences from the XML5 draft are marked as "XML5:". |
| 214 |
|
| 215 |
## XML5: No namespace support. |
| 216 |
|
| 217 |
## XML5: XML5 has "empty tag token". In this implementation, it is |
| 218 |
## represented as a start tag token with $self->{self_closing} flag |
| 219 |
## set to true. |
| 220 |
|
| 221 |
## XML5: XML5 has "short end tag token". In this implementation, it |
| 222 |
## is represented as an end tag token with $token->{tag_name} flag set |
| 223 |
## to an empty string. |
| 224 |
|
| 225 |
## XML5: Start, main, end phases. In this implementation, they are |
| 226 |
## represented by insertion modes. |
| 227 |
|
| 228 |
## Insertion modes |
| 229 |
sub INITIAL_IM () { 0 } |
| 230 |
sub BEFORE_ROOT_ELEMENT_IM () { 1 } |
| 231 |
sub IN_ELEMENT_IM () { 2 } |
| 232 |
sub AFTER_ROOT_ELEMENT_IM () { 3 } |
| 233 |
|
| 234 |
{ |
| 235 |
my $token; ## TODO: change to $self->{t} |
| 236 |
|
| 237 |
sub _construct_tree ($) { |
| 238 |
my ($self) = @_; |
| 239 |
|
| 240 |
!!!next-token; |
| 241 |
|
| 242 |
delete $self->{tainted}; |
| 243 |
$self->{open_elements} = []; |
| 244 |
$self->{insertion_mode} = INITIAL_IM; |
| 245 |
|
| 246 |
while (1) { |
| 247 |
if ($self->{insertion_mode} == IN_ELEMENT_IM) { |
| 248 |
$self->_tree_in_element; |
| 249 |
} elsif ($self->{insertion_mode} == AFTER_ROOT_ELEMENT_IM) { |
| 250 |
$self->_tree_after_root_element; |
| 251 |
} elsif ($self->{insertion_mode} == BEFORE_ROOT_ELEMENT_IM) { |
| 252 |
$self->_tree_before_root_element; |
| 253 |
} elsif ($self->{insertion_mode} == INITIAL_IM) { |
| 254 |
$self->_tree_initial; |
| 255 |
} else { |
| 256 |
die "$0: Unknown XML insertion mode: $self->{insertion_mode}"; |
| 257 |
} |
| 258 |
|
| 259 |
last if $token->{type} == ABORT_TOKEN; |
| 260 |
} |
| 261 |
} # _construct_tree |
| 262 |
|
| 263 |
sub _tree_initial ($) { |
| 264 |
my $self = shift; |
| 265 |
|
| 266 |
B: while (1) { |
| 267 |
if ($token->{type} == DOCTYPE_TOKEN) { |
| 268 |
## XML5: No "DOCTYPE" token. |
| 269 |
|
| 270 |
my $doctype = $self->{document}->create_document_type_definition |
| 271 |
(defined $token->{name} ? $token->{name} : ''); |
| 272 |
|
| 273 |
## NOTE: Default value for both |public_id| and |system_id| attributes |
| 274 |
## are empty strings, so that we don't set any value in missing cases. |
| 275 |
$doctype->public_id ($token->{public_identifier}) |
| 276 |
if defined $token->{public_identifier}; |
| 277 |
$doctype->system_id ($token->{system_identifier}) |
| 278 |
if defined $token->{system_identifier}; |
| 279 |
|
| 280 |
## TODO: internal_subset |
| 281 |
|
| 282 |
$self->{document}->append_child ($doctype); |
| 283 |
|
| 284 |
$self->{insertion_mode} = BEFORE_ROOT_ELEMENT_IM; |
| 285 |
!!!next-token; |
| 286 |
return; |
| 287 |
} elsif ($token->{type} == START_TAG_TOKEN or |
| 288 |
$token->{type} == END_OF_FILE_TOKEN) { |
| 289 |
$self->{insertion_mode} = BEFORE_ROOT_ELEMENT_IM; |
| 290 |
## Reprocess. |
| 291 |
return; |
| 292 |
} elsif ($token->{type} == COMMENT_TOKEN) { |
| 293 |
my $comment = $self->{document}->create_comment ($token->{data}); |
| 294 |
$self->{document}->append_child ($comment); |
| 295 |
|
| 296 |
## Stay in the mode. |
| 297 |
!!!next-token; |
| 298 |
next B; |
| 299 |
} elsif ($token->{type} == PI_TOKEN) { |
| 300 |
my $pi = $self->{document}->create_processing_instruction |
| 301 |
($token->{target}, $token->{data}); |
| 302 |
$self->{document}->append_child ($pi); |
| 303 |
|
| 304 |
## Stay in the mode. |
| 305 |
!!!next-token; |
| 306 |
next B; |
| 307 |
} elsif ($token->{type} == CHARACTER_TOKEN) { |
| 308 |
if (not $self->{tainted} and |
| 309 |
$token->{data} =~ s/^([\x09\x0A\x0C\x20]+)//) { |
| 310 |
# |
| 311 |
} |
| 312 |
|
| 313 |
if (length $token->{data}) { |
| 314 |
## XML5: Ignore the token. |
| 315 |
|
| 316 |
unless ($self->{tainted}) { |
| 317 |
!!!parse-error (type => 'text outside of root element', |
| 318 |
token => $token); |
| 319 |
$self->{tainted} = 1; |
| 320 |
} |
| 321 |
|
| 322 |
$self->{document}->manakai_append_text ($token->{data}); |
| 323 |
} |
| 324 |
|
| 325 |
## Stay in the mode. |
| 326 |
!!!next-token; |
| 327 |
next B; |
| 328 |
} elsif ($token->{type} == END_TAG_TOKEN) { |
| 329 |
!!!parse-error (type => 'unmatched end tag', |
| 330 |
text => $token->{tag_name}, |
| 331 |
token => $token); |
| 332 |
## Ignore the token. |
| 333 |
|
| 334 |
## Stay in the mode. |
| 335 |
!!!next-token; |
| 336 |
next B; |
| 337 |
} elsif ($token->{type} == ABORT_TOKEN) { |
| 338 |
return; |
| 339 |
} else { |
| 340 |
die "$0: XML parser initial: Unknown token type $token->{type}"; |
| 341 |
} |
| 342 |
} # B |
| 343 |
} # _tree_initial |
| 344 |
|
| 345 |
sub _tree_before_root_element ($) { |
| 346 |
my $self = shift; |
| 347 |
|
| 348 |
B: while (1) { |
| 349 |
if ($token->{type} == START_TAG_TOKEN) { |
| 350 |
my $nsmap = { |
| 351 |
xml => q<http://www.w3.org/XML/1998/namespace>, |
| 352 |
xmlns => q<http://www.w3.org/2000/xmlns/>, |
| 353 |
}; |
| 354 |
|
| 355 |
for (keys %{$token->{attributes}}) { |
| 356 |
if (/^xmlns:./s) { |
| 357 |
my $prefix = substr $_, 6; |
| 358 |
my $value = $token->{attributes}->{$_}->{value}; |
| 359 |
if ($prefix eq 'xml' or $prefix eq 'xmlns' or |
| 360 |
$value eq q<http://www.w3.org/XML/1998/namespace> or |
| 361 |
$value eq q<http://www.w3.org/2000/xmlns/>) { |
| 362 |
## NOTE: Error should be detected at the DOM layer. |
| 363 |
# |
| 364 |
} elsif (length $value) { |
| 365 |
$nsmap->{$prefix} = $value; |
| 366 |
} else { |
| 367 |
delete $nsmap->{$prefix}; |
| 368 |
## TODO: Error unless XML1.1 |
| 369 |
} |
| 370 |
} elsif ($_ eq 'xmlns') { |
| 371 |
my $value = $token->{attributes}->{$_}->{value}; |
| 372 |
if ($value eq q<http://www.w3.org/XML/1998/namespace> or |
| 373 |
$value eq q<http://www.w3.org/2000/xmlns/>) { |
| 374 |
## NOTE: Error should be detected at the DOM layer. |
| 375 |
# |
| 376 |
} elsif (length $value) { |
| 377 |
$nsmap->{''} = $value; |
| 378 |
} else { |
| 379 |
delete $nsmap->{''}; |
| 380 |
} |
| 381 |
} |
| 382 |
} |
| 383 |
|
| 384 |
my $ns; |
| 385 |
my ($prefix, $ln) = split /:/, $token->{tag_name}, 2; |
| 386 |
|
| 387 |
if (defined $ln) { # prefixed |
| 388 |
if (defined $nsmap->{$prefix}) { |
| 389 |
$ns = $nsmap->{$prefix}; |
| 390 |
} else { |
| 391 |
## NOTE: Error should be detected at the DOM layer. |
| 392 |
($prefix, $ln) = (undef, $token->{tag_name}); |
| 393 |
} |
| 394 |
} else { |
| 395 |
($prefix, $ln) = (undef, $prefix); |
| 396 |
$ns = $nsmap->{''}; |
| 397 |
} |
| 398 |
|
| 399 |
my $el = $self->{document}->create_element_ns ($ns, [$prefix, $ln]); |
| 400 |
$el->set_user_data (manakai_source_line => $token->{line}); |
| 401 |
$el->set_user_data (manakai_source_column => $token->{column}); |
| 402 |
|
| 403 |
my $has_attr; |
| 404 |
for my $attr_name (sort {$a cmp $b} keys %{$token->{attributes}}) { |
| 405 |
my $ns; |
| 406 |
my ($p, $l) = split /:/, $attr_name, 2; |
| 407 |
|
| 408 |
if ($attr_name eq 'xmlns:xmlns') { |
| 409 |
($p, $l) = (undef, $attr_name); |
| 410 |
} elsif (defined $l) { # prefixed |
| 411 |
if (defined $nsmap->{$p}) { |
| 412 |
$ns = $nsmap->{$p}; |
| 413 |
} else { |
| 414 |
## NOTE: Error should be detected at the DOM-layer. |
| 415 |
($p, $l) = (undef, $attr_name); |
| 416 |
} |
| 417 |
} else { |
| 418 |
if ($p eq 'xmlns') { |
| 419 |
$ns = $nsmap->{xmlns}; |
| 420 |
} |
| 421 |
($p, $l) = (undef, $p); |
| 422 |
} |
| 423 |
|
| 424 |
if ($has_attr->{defined $ns ? $ns : ''}->{$l}) { |
| 425 |
## NOTE: Attributes are sorted as Unicode characters (not |
| 426 |
## code units) of their names, for stable output. |
| 427 |
|
| 428 |
## TODO: Should be sorted by source order? |
| 429 |
!!!parse-error (type => 'duplicate ns attr', |
| 430 |
token => $token, |
| 431 |
value => $attr_name); |
| 432 |
next; |
| 433 |
} else { |
| 434 |
$has_attr->{defined $ns ? $ns : ''}->{$l} = 1; |
| 435 |
} |
| 436 |
|
| 437 |
my $attr_t = $token->{attributes}->{$attr_name}; |
| 438 |
my $attr = $self->{document}->create_attribute_ns ($ns, [$p, $l]); |
| 439 |
$attr->value ($attr_t->{value}); |
| 440 |
$attr->set_user_data (manakai_source_line => $attr_t->{line}); |
| 441 |
$attr->set_user_data (manakai_source_column => $attr_t->{column}); |
| 442 |
$el->set_attribute_node_ns ($attr); |
| 443 |
} |
| 444 |
|
| 445 |
$self->{document}->append_child ($el); |
| 446 |
|
| 447 |
if ($self->{self_closing}) { |
| 448 |
!!!ack ('ack'); |
| 449 |
$self->{insertion_mode} = AFTER_ROOT_ELEMENT_IM; |
| 450 |
} else { |
| 451 |
push @{$self->{open_elements}}, [$el, $token->{tag_name}, $nsmap]; |
| 452 |
$self->{insertion_mode} = IN_ELEMENT_IM; |
| 453 |
} |
| 454 |
|
| 455 |
#delete $self->{tainted}; |
| 456 |
|
| 457 |
!!!next-token; |
| 458 |
return; |
| 459 |
} elsif ($token->{type} == COMMENT_TOKEN) { |
| 460 |
my $comment = $self->{document}->create_comment ($token->{data}); |
| 461 |
$self->{document}->append_child ($comment); |
| 462 |
|
| 463 |
## Stay in the mode. |
| 464 |
!!!next-token; |
| 465 |
next B; |
| 466 |
} elsif ($token->{type} == PI_TOKEN) { |
| 467 |
my $pi = $self->{document}->create_processing_instruction |
| 468 |
($token->{target}, $token->{data}); |
| 469 |
$self->{document}->append_child ($pi); |
| 470 |
|
| 471 |
## Stay in the mode. |
| 472 |
!!!next-token; |
| 473 |
next B; |
| 474 |
} elsif ($token->{type} == CHARACTER_TOKEN) { |
| 475 |
if (not $self->{tainted} and |
| 476 |
$token->{data} =~ s/^([\x09\x0A\x0C\x20]+)//) { |
| 477 |
# |
| 478 |
} |
| 479 |
|
| 480 |
if (length $token->{data}) { |
| 481 |
## XML5: Ignore the token. |
| 482 |
|
| 483 |
unless ($self->{tainted}) { |
| 484 |
!!!parse-error (type => 'text outside of root element', |
| 485 |
token => $token); |
| 486 |
$self->{tainted} = 1; |
| 487 |
} |
| 488 |
|
| 489 |
$self->{document}->manakai_append_text ($token->{data}); |
| 490 |
} |
| 491 |
|
| 492 |
## Stay in the mode. |
| 493 |
!!!next-token; |
| 494 |
next B; |
| 495 |
} elsif ($token->{type} == END_OF_FILE_TOKEN) { |
| 496 |
!!!parse-error (type => 'no root element', |
| 497 |
token => $token); |
| 498 |
|
| 499 |
$self->{insertion_mode} = AFTER_ROOT_ELEMENT_IM; |
| 500 |
## Reprocess. |
| 501 |
return; |
| 502 |
} elsif ($token->{type} == END_TAG_TOKEN) { |
| 503 |
!!!parse-error (type => 'unmatched end tag', |
| 504 |
text => $token->{tag_name}, |
| 505 |
token => $token); |
| 506 |
## Ignore the token. |
| 507 |
|
| 508 |
## Stay in the mode. |
| 509 |
!!!next-token; |
| 510 |
next B; |
| 511 |
} elsif ($token->{type} == DOCTYPE_TOKEN) { |
| 512 |
!!!parse-error (type => 'in html:#doctype', |
| 513 |
token => $token); |
| 514 |
## Ignore the token. |
| 515 |
|
| 516 |
## Stay in the mode. |
| 517 |
!!!next-token; |
| 518 |
next B; |
| 519 |
} elsif ($token->{type} == ABORT_TOKEN) { |
| 520 |
return; |
| 521 |
} else { |
| 522 |
die "$0: XML parser initial: Unknown token type $token->{type}"; |
| 523 |
} |
| 524 |
} # B |
| 525 |
} # _tree_before_root_element |
| 526 |
|
| 527 |
sub _tree_in_element ($) { |
| 528 |
my $self = shift; |
| 529 |
|
| 530 |
B: while (1) { |
| 531 |
if ($token->{type} == CHARACTER_TOKEN) { |
| 532 |
$self->{open_elements}->[-1]->[0]->manakai_append_text ($token->{data}); |
| 533 |
|
| 534 |
## Stay in the mode. |
| 535 |
!!!next-token; |
| 536 |
next B; |
| 537 |
} elsif ($token->{type} == START_TAG_TOKEN) { |
| 538 |
my ($prefix, $ln) = split /:/, $token->{tag_name}, 2; |
| 539 |
($prefix, $ln) = (undef, $prefix) unless defined $ln; |
| 540 |
my $ns; ## TODO: |
| 541 |
my $el = $self->{document}->create_element_ns ($ns, [$prefix, $ln]); |
| 542 |
$el->set_user_data (manakai_source_line => $token->{line}); |
| 543 |
$el->set_user_data (manakai_source_column => $token->{column}); |
| 544 |
|
| 545 |
for my $attr_name (keys %{$token->{attributes}}) { |
| 546 |
my $ns; ## TODO |
| 547 |
my ($p, $l) = split /:/, $attr_name, 2; |
| 548 |
($p, $l) = (undef, $p) unless defined $l; |
| 549 |
my $attr_t = $token->{attributes}->{$attr_name}; |
| 550 |
my $attr = $self->{document}->create_attribute_ns ($ns, [$p, $l]); |
| 551 |
$attr->value ($attr_t->{value}); |
| 552 |
$attr->set_user_data (manakai_source_line => $attr_t->{line}); |
| 553 |
$attr->set_user_data (manakai_source_column => $attr_t->{column}); |
| 554 |
$el->set_attribute_node_ns ($attr); |
| 555 |
} |
| 556 |
|
| 557 |
$self->{open_elements}->[-1]->[0]->append_child ($el); |
| 558 |
|
| 559 |
if ($self->{self_closing}) { |
| 560 |
!!!ack ('ack'); |
| 561 |
} else { |
| 562 |
push @{$self->{open_elements}}, [$el, $token->{tag_name}]; |
| 563 |
} |
| 564 |
|
| 565 |
## Stay in the mode. |
| 566 |
!!!next-token; |
| 567 |
next B; |
| 568 |
} elsif ($token->{type} == END_TAG_TOKEN) { |
| 569 |
if ($token->{tag_name} eq '') { |
| 570 |
## Short end tag token. |
| 571 |
pop @{$self->{open_elements}}; |
| 572 |
} elsif ($self->{open_elements}->[-1]->[1] eq $token->{tag_name}) { |
| 573 |
pop @{$self->{open_elements}}; |
| 574 |
} else { |
| 575 |
!!!parse-error (type => 'unmatched end tag', |
| 576 |
text => $token->{tag_name}, |
| 577 |
token => $token); |
| 578 |
|
| 579 |
## Has an element in scope |
| 580 |
INSCOPE: for my $i (reverse 0..$#{$self->{open_elements}}) { |
| 581 |
if ($self->{open_elements}->[$i]->[1] eq $token->{tag_name}) { |
| 582 |
splice @{$self->{open_elements}}, $i; |
| 583 |
last INSCOPE; |
| 584 |
} |
| 585 |
} # INSCOPE |
| 586 |
} |
| 587 |
|
| 588 |
unless (@{$self->{open_elements}}) { |
| 589 |
$self->{insertion_mode} = AFTER_ROOT_ELEMENT_IM; |
| 590 |
!!!next-token; |
| 591 |
return; |
| 592 |
} else { |
| 593 |
## Stay in the state. |
| 594 |
!!!next-token; |
| 595 |
redo B; |
| 596 |
} |
| 597 |
} elsif ($token->{type} == COMMENT_TOKEN) { |
| 598 |
my $comment = $self->{document}->create_comment ($token->{data}); |
| 599 |
$self->{open_elements}->[-1]->[0]->append_child ($comment); |
| 600 |
|
| 601 |
## Stay in the mode. |
| 602 |
!!!next-token; |
| 603 |
next B; |
| 604 |
} elsif ($token->{type} == PI_TOKEN) { |
| 605 |
my $pi = $self->{document}->create_processing_instruction |
| 606 |
($token->{target}, $token->{data}); |
| 607 |
$self->{open_elements}->[-1]->[0]->append_child ($pi); |
| 608 |
|
| 609 |
## Stay in the mode. |
| 610 |
!!!next-token; |
| 611 |
next B; |
| 612 |
} elsif ($token->{type} == END_OF_FILE_TOKEN) { |
| 613 |
!!!parse-error (type => 'in body:#eof', |
| 614 |
token => $token); |
| 615 |
|
| 616 |
$self->{insertion_mode} = AFTER_ROOT_ELEMENT_IM; |
| 617 |
!!!next-token; |
| 618 |
return; |
| 619 |
} elsif ($token->{type} == DOCTYPE_TOKEN) { |
| 620 |
!!!parse-error (type => 'in html:#doctype', |
| 621 |
token => $token); |
| 622 |
## Ignore the token. |
| 623 |
|
| 624 |
## Stay in the mode. |
| 625 |
!!!next-token; |
| 626 |
next B; |
| 627 |
} elsif ($token->{type} == ABORT_TOKEN) { |
| 628 |
return; |
| 629 |
} else { |
| 630 |
die "$0: XML parser initial: Unknown token type $token->{type}"; |
| 631 |
} |
| 632 |
} # B |
| 633 |
} # _tree_in_element |
| 634 |
|
| 635 |
sub _tree_after_root_element ($) { |
| 636 |
my $self = shift; |
| 637 |
|
| 638 |
B: while (1) { |
| 639 |
if ($token->{type} == START_TAG_TOKEN) { |
| 640 |
!!!parse-error (type => 'second root element', |
| 641 |
token => $token); |
| 642 |
|
| 643 |
## XML5: Ignore the token. |
| 644 |
|
| 645 |
$self->{insertion_mode} = BEFORE_ROOT_ELEMENT_IM; |
| 646 |
## Reprocess. |
| 647 |
return; |
| 648 |
} elsif ($token->{type} == COMMENT_TOKEN) { |
| 649 |
my $comment = $self->{document}->create_comment ($token->{data}); |
| 650 |
$self->{document}->append_child ($comment); |
| 651 |
|
| 652 |
## Stay in the mode. |
| 653 |
!!!next-token; |
| 654 |
next B; |
| 655 |
} elsif ($token->{type} == PI_TOKEN) { |
| 656 |
my $pi = $self->{document}->create_processing_instruction |
| 657 |
($token->{target}, $token->{data}); |
| 658 |
$self->{document}->append_child ($pi); |
| 659 |
|
| 660 |
## Stay in the mode. |
| 661 |
!!!next-token; |
| 662 |
next B; |
| 663 |
} elsif ($token->{type} == CHARACTER_TOKEN) { |
| 664 |
if (not $self->{tainted} and |
| 665 |
$token->{data} =~ s/^([\x09\x0A\x0C\x20]+)//) { |
| 666 |
# |
| 667 |
} |
| 668 |
|
| 669 |
if (length $token->{data}) { |
| 670 |
## XML5: Ignore the token. |
| 671 |
|
| 672 |
unless ($self->{tainted}) { |
| 673 |
!!!parse-error (type => 'text outside of root element', |
| 674 |
token => $token); |
| 675 |
$self->{tainted} = 1; |
| 676 |
} |
| 677 |
|
| 678 |
$self->{document}->manakai_append_text ($token->{data}); |
| 679 |
} |
| 680 |
|
| 681 |
## Stay in the mode. |
| 682 |
!!!next-token; |
| 683 |
next B; |
| 684 |
} elsif ($token->{type} == END_OF_FILE_TOKEN) { |
| 685 |
## Stop parsing. |
| 686 |
|
| 687 |
## TODO: implement "stop parsing". |
| 688 |
|
| 689 |
$token = {type => ABORT_TOKEN}; |
| 690 |
return; |
| 691 |
} elsif ($token->{type} == END_TAG_TOKEN) { |
| 692 |
!!!parse-error (type => 'unmatched end tag', |
| 693 |
text => $token->{tag_name}, |
| 694 |
token => $token); |
| 695 |
## Ignore the token. |
| 696 |
|
| 697 |
## Stay in the mode. |
| 698 |
!!!next-token; |
| 699 |
next B; |
| 700 |
} elsif ($token->{type} == DOCTYPE_TOKEN) { |
| 701 |
!!!parse-error (type => 'in html:#doctype', |
| 702 |
token => $token); |
| 703 |
## Ignore the token. |
| 704 |
|
| 705 |
## Stay in the mode. |
| 706 |
!!!next-token; |
| 707 |
next B; |
| 708 |
} elsif ($token->{type} == ABORT_TOKEN) { |
| 709 |
return; |
| 710 |
} else { |
| 711 |
die "$0: XML parser initial: Unknown token type $token->{type}"; |
| 712 |
} |
| 713 |
} # B |
| 714 |
} # _tree_after_root_element |
| 715 |
|
| 716 |
} |
| 717 |
|
| 718 |
1; |
Parent Directory
| 
Revision Log