Markup/XML/EntityManager.pm


=head1 NAME

Message::Markup::XML::EntityManager --- manakai: XML Entity manager

=head1 DESCRIPTION

The entity manager is part of XML system to retrive internal/external entity in
this implementation.  In addition to it, this module provides some procedures
to validate public identifier or system identifier and to get one of/list of
markup declarations for element, attribute list or notation from the DTD.

This module have customizable interface to get external resource.
Defining the additional or replacing function for the "external identifier(s)
to entity value convertion", more flexible or secure entity resolving can be
implemented.  (For detail, see examples below.)

This module is part of XML.

=cut

package Message::Markup::XML::EntityManager;
use strict;
our $VERSION = do{my @r=(q$Revision: 1.12 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
our %NS;
*NS = \%Message::Markup::XML::NS;

# $class->new ($yourself)
sub new ($$) {
  my $self = bless {node => $_[1]}, $_[0];
  return $self unless ref $self->{node};
  for (@{$self->{node}->{node}}) {
    if ($_->{type} eq '#declaration' && $_->{namespace_uri} eq $NS{SGML}.'doctype') {
      $self->{doctype} = $_;
      last;
    }
  }
  $self;
}

sub set_root_node ($$) { $_[0]->{node} = $_[1] }
sub set_doctype_node ($$) { $_[0]->{doctype} = $_[1] }

sub is_declared_entity ($$;%) {
  my ($self, $name, %o) = @_;
  if (ref $name) {
    $o{namespace_uri} ||= $name->{namespace_uri};
    $name = $name->{local_name};
  } else {
    $o{namespace_uri} ||= $NS{SGML}.'entity';
  }
  $self->{cache}->{is_declared_entity}->{$o{namespace_uri}} = {} if $o{clear_cache};
  if (ref $o{set_value}) {
    $self->{cache}->{entity_declaration}->{$o{namespace_uri}}->{$name} = $o{set_value};
    $self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name} = 1;
  } elsif (defined $o{set_value}) {
    $self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name} = $o{set_value};
  }
  unless (defined $self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name}) {
    if ($o{seek}) {
      $self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name}
        = $self->get_entity ($name, %o) ? 1 : 0;
    }
  }
  $self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name};
}

sub get_entity ($$;%) {
  my ($self, $name, %o) = @_;
  if (ref $name) {
    $o{namespace_uri} ||= $name->{namespace_uri};
    $name = $name->{local_name};
  } else {
    $o{namespace_uri} ||= $NS{SGML}.'entity';
  }
  if (!$o{dont_use_predefined_entities}
      && ($o{namespace_uri} eq $NS{SGML}.'entity')) {   ## General entity
    my $predec = {
        amp     => '&#38;',
        apos    => '&#39;',
        gt      => '&#62;',
        lt      => '&#60;',
        quot    => '&#34;',
    }->{$name};
    if ($predec) {
      for (Message::Markup::XML->new (type => '#declaration',
                                        namespace_uri => $NS{SGML}.'entity')) {
        $_->set_attribute ('value')->append_new_node (type => '#xml', value => $predec);
        return $_;
      }
    }
  }
  $self->{cache}->{entity_declaration}->{$o{namespace_uri}} = {} if $o{clear_cache};
  my $e = $self->{cache}->{entity_declaration}->{$o{namespace_uri}}->{$name};
  return $e if ref $e;
  return undef if !$o{seek} || !(ref $self->{doctype});
  $e = $self->_get_entity ($name, $self->{doctype}->{node}, \%o);
  if (ref $e) {
    $self->{cache}->{entity_declaration}->{$o{namespace_uri}}->{$name} = $e;
    return $e;
  }
  my $xsub = $self->{doctype}->get_attribute ('external-subset');
  if (ref $xsub) {
    $e = $self->_get_entity ($name, $xsub->{node}, \%o);
    if (ref $e) {
      $self->{cache}->{entity_declaration}->{$o{namespace_uri}}->{$name} = $e;
      return $e;
    }
  }
  return undef;
}
sub _get_entity ($$$$) {
  my ($self, $name, $nodes, $o) = @_;
  return undef unless ref $nodes;
  for (@$nodes) {
    next if $_->{flag}->{smxp__non_processed_declaration};
    if ($_->{type} eq '#declaration' && $_->{namespace_uri} eq $o->{namespace_uri}
     && $_->{local_name} eq $name) {
      return $_;
    } elsif ($_->{type} eq '#reference') {
      my $e = $self->_get_entity ($name, $_->{node}, $o);
      return $e if ref $e;
    } elsif ($_->{type} eq '#section'
          && ($_->get_attribute ('status', make_new_node => 1)->inner_text||'INCLUDE')
              eq 'INCLUDE') {
      my $e = $self->_get_entity ($name, $_->{node}, $o);
      return $e if ref $e;
    }
  }
  return undef;
}

