| 1 |
|
| 2 |
=head1 NAME |
| 3 |
|
| 4 |
Message::Markup::XML::EntityManager --- manakai: XML Entity manager |
| 5 |
|
| 6 |
=head1 DESCRIPTION |
| 7 |
|
| 8 |
The entity manager is part of XML system to retrive internal/external entity in |
| 9 |
this implementation. In addition to it, this module provides some procedures |
| 10 |
to validate public identifier or system identifier and to get one of/list of |
| 11 |
markup declarations for element, attribute list or notation from the DTD. |
| 12 |
|
| 13 |
This module have customizable interface to get external resource. |
| 14 |
Defining the additional or replacing function for the "external identifier(s) |
| 15 |
to entity value convertion", more flexible or secure entity resolving can be |
| 16 |
implemented. (For detail, see examples below.) |
| 17 |
|
| 18 |
This module is part of XML. |
| 19 |
|
| 20 |
=cut |
| 21 |
|
| 22 |
package Message::Markup::XML::EntityManager; |
| 23 |
use strict; |
| 24 |
our $VERSION = do{my @r=(q$Revision: 1.15 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; |
| 25 |
our %NS; |
| 26 |
*NS = \%Message::Markup::XML::NS; |
| 27 |
|
| 28 |
# $class->new ($yourself) |
| 29 |
sub new ($$) { |
| 30 |
my $self = bless {node => $_[1]}, $_[0]; |
| 31 |
return $self unless ref $self->{node}; |
| 32 |
for (@{$self->{node}->{node}}) { |
| 33 |
if ($_->{type} eq '#declaration' && $_->{namespace_uri} eq $NS{SGML}.'doctype') { |
| 34 |
$self->{doctype} = $_; |
| 35 |
last; |
| 36 |
} |
| 37 |
} |
| 38 |
$self; |
| 39 |
} |
| 40 |
|
| 41 |
sub set_root_node ($$) { $_[0]->{node} = $_[1] } |
| 42 |
sub set_doctype_node ($$) { $_[0]->{doctype} = $_[1] } |
| 43 |
|
| 44 |
sub is_declared_entity ($$;%) { |
| 45 |
my ($self, $name, %o) = @_; |
| 46 |
if (ref $name) { |
| 47 |
$o{namespace_uri} ||= $name->{namespace_uri}; |
| 48 |
$name = $name->{local_name}; |
| 49 |
} else { |
| 50 |
$o{namespace_uri} ||= $NS{SGML}.'entity'; |
| 51 |
} |
| 52 |
$self->{cache}->{is_declared_entity}->{$o{namespace_uri}} = {} if $o{clear_cache}; |
| 53 |
if (ref $o{set_value}) { |
| 54 |
$self->{cache}->{entity_declaration}->{$o{namespace_uri}}->{$name} = $o{set_value}; |
| 55 |
$self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name} = 1; |
| 56 |
} elsif (defined $o{set_value}) { |
| 57 |
$self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name} = $o{set_value}; |
| 58 |
} |
| 59 |
unless (defined $self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name}) { |
| 60 |
if ($o{seek}) { |
| 61 |
$self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name} |
| 62 |
= $self->get_entity ($name, %o) ? 1 : 0; |
| 63 |
} |
| 64 |
} |
| 65 |
$self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name}; |
| 66 |
} |
| 67 |
|
| 68 |
sub get_entity ($$;%) { |
| 69 |
my ($self, $name, %o) = @_; |
| 70 |
if (ref $name) { |
| 71 |
$o{namespace_uri} ||= $name->{namespace_uri}; |
| 72 |
$name = $name->{local_name}; |
| 73 |
} else { |
| 74 |
$o{namespace_uri} ||= $NS{SGML}.'entity'; |
| 75 |
} |
| 76 |
if (!$o{dont_use_predefined_entities} |
| 77 |
&& ($o{namespace_uri} eq $NS{SGML}.'entity')) { ## General entity |
| 78 |
my $predec = { |
| 79 |
amp => '&', |
| 80 |
apos => ''', |
| 81 |
gt => '>', |
| 82 |
lt => '<', |
| 83 |
quot => '"', |
| 84 |
}->{$name}; |
| 85 |
if ($predec) { |
| 86 |
for (Message::Markup::XML->new (type => '#declaration', |
| 87 |
namespace_uri => $NS{SGML}.'entity')) { |
| 88 |
$_->set_attribute ('value')->append_new_node (type => '#xml', value => $predec); |
| 89 |
return $_; |
| 90 |
} |
| 91 |
} |
| 92 |
} |
| 93 |
$self->{cache}->{entity_declaration}->{$o{namespace_uri}} = {} if $o{clear_cache}; |
| 94 |
my $e = $self->{cache}->{entity_declaration}->{$o{namespace_uri}}->{$name}; |
| 95 |
return $e if ref $e; |
| 96 |
return undef if !$o{seek} || !(ref $self->{doctype}); |
| 97 |
$e = $self->_get_entity ($name, $self->{doctype}->{node}, \%o); |
| 98 |
if (ref $e) { |
| 99 |
$self->{cache}->{entity_declaration}->{$o{namespace_uri}}->{$name} = $e; |
| 100 |
return $e; |
| 101 |
} |
| 102 |
my $xsub = $self->{doctype}->get_attribute ('external-subset'); |
| 103 |
if (ref $xsub) { |
| 104 |
$e = $self->_get_entity ($name, $xsub->{node}, \%o); |
| 105 |
if (ref $e) { |
| 106 |
$self->{cache}->{entity_declaration}->{$o{namespace_uri}}->{$name} = $e; |
| 107 |
return $e; |
| 108 |
} |
| 109 |
} |
| 110 |
return undef; |
| 111 |
} |
| 112 |
sub _get_entity ($$$$) { |
| 113 |
my ($self, $name, $nodes, $o) = @_; |
| 114 |
return undef unless ref $nodes; |
| 115 |
for (@$nodes) { |
| 116 |
next if $_->{flag}->{smxp__non_processed_declaration}; |
| 117 |
if ($_->{type} eq '#declaration' && $_->{namespace_uri} eq $o->{namespace_uri} |
| 118 |
&& $_->{local_name} eq $name) { |
| 119 |
return $_; |
| 120 |
} elsif ($_->{type} eq '#reference') { |
| 121 |
my $e = $self->_get_entity ($name, $_->{node}, $o); |
| 122 |
return $e if ref $e; |
| 123 |
} elsif ($_->{type} eq '#section' |
| 124 |
&& ($_->get_attribute ('status', make_new_node => 1)->inner_text||'INCLUDE') |
| 125 |
eq 'INCLUDE') { |
| 126 |
my $e = $self->_get_entity ($name, $_->{node}, $o); |
| 127 |
return $e if ref $e; |
| 128 |
} |
| 129 |
} |
| 130 |
return undef; |
| 131 |
} |
| 132 |
|
| 133 |
# DOM's get*By* |
| 134 |
sub get_entities ($$%) { |
| 135 |
my ($self, $l, %o) = @_; |
| 136 |
$o{namespace_uri} = $NS{SGML}.'entity' unless defined $o{namespace_uri}; |
| 137 |
$o{type} ||= '#declaration'; |
| 138 |
$o{parent_node} ||= $self->{doctype}; |
| 139 |
$self->_get_entities ($l, $o{parent_node}->{node}, \%o); |
| 140 |
} |
| 141 |
sub _get_entities ($$$$) { |
| 142 |
my ($self, $l, $nodes, $o) = @_; |
| 143 |
return undef unless ref $nodes; |
| 144 |
for (@$nodes) { |
| 145 |
next if $_->{flag}->{smxp__non_processed_declaration}; |
| 146 |
if (($_->{type} eq $o->{type}) |
| 147 |
and ( |
| 148 |
( defined $o->{namespace_uri} |
| 149 |
and defined $_->{namespace_uri} |
| 150 |
and $_->{namespace_uri} eq $o->{namespace_uri}) |
| 151 |
or (not defined $o->{namespace_uri} and not defined $_->{namespace_uri}))) { |
| 152 |
push @$l, $_; |
| 153 |
} elsif ($_->{type} eq '#reference' || $_->{type} eq '#element') { |
| 154 |
$self->_get_entities ($l, $_->{node}, $o); |
| 155 |
} elsif (($_->{type} eq '#section' |
| 156 |
&& ($_->get_attribute ('status', make_new_node => 1)->inner_text||'INCLUDE') |
| 157 |
eq 'INCLUDE') |
| 158 |
|| ($_->{type} eq '#declaration' && $_->{namespace_uri} eq $NS{SGML}.'doctype')) { |
| 159 |
$self->_get_entities ($l, $_->{node}, $o); |
| 160 |
} elsif ($_->{type} eq '#attribute' && $_->{local_name} eq 'external-subset') { |
| 161 |
$self->_get_entities ($l, $_->{node}, $o); |
| 162 |
} |
| 163 |
} |
| 164 |
} |
| 165 |
|
| 166 |
sub get_attr_definitions ($%) { |
| 167 |
my ($self, %o) = @_; |
| 168 |
return $self->{cache}->{attr_defs}->{$o{qname}} |
| 169 |
if $self->{cache}->{attr_defs}->{$o{qname}}; |
| 170 |
my %r; |
| 171 |
$o{namespace_uri} = $NS{SGML}.'attlist'; |
| 172 |
$o{type} = '#declaration'; |
| 173 |
$o{parent_node} ||= $self->{doctype}; |
| 174 |
my $l = []; |
| 175 |
$self->_get_entities ($l, $o{parent_node}->{node}, \%o); |
| 176 |
$r{declaration} = []; |
| 177 |
for (@$l) { |
| 178 |
if ($_->get_attribute_value ('qname') eq $o{qname}) { |
| 179 |
push @{$r{declaration}}, $_; |
| 180 |
} |
| 181 |
} |
| 182 |
for my $decl (@{$r{declaration}}) { |
| 183 |
for (@{$decl->{node}}) { |
| 184 |
if ($_->{type} eq '#element' |
| 185 |
and $_->{namespace_uri} eq $NS{XML}.'attlist' |
| 186 |
and $_->{local_name} eq 'AttDef') { |
| 187 |
my $aname = $_->get_attribute_value ('qname'); |
| 188 |
if ($r{attr}->{$aname}) { |
| 189 |
# |
| 190 |
} else { |
| 191 |
$r{attr}->{$aname} = $_; |
| 192 |
$r{attr_may_not_be_read}->{$aname} = $decl->{flag}->{smxp__declaration_may_not_be_read}; |
| 193 |
for (@{$_->{node}}) { |
| 194 |
if ($_->{type} eq '#element' && $_->{namespace_uri} eq $NS{XML}.'attlist' |
| 195 |
&& $_->{local_name} eq 'enum') { |
| 196 |
$r{enum}->{$aname}->{$_->inner_text} = 1; |
| 197 |
} |
| 198 |
} |
| 199 |
} |
| 200 |
} |
| 201 |
} |
| 202 |
} |
| 203 |
$self->{cache}->{attr_defs}->{$o{qname}} = \%r; |
| 204 |
\%r; |
| 205 |
} |
| 206 |
|
| 207 |
## TODO: uri based recursion |
| 208 |
sub get_external_entity ($$$$;%) { |
| 209 |
my ($self, $parser, $decl, $o, %opt) = @_; |
| 210 |
my $declns = ref $decl ? $decl->namespace_uri : '#document'; |
| 211 |
my $name = ref $decl ? |
| 212 |
($declns eq $NS{SGML}.'doctype' ? |
| 213 |
($decl->get_attribute_value ('qname') |
| 214 |
|| '#IMPLIED') : |
| 215 |
$decl->local_name) : |
| 216 |
$opt{uri}; |
| 217 |
my $p = $self->{external_entity_cache}->{$declns}->{$name}; |
| 218 |
if ($name && !$p) { |
| 219 |
$p = {name => $name}; $self->{external_entity_cache}->{$declns}->{$name} = $p; |
| 220 |
if (ref $decl) { |
| 221 |
for (qw/PUBLIC SYSTEM NDATA/) { |
| 222 |
$p->{$_} = ref $decl ? $decl->get_attribute ($_) : $opt{$_}; |
| 223 |
$p->{$_} = ref $p->{$_} ? $p->{$_}->inner_text : undef; |
| 224 |
} |
| 225 |
$p->{uri} = $decl->resolve_relative_uri ($p->{SYSTEM}, use_references_base_uri => 1); |
| 226 |
} else { |
| 227 |
$p->{uri} = $opt{uri}; |
| 228 |
} |
| 229 |
} |
| 230 |
for ($o) { |
| 231 |
$_->{entity_type} ||= 'external_parsed_entity'; |
| 232 |
$_->{uri} = $p->{uri}; $_->{line} = 0; $_->{pos} = 0; |
| 233 |
} |
| 234 |
if ($name && !$p->{__flag}) { |
| 235 |
my $resolver = $parser->option ('uri_resolver'); |
| 236 |
if (ref $resolver) { |
| 237 |
$resolver = &$resolver ($self, $parser, $decl, $p, $o, %opt); ## If returned false, |
| 238 |
$self->default_uri_resolver ($parser, $decl, $p, $o, %opt) if $resolver; ## don't call this. |
| 239 |
} else { |
| 240 |
$self->default_uri_resolver ($parser, $decl, $p, $o, %opt); |
| 241 |
} |
| 242 |
## Line-break normalization |
| 243 |
if (defined $p->{text}) { |
| 244 |
$p->{text} =~ s/\x0D\x0A/\x0A/gs; |
| 245 |
$p->{text} =~ tr/\x0D/\x0A/; |
| 246 |
} |
| 247 |
$p->{__flag} = 1; |
| 248 |
} |
| 249 |
$p; |
| 250 |
} |
| 251 |
|
| 252 |
=pod example |
| 253 |
|
| 254 |
my $parser = Message::Markup::XML::Parser->new (option => {uri_resolver => sub { |
| 255 |
my ($self, $decl, $p) = @_; |
| 256 |
@@ $p->{SYSTEM} =~ s///g @@ |
| 257 |
return 1; |
| 258 |
}}); |
| 259 |
|
| 260 |
=cut |
| 261 |
|
| 262 |
sub default_uri_resolver ($$$$$;%) { |
| 263 |
my ($self, $parser, $decl, $p, $o, %opt) = @_; |
| 264 |
require LWP::UserAgent; |
| 265 |
my $ua = LWP::UserAgent->new; |
| 266 |
$ua->agent ('"Message::Markup::XML::EntityManager"/'.$VERSION); |
| 267 |
## TODO: use Message::Field::UA |
| 268 |
my $req = HTTP::Request->new (GET => $p->{uri}); |
| 269 |
my $res = $ua->request ($req); |
| 270 |
if ($res->is_success || $opt{accept_error_page}) { |
| 271 |
## TODO: use Message::Entity for more intelligent/strict parsing:-) |
| 272 |
$p->{base_uri} = $res->base; ## See Content-Base: and Content-Location: (and HTML:BASE) |
| 273 |
$p->{uri} = $res->request->uri; $o->{uri} = $p->{uri}; ## Redirect support |
| 274 |
## Check media type |
| 275 |
my $CT = $res->header ('Content-Type'); |
| 276 |
my $ct = lc $res->content_type; |
| 277 |
$self->_check_media_type ($o, $ct); |
| 278 |
$p->{text} = $res->content; |
| 279 |
#$p->{text} .= "<!--$p->{uri}-->"; ## DEBUG: base URI |
| 280 |
## Charset/encoding convertion |
| 281 |
my $encoding; |
| 282 |
if ($CT =~ /charset\s*=\s*"?([^",;\s]+)"?/i) { ## BUG: This check is not strict |
| 283 |
$encoding = lc $1; |
| 284 |
} else { ## No charset parameter |
| 285 |
if ($p->{uri}->scheme eq 'file') { |
| 286 |
## Protocol does not provide charset information |
| 287 |
} elsif (lc (substr ($ct, 0, 5)) eq 'text/') { ## BUG: This check is not strict |
| 288 |
$encoding = 'us-ascii'; ## See RFC 3023 |
| 289 |
$self->_raise_error ($o, type => 'WARN_NO_CHARSET_PARAM_FOR_TEXT', t => $ct); |
| 290 |
} else { |
| 291 |
## BUG: Warn even if the media type does not have the charset parameter |
| 292 |
$self->_raise_error ($o, type => 'WARN_NO_CHARSET_PARAM', t => $ct); |
| 293 |
} |
| 294 |
} |
| 295 |
unless ($encoding) { |
| 296 |
$encoding = $self->_guess_entity_encoding ($p->{text}, $o) || 'utf-8'; |
| 297 |
} |
| 298 |
#print "<$p->{uri}>: encode is {$encoding}\n"; ## DEBUG: Detected encoding |
| 299 |
if ($encoding) { |
| 300 |
require Encode; |
| 301 |
eval q{$p->{text} = Encode::decode ($encoding, $p->{text}); 1} |
| 302 |
or $self->_raise_error ($o, type => 'FATAL_ERR_DECODE_IMPL_ERR', t => $@); |
| 303 |
} else { |
| 304 |
#$self->_raise_error ($o, type => 'WARN_NO_EXPLICIT_ENCODING_INFO'); |
| 305 |
} |
| 306 |
## parse and remove xml declaration |
| 307 |
unless ($opt{dont_parse_text_declaration}) { |
| 308 |
$p->{text_declaration} = (ref ($decl)||$decl)->new (type => '#pi', local_name => 'xml'); |
| 309 |
$parser->_parse_xml_or_text_declaration ($p->{text_declaration}, \$p->{text}, $o); |
| 310 |
} |
| 311 |
} else { |
| 312 |
$p->{error}->{no_data} = 1; |
| 313 |
$p->{error}->{reason_text} = $res->status_line; |
| 314 |
$p->{uri} = $res->request->uri; $o->{uri} = $p->{uri}; ## Redirect support |
| 315 |
} |
| 316 |
} |
| 317 |
|
| 318 |
sub is_standalone_document ($) { |
| 319 |
my $self = shift; |
| 320 |
return $self->{node}->{flag}->{smxe__standalone} |
| 321 |
if defined $self->{node}->{flag}->{smxe__standalone}; |
| 322 |
for (@{$self->{node}->{node}}) { |
| 323 |
if ($_->{type} eq '#pi' && $_->{local_name} eq 'xml') { |
| 324 |
my $a = $_->get_attribute ('standalone'); |
| 325 |
if (ref $a) { |
| 326 |
$self->{node}->{flag}->{smxe__standalone} = $a->inner_text eq 'yes' ? 1 : 0; |
| 327 |
return $self->{node}->{flag}->{smxe__standalone}; |
| 328 |
} |
| 329 |
} elsif ($_->{type} eq '#attribute') { |
| 330 |
## Check next node too |
| 331 |
} else { |
| 332 |
last; ## No xml declaration |
| 333 |
} |
| 334 |
} |
| 335 |
$self->{node}->{flag}->{smxe__standalone} = 0; |
| 336 |
return $self->{node}->{flag}->{smxe__standalone}; |
| 337 |
} |
| 338 |
sub is_standalone_document_1 ($) { |
| 339 |
my $self = shift; |
| 340 |
return $self->{node}->{flag}->{smxe__standalone_1} |
| 341 |
if defined $self->{node}->{flag}->{smxe__standalone_1}; |
| 342 |
for (@{$self->{node}->{node}}) { |
| 343 |
if ($_->{type} eq '#pi' && $_->{local_name} eq 'xml') { |
| 344 |
my $a = $_->get_attribute ('standalone'); |
| 345 |
if (ref $a) { |
| 346 |
$self->{node}->{flag}->{smxe__standalone_1} = $a->inner_text eq 'yes' ? 1 : 0; |
| 347 |
return $self->{node}->{flag}->{smxe__standalone_1}; |
| 348 |
} |
| 349 |
} |
| 350 |
last; |
| 351 |
} |
| 352 |
if ($self->{doctype}) { |
| 353 |
if ($self->{doctype}->external_id) { |
| 354 |
$self->{node}->{flag}->{smxe__standalone_1} = 0; |
| 355 |
return $self->{node}->{flag}->{smxe__standalone_1}; |
| 356 |
} |
| 357 |
for (@{$self->{doctype}->{node}}) { |
| 358 |
if ($_->{type} eq '#declaration' && $_->{namespace_uri} eq $NS{SGML}.'entity:parameter') { |
| 359 |
$self->{node}->{flag}->{smxe__standalone_1} = 0; |
| 360 |
return $self->{node}->{flag}->{smxe__standalone_1}; |
| 361 |
} |
| 362 |
} |
| 363 |
} |
| 364 |
$self->{node}->{flag}->{smxe__standalone_1} = 1; |
| 365 |
return $self->{node}->{flag}->{smxe__standalone_1}; |
| 366 |
} |
| 367 |
|
| 368 |
sub check_public_id ($$$) { |
| 369 |
my ($self, $o, $pubid) = @_; |
| 370 |
if (length ($pubid) == 0) { |
| 371 |
$self->_raise_error ($o, type => 'WARN_PID_EMPTY'); |
| 372 |
} |
| 373 |
if ($pubid =~ m"([^\x0A\x0D\x20A-Za-z0-9'()+,./:=?;!*#\@\$_%-])"s) { |
| 374 |
$self->_raise_error ($o, type => 'SYNTAX_INVALID_PUBID', t => $1); |
| 375 |
} |
| 376 |
$pubid =~ s/[\x0A\x0D\x20]+/\x20/gs; |
| 377 |
if (length ($pubid) > 240) { ## this check is not strict |
| 378 |
$self->_raise_error ($o, type => 'WARN_PID_IS_TOO_LONG', t => $pubid); |
| 379 |
} |
| 380 |
$pubid =~ s/^\x20//; $pubid =~ s/\x20$//; |
| 381 |
if ($pubid =~ /^[Uu][Rr][Nn]:/) { |
| 382 |
if ($pubid !~ m"^[Uu][Rr][Nn]:[0-9A-Za-z][0-9A-Za-z-]{0,31}:(?:[0-9A-Za-z()+,.:=\@;\$_!*'/?-]|%[0-9A-Fa-f]{2})+$") { |
| 383 |
$self->_raise_error ($o, type => 'WARN_PID_IS_INVALID_URN', t => $pubid); |
| 384 |
} elsif ($pubid =~ m![/?]!) { |
| 385 |
$self->_raise_error ($o, type => 'WARN_PID_IS_URN_WITH_RESERVED_CHAR', t => $pubid); |
| 386 |
} |
| 387 |
} elsif ($pubid !~ m<^(?:[+-]//|ISO)(?:(?!//).)+//[A-Z]+ (?:(?!//).)+//(?:(?!//).)+(?://(?:(?!//).)+)?$>) { |
| 388 |
$self->_raise_error ($o, type => 'WARN_PID_IS_NOT_FPI_NOR_URN', t => $pubid); |
| 389 |
} |
| 390 |
$pubid; |
| 391 |
} |
| 392 |
|
| 393 |
sub check_system_id ($$$) { |
| 394 |
my ($self, $o, $sysid) = @_; |
| 395 |
if ($sysid =~ m"([^0-9A-Za-z_.!~*'();/?:\@&=+\$,%\[\]#-])"s) { |
| 396 |
$self->_raise_error ($o, type => 'WARN_INVALID_URI_CHAR_IN_SYSID', t => $1); |
| 397 |
} |
| 398 |
if ($sysid =~ s/(#[^#]*)$//g) { |
| 399 |
$self->_raise_error ($o, type => 'ERR_XML_SYSID_HAS_FRAGMENT', t => $1); |
| 400 |
} |
| 401 |
if (length ($sysid) == 0) { |
| 402 |
$self->_raise_error ($o, type => 'WARN_SYSID_EMPTY'); |
| 403 |
} |
| 404 |
$sysid; |
| 405 |
} |
| 406 |
|
| 407 |
sub check_ns_uri ($$$$) { ## TODO: check predefined NS |
| 408 |
my ($self, $o, $ns_pfx => $ns_name) = @_; |
| 409 |
if ($ns_name =~ m"([^0-9A-Za-z_.!~*'();/?:\@&=+\$,%\[\]#-])"s) { |
| 410 |
$self->_raise_error ($o, type => 'WARN_INVALID_URI_CHAR_IN_NS_NAME', t => $1); |
| 411 |
} |
| 412 |
if ($ns_name !~ /^[0-9A-Za-z.+-]+:/) { |
| 413 |
$self->_raise_error ($o, type => 'WARN_XML_NS_URI_IS_RELATIVE', t => $ns_name); |
| 414 |
} |
| 415 |
} |
| 416 |
|
| 417 |
## Guess encoding of the entity by BOM and '<?' and Encode::Guess --- Used by default resolver |
| 418 |
sub _guess_entity_encoding ($$) { |
| 419 |
my ($self, $entity, $o) = @_; |
| 420 |
my $encoding; |
| 421 |
my $f2 = substr ($entity, 0, 2); |
| 422 |
my $s2 = substr ($entity, 2, 2); |
| 423 |
if ($f2 eq "<?") { |
| 424 |
$encoding = '*ascii'; |
| 425 |
} elsif ($f2 eq "\xEF\xBB" && substr ($s2, 0, 1) eq "\xBF") { |
| 426 |
$encoding = '*utf-8'; |
| 427 |
} elsif ($f2 eq "\xFE\xFF" || $f2 eq "\x00\x3C") { |
| 428 |
if ($s2 eq "\x00\x00") { |
| 429 |
$encoding = '*ucs-4-3412'; |
| 430 |
} else { |
| 431 |
$encoding = '*ucs-2be'; |
| 432 |
} |
| 433 |
} elsif ($f2 eq "\xFF\xFE" || $f2 eq "\x3C\x00") { |
| 434 |
if ($s2 eq "\x00\x00") { |
| 435 |
$encoding = '*ucs-4le'; |
| 436 |
} else { |
| 437 |
$encoding = '*ucs-2le'; |
| 438 |
} |
| 439 |
} elsif ($f2 eq "\x00\x00") { |
| 440 |
if ($s2 eq "\xFE\xFF" || $s2 eq "\x00\x3C") { |
| 441 |
$encoding = '*ucs-4be'; |
| 442 |
} elsif ($s2 eq "\xFF\xFE" || $s2 eq "\x3C\x00") { |
| 443 |
$encoding = '*ucs-4-2143'; |
| 444 |
} |
| 445 |
} elsif ($f2 eq "\x4C\x6F") { |
| 446 |
$encoding = '*ebcdic'; |
| 447 |
} |
| 448 |
|
| 449 |
## TODO: Charset list need more consideration |
| 450 |
my @guess_list; |
| 451 |
if ($encoding eq '*ascii' || $encoding eq '*utf-8') { |
| 452 |
if ($entity =~ /<\?xml.+?encoding=["']([0-9A-Za-z._-]+)["']/) { |
| 453 |
$encoding = lc $1; |
| 454 |
} else { |
| 455 |
if ($encoding eq '*utf-8') { |
| 456 |
$encoding = undef; |
| 457 |
@guess_list = qw/utf-8 cesu-8 unicode-1-1-utf-8/; |
| 458 |
} else { |
| 459 |
$encoding = undef; |
| 460 |
@guess_list = qw/us-ascii iso-8859-1 iso-8859-2 iso-8859-8 iso-8859-15 |
| 461 |
iso-2022-jp euc-jp shift_jis euc-kr |
| 462 |
gbk gb18030 big5-eten big5-hkscs windows-1252 koi8-r koi8-u/; |
| 463 |
} |
| 464 |
} |
| 465 |
} elsif ($encoding =~ /ucs/) { |
| 466 |
my $ent = $entity; $ent =~ tr/\x00//d; |
| 467 |
if ($ent =~ /<\?xml.+?encoding=["']([0-9A-Za-z._-]+)["']/) { |
| 468 |
$encoding = lc $1; |
| 469 |
} else { |
| 470 |
if ($encoding eq '*ucs-2be') { |
| 471 |
$encoding = 'utf-16be'; |
| 472 |
} elsif ($encoding eq '*ucs-2le') { |
| 473 |
$encoding = 'utf-16le'; |
| 474 |
} elsif ($encoding =~ /(ucs-4.+)/) { |
| 475 |
$encoding = $1; |
| 476 |
} |
| 477 |
} |
| 478 |
} elsif ($encoding eq '*ebcdic') { |
| 479 |
@guess_list = qw/cp037 cp500 cp875 cp1026 cp1047 posix-bc/; ## All Encode::EBCDIC supporteds |
| 480 |
} |
| 481 |
|
| 482 |
unless ($encoding) { |
| 483 |
$self->_raise_error ($o, type => 'WARN_NO_EXPLICIT_ENCODING_INFO'); |
| 484 |
require Encode::Guess; |
| 485 |
unless (@guess_list) { |
| 486 |
@guess_list = qw/utf-8 utf-16 utf-16be utf-16le |
| 487 |
7bit-jis euc-jp shift_jis gbk gb18030 euc-kr big5-eten big5-hkscs |
| 488 |
iso-8859-1 iso-8859-8 koi8-r koi8-u tis-620 |
| 489 |
windows-1252/; |
| 490 |
} |
| 491 |
my @gl; |
| 492 |
for (@guess_list) { |
| 493 |
push @gl, $_ if Encode::find_encoding ($_); |
| 494 |
} |
| 495 |
my $enc; |
| 496 |
eval q{$enc = Encode::Guess::guess_encoding ($entity, @gl); 1} |
| 497 |
or $self->_raise_error ($o, type => 'WARN_GUESS_ENCODING_IMPL_ERR', t => $@); |
| 498 |
$encoding = $enc->name if ref $enc; |
| 499 |
} |
| 500 |
$encoding; |
| 501 |
} |
| 502 |
|
| 503 |
## Check whether the media type specified is better one for that type of entity |
| 504 |
## and raise error if not --- See RFC 3023 |
| 505 |
## |
| 506 |
## Known error: Warn even when source is local file doesn't have meta type information |
| 507 |
## (but LWP give inappropreate value such as 'text/plain'). This is an error but spec. |
| 508 |
sub _check_media_type ($$$) { |
| 509 |
my ($self, $o, $ct) = @_; |
| 510 |
if ($ct eq 'application/xml' || $ct eq 'text/xml') { |
| 511 |
if ($o->{entity_type} eq 'external_parsed_entity' |
| 512 |
|| $o->{entity_type} eq 'external_general_parsed_entity') { |
| 513 |
$self->_raise_error ($o, type => 'WARN_MT_XML_FOR_EXT_GENERAL_ENTITY', t => $ct); |
| 514 |
} elsif ($o->{entity_type} ne 'document_entity') { |
| 515 |
$self->_raise_error ($o, type => 'ERR_MT_XML_FOR_EXT_ENTITY', t => $ct); |
| 516 |
} |
| 517 |
if ($ct eq 'text/xml') { |
| 518 |
$self->_raise_error ($o, type => 'WARN_MT_TEXT_XML'); |
| 519 |
} |
| 520 |
} elsif ($o->{entity_type} eq 'external_general_parsed_entity') { |
| 521 |
if ($ct eq 'text/xml-external-parsed-entity') { |
| 522 |
$self->_raise_error ($o, type => 'WARN_MT_TEXT_XML_EXTERNAL_PARSED_ENTITY'); |
| 523 |
} elsif ($ct ne 'application/xml-external-parsed-entity') { |
| 524 |
$self->_raise_error ($o, type => 'WARN_MT_EXTERNAL_GENERAL_PARSED_ENTITY', t => $ct); |
| 525 |
} |
| 526 |
} elsif ($o->{entity_type} eq 'dtd_external_subset' |
| 527 |
|| $o->{entity_type} eq 'external_parameter_entity') { |
| 528 |
if ($ct ne 'application/xml-dtd') { |
| 529 |
$self->_raise_error ($o, type => 'WARN_MT_DTD_EXTERNAL_SUBSET', t => $ct); |
| 530 |
} |
| 531 |
} |
| 532 |
} |
| 533 |
|
| 534 |
sub option ($$;$) { |
| 535 |
my ($self, $name, $value) = @_; |
| 536 |
if (defined $value) { |
| 537 |
$self->{option}->{$name} = $value; |
| 538 |
} |
| 539 |
$self->{option}->{$name}; |
| 540 |
} |
| 541 |
|
| 542 |
sub flag ($$;$) { |
| 543 |
my ($self, $name, $value) = @_; |
| 544 |
if (defined $value) { |
| 545 |
$self->{flag}->{$name} = $value; |
| 546 |
} |
| 547 |
$self->{flag}->{$name}; |
| 548 |
} |
| 549 |
|
| 550 |
## $self->_raise_error: Raising error or warn |
| 551 |
require Message::Markup::XML::Error; |
| 552 |
*_raise_error = \&Message::Markup::XML::Error::raise; |
| 553 |
|
| 554 |
=head1 DEVELOPER'S NOTE |
| 555 |
|
| 556 |
This module "knows" how Message::Markup::XML works, i.e. this module accesses |
| 557 |
internal structure of that module directly. |
| 558 |
|
| 559 |
=head1 LICENSE |
| 560 |
|
| 561 |
Copyright 2003 Wakaba <[email protected]> |
| 562 |
|
| 563 |
This program is free software; you can redistribute it and/or |
| 564 |
modify it under the same terms as Perl itself. |
| 565 |
|
| 566 |
=cut |
| 567 |
|
| 568 |
1; # $Date: 2003/10/31 08:41:35 $ |
Parent Directory
| 
Revision Log