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