# DOM's get*By*
sub get_entities ($$%) {
  my ($self, $l, %o) = @_;
  $o{namespace_uri} = $NS{SGML}.'entity' unless defined $o{namespace_uri};
  $o{type} ||= '#declaration';
  $o{parent_node} ||= $self->{doctype};
  $self->_get_entities ($l, $o{parent_node}->{node}, \%o);
}
sub _get_entities ($$$$) {
  my ($self, $l, $nodes, $o) = @_;
  return undef unless ref $nodes;
  for (@$nodes) {
    next if $_->{flag}->{smxp__non_processed_declaration};
    if (($_->{type} eq $o->{type}) && ($_->{namespace_uri} eq $o->{namespace_uri})) {
      push @$l, $_;
    } elsif ($_->{type} eq '#reference' || $_->{type} eq '#element') {
      $self->_get_entities ($l, $_->{node}, $o);
    } elsif (($_->{type} eq '#section'
              && ($_->get_attribute ('status', make_new_node => 1)->inner_text||'INCLUDE')
              eq 'INCLUDE')
         || ($_->{type} eq '#declaration' && $_->{namespace_uri} eq $NS{SGML}.'doctype')) {
      $self->_get_entities ($l, $_->{node}, $o);
    } elsif ($_->{type} eq '#attribute' && $_->{local_name} eq 'external-subset') {
      $self->_get_entities ($l, $_->{node}, $o);
    }
  }
}

sub get_attr_definitions ($%) {
  my ($self, %o) = @_;
  return $self->{cache}->{attr_defs}->{$o{qname}}
    if $self->{cache}->{attr_defs}->{$o{qname}};
  my %r;
  $o{namespace_uri} = $NS{SGML}.'attlist';
  $o{type} = '#declaration';
  $o{parent_node} ||= $self->{doctype};
  my $l = [];
  $self->_get_entities ($l, $o{parent_node}->{node}, \%o);
  $r{declaration} = [];
  for (@$l) {
    if ($_->get_attribute ('qname', make_new_node => 1)->inner_text eq $o{qname}) {
      push @{$r{declaration}}, $_;
    }
  }
  for my $decl (@{$r{declaration}}) {
    for (@{$decl->{node}}) {
      if ($_->{type} eq '#element' && $_->{namespace_uri} eq $NS{XML}.'attlist',
          $_->{local_name} eq 'AttDef') {
        my $aname = $_->get_attribute ('qname', make_new_node => 1)->inner_text;
        if ($r{attr}->{$aname}) {
          # 
        } else {
          $r{attr}->{$aname} = $_;
          $r{attr_may_not_be_read}->{$aname} = $decl->{flag}->{smxp__declaration_may_not_be_read};
          for (@{$_->{node}}) {
            if ($_->{type} eq '#element' && $_->{namespace_uri} eq $NS{XML}.'attlist'
             && $_->{local_name} eq 'enum') {
              $r{enum}->{$aname}->{$_->inner_text} = 1;
            }
          }
        }
      }
    }
  }
  $self->{cache}->{attr_defs}->{$o{qname}} = \%r;
  \%r;
}

