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