Markup/XML/EntityManager.pm


=head1 NAME

SuikaWiki::Markup::XML::EntityManager --- SuikaWiki 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 SuikaWiki XML support.

=cut

package SuikaWiki::Markup::XML::EntityManager;
use strict;
our $VERSION = do{my @r=(q$Revision: 1.9 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
our %NS;
*NS = \%SuikaWiki::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};
  $self->{cache}->{is_declared_entity}->{$o{namespace_uri}}->{$name} = $o{set_value}
    if defined $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 (SuikaWiki::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 unless 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 :
             $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 = SuikaWiki::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 ('"SuikaWiki::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 SuikaWiki::Markup::XML::Error;
*_raise_error = \&SuikaWiki::Markup::XML::Error::raise;

=head1 DEVELOPER'S NOTE

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