## TODO: uri based recursion
sub get_external_entity ($$$$) {
  my ($self, $parser, $decl, $o) = @_;
  my $declns = $decl->namespace_uri;
  my $name = $declns eq $NS{SGML}.'doctype' ?
             ($decl->get_attribute ('qname', make_new_node => 1)->inner_text
              || '#IMPLIED') :
             $decl->local_name;
  my $p = $self->{external_entity_cache}->{$declns}->{$name};
  if ($name && !$p) {
    $p = {name => $name};  $self->{external_entity_cache}->{$declns}->{$name} = $p;
    for (qw/PUBLIC SYSTEM NDATA/) {
      $p->{$_} = $decl->get_attribute ($_);
      $p->{$_} = ref $p->{$_} ? $p->{$_}->inner_text : undef;
    }
    $p->{uri} = $decl->resolve_relative_uri ($p->{SYSTEM}, use_references_base_uri => 1);
  }
    for ($o) {
      $_->{entity_type} ||= 'external_parsed_entity';
      $_->{uri} = $p->{uri};  $_->{line} = 0;  $_->{pos} = 0;
    }
  if ($name && !$p->{__flag}) {
    my $resolver = $parser->option ('uri_resolver');
    if (ref $resolver) {
      $resolver = &$resolver ($self, $parser, $decl, $p, $o);   ## If returned false,
      $self->default_uri_resolver ($parser, $decl, $p, $o) if $resolver;        ## don't call this.
    } else {
      $self->default_uri_resolver ($parser, $decl, $p, $o);
    }
    ## Line-break normalization
    $p->{text} =~ s/\x0D\x0A/\x0A/gs;
    $p->{text} =~ tr/\x0D/\x0A/;
    $p->{__flag} = 1;
  }
  $p;
}

=pod example

 my $parser = Message::Markup::XML::Parser->new (flag => {smxe__uri_resolver => sub {
        my ($self, $decl, $p) = @_;
        @@ $p->{SYSTEM} =~ s///g @@
        return 1;
 }});

=cut

sub default_uri_resolver ($$$$$;%) {
  my ($self, $parser, $decl, $p, $o, %opt) = @_;
  require LWP::UserAgent;
  my $ua = LWP::UserAgent->new;
  $ua->agent ('"Message::Markup::XML::EntityManager"/'.$VERSION);
        ## TODO: use Message::Field::UA
  my $req = HTTP::Request->new (GET => $p->{uri});
  my $res = $ua->request ($req);
  if ($res->is_success || $opt{accept_error_page}) {
    ## TODO: use Message::Entity for more intelligent/strict parsing:-)
    $p->{base_uri} = $res->base;        ## See Content-Base: and Content-Location: (and HTML:BASE)
    $p->{uri} = $res->request->uri;  $o->{uri} = $p->{uri};     ## Redirect support
    ## Check media type
    my $CT = $res->header ('Content-Type');
    my $ct = lc $res->content_type;
    $self->_check_media_type ($o, $ct);
    $p->{text} = $res->content;
    #$p->{text} .= "<!--$p->{uri}-->";  ## DEBUG: base URI
    ## Charset/encoding convertion
    my $encoding;
    if ($CT =~ /charset\s*=\s*"?([^",;\s]+)"?/i) {      ## BUG: This check is not strict
      $encoding = lc $1;
    } else {    ## No charset parameter
      if ($p->{uri}->scheme eq 'file') {
        ## Protocol does not provide charset information
      } elsif (lc (substr ($ct, 0, 5)) eq 'text/') {    ## BUG: This check is not strict
        $encoding = 'us-ascii'; ## See RFC 3023
        $self->_raise_error ($o, type => 'WARN_NO_CHARSET_PARAM_FOR_TEXT', t => $ct);
      } else {
        ## BUG: Warn even if the media type does not have the charset parameter
        $self->_raise_error ($o, type => 'WARN_NO_CHARSET_PARAM', t => $ct);
      }
    }
    unless ($encoding) {
      $encoding = $self->_guess_entity_encoding ($p->{text}, $o) || 'utf-8';
    }
    #print "<$p->{uri}>: encode is {$encoding}\n";      ## DEBUG: Detected encoding
    if ($encoding) {
      require Encode;
      eval q{$p->{text} = Encode::decode ($encoding, $p->{text}); 1}
        or $self->_raise_error ($o, type => 'FATAL_ERR_DECODE_IMPL_ERR', t => $@);
    } else {
      #$self->_raise_error ($o, type => 'WARN_NO_EXPLICIT_ENCODING_INFO');
    }
    ## parse and remove xml declaration
    unless ($opt{dont_parse_text_declaration}) {
      $p->{text_declaration} = (ref ($decl)||$decl)->new (type => '#pi', local_name => 'xml');
      $parser->_parse_xml_or_text_declaration ($p->{text_declaration}, \$p->{text}, $o);
    }
  } else {
    $p->{error}->{no_data} = 1;
    $p->{error}->{reason_text} = $res->status_line;
    $p->{uri} = $res->request->uri;  $o->{uri} = $p->{uri};     ## Redirect support
  }
}

sub is_standalone_document ($) {
  my $self = shift;
  return $self->{node}->{flag}->{smxe__standalone}
      if defined $self->{node}->{flag}->{smxe__standalone};
  for (@{$self->{node}->{node}}) {
    if ($_->{type} eq '#pi' && $_->{local_name} eq 'xml') {
      my $a = $_->get_attribute ('standalone');
      if (ref $a) {
        $self->{node}->{flag}->{smxe__standalone} = $a->inner_text eq 'yes' ? 1 : 0;
        return $self->{node}->{flag}->{smxe__standalone};
      }
    } elsif ($_->{type} eq '#attribute') {
      ## Check next node too
    } else {
      last;     ## No xml declaration
    }
  }
  $self->{node}->{flag}->{smxe__standalone} = 0;
  return $self->{node}->{flag}->{smxe__standalone};
}
sub is_standalone_document_1 ($) {
  my $self = shift;
  return $self->{node}->{flag}->{smxe__standalone_1}
      if defined $self->{node}->{flag}->{smxe__standalone_1};
  for (@{$self->{node}->{node}}) {
    if ($_->{type} eq '#pi' && $_->{local_name} eq 'xml') {
      my $a = $_->get_attribute ('standalone');
      if (ref $a) {
        $self->{node}->{flag}->{smxe__standalone_1} = $a->inner_text eq 'yes' ? 1 : 0;
        return $self->{node}->{flag}->{smxe__standalone_1};
      }
    }
    last;
  }
  if ($self->{doctype}) {
    if ($self->{doctype}->external_id) {
      $self->{node}->{flag}->{smxe__standalone_1} = 0;
      return $self->{node}->{flag}->{smxe__standalone_1};
    }
    for (@{$self->{doctype}->{node}}) {
      if ($_->{type} eq '#declaration' && $_->{namespace_uri} eq $NS{SGML}.'entity:parameter') {
        $self->{node}->{flag}->{smxe__standalone_1} = 0;
        return $self->{node}->{flag}->{smxe__standalone_1};
      }
    }
  }
  $self->{node}->{flag}->{smxe__standalone_1} = 1;
  return $self->{node}->{flag}->{smxe__standalone_1};
}

sub check_public_id ($$$) {
  my ($self, $o, $pubid) = @_;
  if (length ($pubid) == 0) {
    $self->_raise_error ($o, type => 'WARN_PID_EMPTY');
  }
  if ($pubid =~ m"([^\x0A\x0D\x20A-Za-z0-9'()+,./:=?;!*#\@\$_%-])"s) {
    $self->_raise_error ($o, type => 'SYNTAX_INVALID_PUBID', t => $1);
  }
  $pubid =~ s/[\x0A\x0D\x20]+/\x20/gs;
  if (length ($pubid) > 240) {  ## this check is not strict
    $self->_raise_error ($o, type => 'WARN_PID_IS_TOO_LONG', t => $pubid);
  }
  $pubid =~ s/^\x20//; $pubid =~ s/\x20$//;
  if ($pubid =~ /^[Uu][Rr][Nn]:/) {
    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})+$") {
      $self->_raise_error ($o, type => 'WARN_PID_IS_INVALID_URN', t => $pubid);
    } elsif ($pubid =~ m![/?]!) {
      $self->_raise_error ($o, type => 'WARN_PID_IS_URN_WITH_RESERVED_CHAR', t => $pubid);
    }
  } elsif ($pubid !~ m<^(?:[+-]//|ISO)(?:(?!//).)+//[A-Z]+ (?:(?!//).)+//(?:(?!//).)+(?://(?:(?!//).)+)?$>) {
    $self->_raise_error ($o, type => 'WARN_PID_IS_NOT_FPI_NOR_URN', t => $pubid);
  }
  $pubid;
}

sub check_system_id ($$$) {
  my ($self, $o, $sysid) = @_;
  if ($sysid =~ m"([^0-9A-Za-z_.!~*'();/?:\@&=+\$,%\[\]#-])"s) {
    $self->_raise_error ($o, type => 'WARN_INVALID_URI_CHAR_IN_SYSID', t => $1);
  }
  if ($sysid =~ s/(#[^#]*)$//g) {
    $self->_raise_error ($o, type => 'ERR_XML_SYSID_HAS_FRAGMENT', t => $1);
  }
  if (length ($sysid) == 0) {
    $self->_raise_error ($o, type => 'WARN_SYSID_EMPTY');
  }
  $sysid;
}

sub check_ns_uri ($$$$) {       ## TODO: check predefined NS
  my ($self, $o, $ns_pfx => $ns_name) = @_;
  if ($ns_name =~ m"([^0-9A-Za-z_.!~*'();/?:\@&=+\$,%\[\]#-])"s) {
    $self->_raise_error ($o, type => 'WARN_INVALID_URI_CHAR_IN_NS_NAME', t => $1);
  }
  if ($ns_name !~ /^[0-9A-Za-z.+-]+:/) {
    $self->_raise_error ($o, type => 'WARN_XML_NS_URI_IS_RELATIVE', t => $ns_name);
  }
}

## Guess encoding of the entity by BOM and '<?' and Encode::Guess --- Used by default resolver
sub _guess_entity_encoding ($$) {
  my ($self, $entity, $o) = @_;
  my $encoding;
  my $f2 = substr ($entity, 0, 2);
  my $s2 = substr ($entity, 2, 2);
  if ($f2 eq "<?") {
    $encoding = '*ascii';
  } elsif ($f2 eq "\xEF\xBB" && substr ($s2, 0, 1) eq "\xBF") {
    $encoding = '*utf-8';
  } elsif ($f2 eq "\xFE\xFF" || $f2 eq "\x00\x3C") {
    if ($s2 eq "\x00\x00") {
      $encoding = '*ucs-4-3412';
    } else {
      $encoding = '*ucs-2be';
    }
  } elsif ($f2 eq "\xFF\xFE" || $f2 eq "\x3C\x00") {
    if ($s2 eq "\x00\x00") {
      $encoding = '*ucs-4le';
    } else {
      $encoding = '*ucs-2le';
    }
  } elsif ($f2 eq "\x00\x00") {
    if ($s2 eq "\xFE\xFF" || $s2 eq "\x00\x3C") {
      $encoding = '*ucs-4be';
    } elsif ($s2 eq "\xFF\xFE" || $s2 eq "\x3C\x00") {
      $encoding = '*ucs-4-2143';
    }
  } elsif ($f2 eq "\x4C\x6F") {
    $encoding = '*ebcdic';
  }
  
  ## TODO: Charset list need more consideration
  my @guess_list;
  if ($encoding eq '*ascii' || $encoding eq '*utf-8') {
    if ($entity =~ /<\?xml.+?encoding=["']([0-9A-Za-z._-]+)["']/) {
      $encoding = lc $1;
    } else {
      if ($encoding eq '*utf-8') {
        $encoding = undef;
        @guess_list = qw/utf-8 cesu-8 unicode-1-1-utf-8/;
      } else {
        $encoding = undef;
        @guess_list = qw/us-ascii iso-8859-1 iso-8859-2 iso-8859-8 iso-8859-15
                         iso-2022-jp euc-jp shift_jis euc-kr
                         gbk gb18030 big5-eten big5-hkscs windows-1252 koi8-r koi8-u/;
      }
    }
  } elsif ($encoding =~ /ucs/) {
    my $ent = $entity; $ent =~ tr/\x00//d;
    if ($ent =~ /<\?xml.+?encoding=["']([0-9A-Za-z._-]+)["']/) {
      $encoding = lc $1;
    } else {
      if ($encoding eq '*ucs-2be') {
        $encoding = 'utf-16be';
      } elsif ($encoding eq '*ucs-2le') {
        $encoding = 'utf-16le';
      } elsif ($encoding =~ /(ucs-4.+)/) {
        $encoding = $1;
      }
    }
  } elsif ($encoding eq '*ebcdic') {
    @guess_list = qw/cp037 cp500 cp875 cp1026 cp1047 posix-bc/; ## All Encode::EBCDIC supporteds
  }
  
  unless ($encoding) {
    $self->_raise_error ($o, type => 'WARN_NO_EXPLICIT_ENCODING_INFO');
    require Encode::Guess;
    unless (@guess_list) {
      @guess_list = qw/utf-8 utf-16 utf-16be utf-16le
                       7bit-jis euc-jp shift_jis gbk gb18030 euc-kr big5-eten big5-hkscs
                       iso-8859-1 iso-8859-8 koi8-r koi8-u tis-620
                       windows-1252/;
    }
    my @gl;
    for (@guess_list) {
      push @gl, $_ if Encode::find_encoding ($_);
    }
    my $enc;
    eval q{$enc = Encode::Guess::guess_encoding ($entity, @gl); 1}
      or $self->_raise_error ($o, type => 'WARN_GUESS_ENCODING_IMPL_ERR', t => $@);
    $encoding = $enc->name if ref $enc;
  }
  $encoding;
}

## Check whether the media type specified is better one for that type of entity
## and raise error if not --- See RFC 3023
## 
## Known error: Warn even when source is local file doesn't have meta type information
##              (but LWP give inappropreate value such as 'text/plain').  This is an error but spec.
sub _check_media_type ($$$) {
  my ($self, $o, $ct) = @_;
  if ($ct eq 'application/xml' || $ct eq 'text/xml') {
      if ($o->{entity_type} eq 'external_parsed_entity'
       || $o->{entity_type} eq 'external_general_parsed_entity') {
        $self->_raise_error ($o, type => 'WARN_MT_XML_FOR_EXT_GENERAL_ENTITY', t => $ct);
      } elsif ($o->{entity_type} ne 'document_entity') {
        $self->_raise_error ($o, type => 'ERR_MT_XML_FOR_EXT_ENTITY', t => $ct);
      }
      if ($ct eq 'text/xml') {
        $self->_raise_error ($o, type => 'WARN_MT_TEXT_XML');
      }
  } elsif ($o->{entity_type} eq 'external_general_parsed_entity') {
        if ($ct eq 'text/xml-external-parsed-entity') {
          $self->_raise_error ($o, type => 'WARN_MT_TEXT_XML_EXTERNAL_PARSED_ENTITY');
        } elsif ($ct ne 'application/xml-external-parsed-entity') {
          $self->_raise_error ($o, type => 'WARN_MT_EXTERNAL_GENERAL_PARSED_ENTITY', t => $ct);
        }
  } elsif ($o->{entity_type} eq 'dtd_external_subset'
        || $o->{entity_type} eq 'external_parameter_entity') {
    if ($ct ne 'application/xml-dtd') {
      $self->_raise_error ($o, type => 'WARN_MT_DTD_EXTERNAL_SUBSET', t => $ct);
    }
  }
}

sub option ($$;$) {
  my ($self, $name, $value) = @_;
  if (defined $value) {
    $self->{option}->{$name} = $value;
  }
  $self->{option}->{$name};
}

sub flag ($$;$) {
  my ($self, $name, $value) = @_;
  if (defined $value) {
    $self->{flag}->{$name} = $value;
  }
  $self->{flag}->{$name};
}

## $self->_raise_error: Raising error or warn
require Message::Markup::XML::Error;
*_raise_error = \&Message::Markup::XML::Error::raise;

=head1 DEVELOPER'S NOTE

This module "knows" how Message::Markup::XML works, i.e. this module accesses
internal structure of that module directly.

=head1 LICENSE

Copyright 2003 Wakaba <[email protected]>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

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