Message/DOM/Attr.pm

package Message::DOM::Attr;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.9 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
push our @ISA, 'Message::DOM::Node', 'Message::IF::Attr';
require Message::DOM::Node;

sub ____new ($$$$$$) {
  my $self = shift->SUPER::____new (shift);
  ($$self->{owner_element},
   $$self->{namespace_uri},
   $$self->{prefix},
   $$self->{local_name}) = @_;
  Scalar::Util::weaken ($$self->{owner_element});
  $$self->{child_nodes} = [];
  $$self->{specified} = 1;
  return $self;
} # ____new
             
sub AUTOLOAD {
  my $method_name = our $AUTOLOAD;
  $method_name =~ s/.*:://;
  return if $method_name eq 'DESTROY';

  if ({
    ## Read-only attributes (trivial accessors)
    namespace_uri => 1,
    owner_element => 1,
  }->{$method_name}) {
    no strict 'refs';
    eval qq{
      sub $method_name (\$) {
        return \${\$_[0]}->{$method_name}; 
      }
    };
    goto &{ $AUTOLOAD };
  } else {
    require Carp;
    Carp::croak (qq<Can't locate method "$AUTOLOAD">);
  }
} # AUTOLOAD
sub owner_element ($);

## |Node| attributes

sub base_uri ($) {
  my $self = $_[0];
  local $Error::Depth = $Error::Depth + 1;
  my $oe = $self->owner_element;
  if ($oe) {
    my $ln = $self->manakai_local_name;
    my $nsuri = $self->namespace_uri;
    if (($ln eq 'base' and
         defined $nsuri and $nsuri eq 'http://www.w3.org/XML/1998/namespace') or
        ($ln eq 'xml:base' and not defined $nsuri)) {
      my $oep = $oe->parent_node;
      if ($oep) {
        return $oep->base_uri;
      } else {
        return $self->owner_document->base_uri;
      }
    } else {
      return $oe->base_uri;
    }
  } else {
    return $self->owner_document->base_uri;
  }
} # base_uri

sub local_name ($) {
  ## TODO: HTML5
  return ${+shift}->{local_name};
} # local_name

sub manakai_local_name ($) {
  return ${$_[0]}->{local_name};
} # manakai_local_name

sub namespace_uri ($);

*node_name = \&name;

sub node_type () { 2 } # ATTRIBUTE_NODE

*node_value = \&Message::DOM::Node::text_content;

sub prefix ($;$) {
  ## NOTE: No check for new value as Firefox doesn't do.
  ## See <http://suika.fam.cx/gate/2005/sw/prefix>.

  ## NOTE: Same as trivial setter except "" -> undef

  ## NOTE: Same as |Element|'s |prefix|.
  
  if (@_ > 1) {
    if (${${$_[0]}->{owner_document}}->{strict_error_checking} and 
        ${$_[0]}->{manakai_read_only}) {
      report Message::DOM::DOMException
          -object => $_[0],
          -type => 'NO_MODIFICATION_ALLOWED_ERR',
          -subtype => 'READ_ONLY_NODE_ERR';
    }
    if (defined $_[1] and $_[1] ne '') {
      ${$_[0]}->{prefix} = ''.$_[1];
    } else {
      delete ${$_[0]}->{prefix};
    }
  }
  return ${$_[0]}->{prefix}; 
} # prefix

## |Node| methods

sub append_child ($$) {
  my $self = $_[0];
  
  ## NOTE: Depends on $self->node_type:
  my $self_od = $$self->{owner_document};

  ## -- Node Type check
  my @new_child;
  my $new_child_parent;
  if ($_[1]->node_type == 11) { # DOCUMENT_FRAGMENT_NODE
    push @new_child, @{$_[1]->child_nodes};
    $new_child_parent = $_[1];
  } else {
    @new_child = ($_[1]);
    $new_child_parent = $_[1]->parent_node;
  }

  ## NOTE: Depends on $self->node_type:
  if ($$self_od->{strict_error_checking}) {
    my $child_od = $_[1]->owner_document || $_[1]; # might be DocumentType
    if ($self_od ne $child_od and $child_od->node_type != 10) {
      report Message::DOM::DOMException # DOCUMENT_TYPE_NODE
          -object => $self,
          -type => 'WRONG_DOCUMENT_ERR',
          -subtype => 'EXTERNAL_OBJECT_ERR';
    }

    if ($$self->{manakai_read_only} or
        (@new_child and defined $new_child_parent and
         $$new_child_parent->{manakai_read_only})) {
      report Message::DOM::DOMException
          -object => $self,
          -type => 'NO_MODIFICATION_ALLOWED_ERR',
          -subtype => 'READ_ONLY_NODE_ERR';
    }

    ## NOTE: |Document| has children order check here.

    for my $cn (@new_child) {
      unless ({
               3, 1, 5, 1, # TEXT_NODE, ENTITY_REFERENCE_NODE
              }->{$cn->node_type}) {
        report Message::DOM::DOMException
            -object => $self,
            -type => 'HIERARCHY_REQUEST_ERR',
            -subtype => 'CHILD_NODE_TYPE_ERR';
      }
    }

    ## NOTE: Ancestor check here in |Node|.
  }

  ## NOTE: "Insert at" code only in insert_before and replace_child

  ## -- Removes from parent
  if ($new_child_parent) {
    if (@new_child == 1) {
      my $v = $$new_child_parent->{child_nodes};
      RP: for my $i (0..$#$v) {
        if ($v->[$i] eq $new_child[0]) {
          splice @$v, $i, 1, ();
          last RP;
        }
      } # RP
    } else {
      @{$$new_child_parent->{child_nodes}} = ();
    }
  }

  ## -- Rewrite the |parentNode| properties
  for my $nc (@new_child) {
    $$nc->{parent_node} = $self;
    Scalar::Util::weaken ($$nc->{parent_node});
  }

  ## NOTE: Depends on method:
  push @{$$self->{child_nodes}}, @new_child;

  ## NOTE: Setting |owner_document| in |Document|.

  return $_[1];
} # apepnd_child

sub insert_before ($$) {
  my $self = $_[0];

  ## NOTE: Depends on $self->node_type:
  my $self_od = $$self->{owner_document};

  ## -- Node Type check
  my @new_child;
  my $new_child_parent;
  if ($_[1]->node_type == 11) { # DOCUMENT_FRAGMENT_NODE
    push @new_child, @{$_[1]->child_nodes};
    $new_child_parent = $_[1];
  } else {
    @new_child = ($_[1]);
    $new_child_parent = $_[1]->parent_node;
  }

  ## NOTE: Depends on $self->node_type:
  if ($$self_od->{strict_error_checking}) {
    my $child_od = $_[1]->owner_document || $_[1]; # might be DocumentType
    if ($self_od ne $child_od and $child_od->node_type != 10) {
      report Message::DOM::DOMException # DOCUMENT_TYPE_NODE
          -object => $self,
          -type => 'WRONG_DOCUMENT_ERR',
          -subtype => 'EXTERNAL_OBJECT_ERR';
    }

    if ($$self->{manakai_read_only} or
        (@new_child and defined $new_child_parent and
         $$new_child_parent->{manakai_read_only})) {
      report Message::DOM::DOMException
          -object => $self,
          -type => 'NO_MODIFICATION_ALLOWED_ERR',
          -subtype => 'READ_ONLY_NODE_ERR';
    }

    ## NOTE: |Document| has children order check here.

    for my $cn (@new_child) {
      unless ({
               3, 1, 5, 1, # TEXT_NODE, ENTITY_REFERENCE_NODE
              }->{$cn->node_type}) {
        report Message::DOM::DOMException
            -object => $self,
            -type => 'HIERARCHY_REQUEST_ERR',
            -subtype => 'CHILD_NODE_TYPE_ERR';
      }
    }

    ## NOTE: Ancestor check here in |Node|.
  }
  
  ## -- Insert at... ## NOTE: Only in insert_before and replace_child
  my $index = -1; # last
  if (defined $_[2]) {
    ## error if $_[1] eq $_[2];
    
    my $cns = $self->child_nodes;
    my $cnsl = @$cns;
    C: {
      $index = 0;
      for my $i (0..($cnsl-1)) {
        my $cn = $cns->[$i];
        if ($cn eq $_[2]) {
          $index += $i;
          last C;
        } elsif ($cn eq $_[1]) {
          $index = -1; # offset
        }
      }
      
      report Message::DOM::DOMException
          -object => $self,
          -type => 'NOT_FOUND_ERR',
          -subtype => 'NOT_CHILD_ERR';
    } # C
  }
  ## NOTE: "else" only in replace_child

  ## -- Removes from parent
  if ($new_child_parent) {
    if (@new_child == 1) {
      my $v = $$new_child_parent->{child_nodes};
      RP: for my $i (0..$#$v) {
        if ($v->[$i] eq $new_child[0]) {
          splice @$v, $i, 1, ();
          last RP;
        }
      } # RP
    } else {
      @{$$new_child_parent->{child_nodes}} = ();
    }
  }

  ## -- Rewrite the |parentNode| properties
  for my $nc (@new_child) {
    $$nc->{parent_node} = $self;
    Scalar::Util::weaken ($$nc->{parent_node});
  }

  ## NOTE: Depends on method:
  if ($index == -1) {
    push @{$$self->{child_nodes}}, @new_child;
  } else {
    splice @{$$self->{child_nodes}}, $index, 0, @new_child;
  }

  ## NOTE: Setting |owner_document| in |Document|.

  return $_[1];
} # insert_before

sub replace_child ($$) {
  my $self = $_[0];

  ## NOTE: Depends on $self->node_type:
  my $self_od = $$self->{owner_document};

  ## -- Node Type check
  my @new_child;
  my $new_child_parent;
  if ($_[1]->node_type == 11) { # DOCUMENT_FRAGMENT_NODE
    push @new_child, @{$_[1]->child_nodes};
    $new_child_parent = $_[1];
  } else {
    @new_child = ($_[1]);
    $new_child_parent = $_[1]->parent_node;
  }

  ## NOTE: Depends on $self->node_type:
  if ($$self_od->{strict_error_checking}) {
    my $child_od = $_[1]->owner_document || $_[1]; # might be DocumentType
    if ($self_od ne $child_od and $child_od->node_type != 10) {
      report Message::DOM::DOMException # DOCUMENT_TYPE_NODE
          -object => $self,
          -type => 'WRONG_DOCUMENT_ERR',
          -subtype => 'EXTERNAL_OBJECT_ERR';
    }

    if ($$self->{manakai_read_only} or
        (@new_child and defined $new_child_parent and
         $$new_child_parent->{manakai_read_only})) {
      report Message::DOM::DOMException
          -object => $self,
          -type => 'NO_MODIFICATION_ALLOWED_ERR',
          -subtype => 'READ_ONLY_NODE_ERR';
    }

    ## NOTE: |Document| has children order check here.

    for my $cn (@new_child) {
      unless ({
               3, 1, 5, 1, # TEXT_NODE, ENTITY_REFERENCE_NODE
              }->{$cn->node_type}) {
        report Message::DOM::DOMException
            -object => $self,
            -type => 'HIERARCHY_REQUEST_ERR',
            -subtype => 'CHILD_NODE_TYPE_ERR';
      }
    }

    ## NOTE: Ancestor check here in |Node|.
  }
  
  ## -- Insert at... ## NOTE: Only in insertBefore and replaceChild
  my $index = -1; # last
  if (defined $_[2]) {
    ## error if $_[1] eq $_[2];
    
    my $cns = $self->child_nodes;
    my $cnsl = @$cns;
    C: {
      $index = 0;
      for my $i (0..($cnsl-1)) {
        my $cn = $cns->[$i];
        if ($cn eq $_[2]) {
          $index += $i;
          last C;
        } elsif ($cn eq $_[1]) {
          $index = -1; # offset
        }
      }
      
      report Message::DOM::DOMException
          -object => $self,
          -type => 'NOT_FOUND_ERR',
          -subtype => 'NOT_CHILD_ERR';
    } # C
  } else {
    ## NOTE: Only in replaceChild
    report Message::DOM::DOMException
        -object => $self,
        -type => 'NOT_FOUND_ERR',
        -subtype => 'NOT_CHILD_ERR';
  }

  ## -- Removes from parent
  if ($new_child_parent) {
    if (@new_child == 1) {
      my $v = $$new_child_parent->{child_nodes};
      RP: for my $i (0..$#$v) {
        if ($v->[$i] eq $new_child[0]) {
          splice @$v, $i, 1, ();
          last RP;
        }
      } # RP
    } else {
      @{$$new_child_parent->{child_nodes}} = ();
    }
  }

  ## -- Rewrite the |parentNode| properties
  for my $nc (@new_child) {
    $$nc->{parent_node} = $self;
    Scalar::Util::weaken ($$nc->{parent_node});
  }

  ## NOTE: Depends on method:
  splice @{$$self->{child_nodes}}, $index, 1, @new_child;
  delete ${$_[2]}->{parent_node};

  ## NOTE: Setting |owner_document| in |Document|.

  return $_[2];
} # replace_child

## |Attr| attributes

sub manakai_attribute_type ($;$) {
  my $self = $_[0];
  if (@_ > 1) {
    if (${$$self->{owner_document}}->{strict_error_checking}) {
      if ($$self->{manakai_read_only}) {
        report Message::DOM::DOMException
            -object => $self,
            -type => 'NO_MODIFICATION_ALLOWED_ERR',
            -subtype => 'READ_ONLY_NODE_ERR';
      }
    }
    if ($_[1]) {
      $$self->{manakai_attribute_type} = 0+$_[1];
    } else {
      delete $$self->{manakai_attribute_type};
    }
  }
  
  return $$self->{manakai_attribute_type} || 0;
} # manakai_attribute_type

sub is_id ($;$) {
  my $self = $_[0];

  if (@_ > 1) {
    ## NOTE: The setter is a manakai extension.
    ## TODO: Document.

    if (${$$self->{owner_document}}->{strict_error_checking}) {
      if ($$self->{manakai_read_only}) {
        report Message::DOM::DOMException
              -object => $self,
              -type => 'NO_MODIFICATION_ALLOWED_ERR',
              -subtype => 'READ_ONLY_NODE_ERR';
      }
    }

    if ($_[1]) {
      $$self->{manakai_user_determined_id} = 1;
    } else {
      delete $$self->{manakai_user_determined_id};
    }
  }
  return unless defined wantarray;
  
  ## DTD Attribute Type
  my $type = $$self->{manakai_attribute_type};
  if (defined $type and $type == 2) { # ID_ATTR
    return 1;
  }
  
  ## User-determined ID
  if ($$self->{manakai_user_determined_id}) {
    return 1;
  }

  ## Application-determined ID
  my $nsuri = $self->namespace_uri;
  my $ln = $self->manakai_local_name;
  if (defined $nsuri) {
    if ($ln eq 'id') {
      if ($nsuri eq q<http://www.w3.org/XML/1998/namespace>) {
        return 1;
      }
    }
  } else {
    if ($ln eq 'xml:id') {
      return 1;
    }

    my $oe = $$self->{owner_element};
    if ($oe) {
      my $oe_nsuri = $oe->namespace_uri;
      if (defined $oe_nsuri) {
        if ($ln eq 'id') {
          if ($oe_nsuri eq q<http://www.w3.org/1999/xhtml>) {
            return 1;
          }
        }
      }
    }
  }

  return 0;
} # is_id

## TODO: HTML5 case stuff?
sub name ($) {
  my $self = shift;
  if (defined $$self->{prefix}) {
    return $$self->{prefix} . ':' . $$self->{local_name};
  } else {
    return $$self->{local_name};
  }
} # name

## TODO: Documentation
sub manakai_name ($) {
  my $self = shift;
  if (defined $$self->{prefix}) {
    return $$self->{prefix} . ':' . $$self->{local_name};
  } else {
    return $$self->{local_name};
  }
} # manakai_name

sub schema_type_info ($) {
  require Message::DOM::TypeInfo;
  my $v = ${$_[0]}->{manakai_attribute_type} || 0;
  return bless \$v, 'Message::DOM::TypeInfo';
} # schema_type_info

sub specified ($;$) {
  if (@_ > 1) {
    ## NOTE: A manakai extension.
    if (${${$_[0]}->{owner_document}}->{strict_error_checking} and 
        ${$_[0]}->{manakai_read_only}) {
      report Message::DOM::DOMException
          -object => $_[0],
          -type => 'NO_MODIFICATION_ALLOWED_ERR',
          -subtype => 'READ_ONLY_NODE_ERR';
    }
    if ($_[1] or not defined ${$_[0]}->{owner_element}) {
      ${$_[0]}->{specified} = 1;
    } else {
      delete ${$_[0]}->{specified};
    }
  }
  return ${$_[0]}->{specified}; 
} # specified

*value = \&node_value;

package Message::IF::Attr;

package Message::DOM::Document;

sub create_attribute ($$) {
  if (${$_[0]}->{strict_error_checking}) {
    my $xv = $_[0]->xml_version;
    ## TODO: HTML Document ??
    if (defined $xv) {
      if ($xv eq '1.0' and
          $_[1] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
        #
      } elsif ($xv eq '1.1' and
               $_[1] =~ /\A\p{InXMLNameStartChar11}\p{InXMLNameChar11}*\z/) {
        # 
      } else {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'INVALID_CHARACTER_ERR',
            -subtype => 'MALFORMED_NAME_ERR';
      }
    }
  }
  ## TODO: HTML5
  return Message::DOM::Attr->____new ($_[0], undef, undef, undef, $_[1]);
} # create_attribute

sub create_attribute_ns ($$$) {
  my ($prefix, $lname);
  if (ref $_[2] eq 'ARRAY') {
    ($prefix, $lname) = @{$_[2]};
  } else {
    ($prefix, $lname) = split /:/, $_[2], 2;
    ($prefix, $lname) = (undef, $prefix) unless defined $lname;
  }
  my $nsuri = defined $_[1] ? $_[1] eq '' ? undef : $_[1] : undef;

  if (${$_[0]}->{strict_error_checking}) {
    my $xv = $_[0]->xml_version;
    ## TODO: HTML Document ?? (NOT_SUPPORTED_ERR is different from what Web browsers do)
    if (defined $xv) {
      if ($xv eq '1.0') {
        if (ref $_[2] eq 'ARRAY' or
            $_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
          if (defined $prefix) {
            if ($prefix =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) {
              #
            } else {
              report Message::DOM::DOMException
                  -object => $_[0],
                  -type => 'NAMESPACE_ERR',
                  -subtype => 'MALFORMED_QNAME_ERR';
            }
          }
          if ($lname =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) {
            #
          } else {
            report Message::DOM::DOMException
                -object => $_[0],
                -type => 'NAMESPACE_ERR',
                -subtype => 'MALFORMED_QNAME_ERR';
          }
        } else {
          report Message::DOM::DOMException
              -object => $_[0],
              -type => 'INVALID_CHARACTER_ERR',
              -subtype => 'MALFORMED_NAME_ERR';
        }
      } elsif ($xv eq '1.1') {
        if (ref $_[2] eq 'ARRAY' or
            $_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
          if (defined $prefix) {
            if ($prefix =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) {
              #
            } else {
              report Message::DOM::DOMException
                  -object => $_[0],
                  -type => 'NAMESPACE_ERR',
                  -subtype => 'MALFORMED_QNAME_ERR';
            }
          }
          if ($lname =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) {
            #
          } else {
            report Message::DOM::DOMException
                -object => $_[0],
                -type => 'NAMESPACE_ERR',
                -subtype => 'MALFORMED_QNAME_ERR';
          }
        } else {
          report Message::DOM::DOMException
              -object => $_[0],
              -type => 'INVALID_CHARACTER_ERR',
              -subtype => 'MALFORMED_NAME_ERR';
        }
      } else {
        die "create_attribute_ns: XML version |$xv| is not supported";
      }
    }

    if (defined $prefix) {
      if (not defined $nsuri) {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'PREFIXED_NULLNS_ERR';
      } elsif ($prefix eq 'xml' and 
               $nsuri ne q<http://www.w3.org/XML/1998/namespace>) {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'XMLPREFIX_NONXMLNS_ERR';
      } elsif ($prefix eq 'xmlns' and
               $nsuri ne q<http://www.w3.org/2000/xmlns/>) {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'XMLNSPREFIX_NONXMLNSNS_ERR';
      } elsif ($nsuri eq q<http://www.w3.org/2000/xmlns/> and
               $prefix ne 'xmlns') {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR';
      }
    } else { # no prefix
      if ($lname eq 'xmlns' and
          (not defined $nsuri or $nsuri ne q<http://www.w3.org/2000/xmlns/>)) {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'XMLNS_NONXMLNSNS_ERR';
      } elsif (not defined $nsuri) {
        #
      } elsif ($nsuri eq q<http://www.w3.org/2000/xmlns/> and
               $lname ne 'xmlns') {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR';
      }
    }
  }

  ## TODO: Older version of manakai set |attribute_type|
  ## attribute for |xml:id| attribute.  Should we support this?

  return Message::DOM::Attr->____new ($_[0], undef, $nsuri, $prefix, $lname);
} # create_attribute_ns

=head1 LICENSE

Copyright 2007 Wakaba <w@suika.fam.cx>

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

=cut

1;
## $Date: 2007/07/08 13:04:36 $
1	package Message::DOM::Attr;
2	use strict;
3	our $VERSION=do{my @r=(q$Revision: 1.9 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4	push our @ISA, 'Message::DOM::Node', 'Message::IF::Attr';
5	require Message::DOM::Node;
6
7	sub ____new ($$$$$$) {
8	my $self = shift->SUPER::____new (shift);
9	($$self->{owner_element},
10	$$self->{namespace_uri},
11	$$self->{prefix},
12	$$self->{local_name}) = @_;
13	Scalar::Util::weaken ($$self->{owner_element});
14	$$self->{child_nodes} = [];
15	$$self->{specified} = 1;
16	return $self;
17	} # ____new
18
19	sub AUTOLOAD {
20	my $method_name = our $AUTOLOAD;
21	$method_name =~ s/.*:://;
22	return if $method_name eq 'DESTROY';
23
24	if ({
25	## Read-only attributes (trivial accessors)
26	namespace_uri => 1,
27	owner_element => 1,
28	}->{$method_name}) {
29	no strict 'refs';
30	eval qq{
31	sub $method_name (\$) {
32	return \${\$_[0]}->{$method_name};
33	}
34	};
35	goto &{ $AUTOLOAD };
36	} else {
37	require Carp;
38	Carp::croak (qq<Can't locate method "$AUTOLOAD">);
39	}
40	} # AUTOLOAD
41	sub owner_element ($);
42
43	## \|Node\| attributes
44
45	sub base_uri ($) {
46	my $self = $_[0];
47	local $Error::Depth = $Error::Depth + 1;
48	my $oe = $self->owner_element;
49	if ($oe) {
50	my $ln = $self->manakai_local_name;
51	my $nsuri = $self->namespace_uri;
52	if (($ln eq 'base' and
53	defined $nsuri and $nsuri eq 'http://www.w3.org/XML/1998/namespace') or
54	($ln eq 'xml:base' and not defined $nsuri)) {
55	my $oep = $oe->parent_node;
56	if ($oep) {
57	return $oep->base_uri;
58	} else {
59	return $self->owner_document->base_uri;
60	}
61	} else {
62	return $oe->base_uri;
63	}
64	} else {
65	return $self->owner_document->base_uri;
66	}
67	} # base_uri
68
69	sub local_name ($) {
70	## TODO: HTML5
71	return ${+shift}->{local_name};
72	} # local_name
73
74	sub manakai_local_name ($) {
75	return ${$_[0]}->{local_name};
76	} # manakai_local_name
77
78	sub namespace_uri ($);
79
80	*node_name = \&name;
81
82	sub node_type () { 2 } # ATTRIBUTE_NODE
83
84	*node_value = \&Message::DOM::Node::text_content;
85
86	sub prefix ($;$) {
87	## NOTE: No check for new value as Firefox doesn't do.
88	## See <http://suika.fam.cx/gate/2005/sw/prefix>.
89
90	## NOTE: Same as trivial setter except "" -> undef
91
92	## NOTE: Same as \|Element\|'s \|prefix\|.
93
94	if (@_ > 1) {
95	if (${${$_[0]}->{owner_document}}->{strict_error_checking} and
96	${$_[0]}->{manakai_read_only}) {
97	report Message::DOM::DOMException
98	-object => $_[0],
99	-type => 'NO_MODIFICATION_ALLOWED_ERR',
100	-subtype => 'READ_ONLY_NODE_ERR';
101	}
102	if (defined $_[1] and $_[1] ne '') {
103	${$_[0]}->{prefix} = ''.$_[1];
104	} else {
105	delete ${$_[0]}->{prefix};
106	}
107	}
108	return ${$_[0]}->{prefix};
109	} # prefix
110
111	## \|Node\| methods
112
113	sub append_child ($$) {
114	my $self = $_[0];
115
116	## NOTE: Depends on $self->node_type:
117	my $self_od = $$self->{owner_document};
118
119	## -- Node Type check
120	my @new_child;
121	my $new_child_parent;
122	if ($_[1]->node_type == 11) { # DOCUMENT_FRAGMENT_NODE
123	push @new_child, @{$_[1]->child_nodes};
124	$new_child_parent = $_[1];
125	} else {
126	@new_child = ($_[1]);
127	$new_child_parent = $_[1]->parent_node;
128	}
129
130	## NOTE: Depends on $self->node_type:
131	if ($$self_od->{strict_error_checking}) {
132	my $child_od = $_[1]->owner_document \|\| $_[1]; # might be DocumentType
133	if ($self_od ne $child_od and $child_od->node_type != 10) {
134	report Message::DOM::DOMException # DOCUMENT_TYPE_NODE
135	-object => $self,
136	-type => 'WRONG_DOCUMENT_ERR',
137	-subtype => 'EXTERNAL_OBJECT_ERR';
138	}
139
140	if ($$self->{manakai_read_only} or
141	(@new_child and defined $new_child_parent and
142	$$new_child_parent->{manakai_read_only})) {
143	report Message::DOM::DOMException
144	-object => $self,
145	-type => 'NO_MODIFICATION_ALLOWED_ERR',
146	-subtype => 'READ_ONLY_NODE_ERR';
147	}
148
149	## NOTE: \|Document\| has children order check here.
150
151	for my $cn (@new_child) {
152	unless ({
153	3, 1, 5, 1, # TEXT_NODE, ENTITY_REFERENCE_NODE
154	}->{$cn->node_type}) {
155	report Message::DOM::DOMException
156	-object => $self,
157	-type => 'HIERARCHY_REQUEST_ERR',
158	-subtype => 'CHILD_NODE_TYPE_ERR';
159	}
160	}
161
162	## NOTE: Ancestor check here in \|Node\|.
163	}
164
165	## NOTE: "Insert at" code only in insert_before and replace_child
166
167	## -- Removes from parent
168	if ($new_child_parent) {
169	if (@new_child == 1) {
170	my $v = $$new_child_parent->{child_nodes};
171	RP: for my $i (0..$#$v) {
172	if ($v->[$i] eq $new_child[0]) {
173	splice @$v, $i, 1, ();
174	last RP;
175	}
176	} # RP
177	} else {
178	@{$$new_child_parent->{child_nodes}} = ();
179	}
180	}
181
182	## -- Rewrite the \|parentNode\| properties
183	for my $nc (@new_child) {
184	$$nc->{parent_node} = $self;
185	Scalar::Util::weaken ($$nc->{parent_node});
186	}
187
188	## NOTE: Depends on method:
189	push @{$$self->{child_nodes}}, @new_child;
190
191	## NOTE: Setting \|owner_document\| in \|Document\|.
192
193	return $_[1];
194	} # apepnd_child
195
196	sub insert_before ($$) {
197	my $self = $_[0];
198
199	## NOTE: Depends on $self->node_type:
200	my $self_od = $$self->{owner_document};
201
202	## -- Node Type check
203	my @new_child;
204	my $new_child_parent;
205	if ($_[1]->node_type == 11) { # DOCUMENT_FRAGMENT_NODE
206	push @new_child, @{$_[1]->child_nodes};
207	$new_child_parent = $_[1];
208	} else {
209	@new_child = ($_[1]);
210	$new_child_parent = $_[1]->parent_node;
211	}
212
213	## NOTE: Depends on $self->node_type:
214	if ($$self_od->{strict_error_checking}) {
215	my $child_od = $_[1]->owner_document \|\| $_[1]; # might be DocumentType
216	if ($self_od ne $child_od and $child_od->node_type != 10) {
217	report Message::DOM::DOMException # DOCUMENT_TYPE_NODE
218	-object => $self,
219	-type => 'WRONG_DOCUMENT_ERR',
220	-subtype => 'EXTERNAL_OBJECT_ERR';
221	}
222
223	if ($$self->{manakai_read_only} or
224	(@new_child and defined $new_child_parent and
225	$$new_child_parent->{manakai_read_only})) {
226	report Message::DOM::DOMException
227	-object => $self,
228	-type => 'NO_MODIFICATION_ALLOWED_ERR',
229	-subtype => 'READ_ONLY_NODE_ERR';
230	}
231
232	## NOTE: \|Document\| has children order check here.
233
234	for my $cn (@new_child) {
235	unless ({
236	3, 1, 5, 1, # TEXT_NODE, ENTITY_REFERENCE_NODE
237	}->{$cn->node_type}) {
238	report Message::DOM::DOMException
239	-object => $self,
240	-type => 'HIERARCHY_REQUEST_ERR',
241	-subtype => 'CHILD_NODE_TYPE_ERR';
242	}
243	}
244
245	## NOTE: Ancestor check here in \|Node\|.
246	}
247
248	## -- Insert at... ## NOTE: Only in insert_before and replace_child
249	my $index = -1; # last
250	if (defined $_[2]) {
251	## error if $_[1] eq $_[2];
252
253	my $cns = $self->child_nodes;
254	my $cnsl = @$cns;
255	C: {
256	$index = 0;
257	for my $i (0..($cnsl-1)) {
258	my $cn = $cns->[$i];
259	if ($cn eq $_[2]) {
260	$index += $i;
261	last C;
262	} elsif ($cn eq $_[1]) {
263	$index = -1; # offset
264	}
265	}
266
267	report Message::DOM::DOMException
268	-object => $self,
269	-type => 'NOT_FOUND_ERR',
270	-subtype => 'NOT_CHILD_ERR';
271	} # C
272	}
273	## NOTE: "else" only in replace_child
274
275	## -- Removes from parent
276	if ($new_child_parent) {
277	if (@new_child == 1) {
278	my $v = $$new_child_parent->{child_nodes};
279	RP: for my $i (0..$#$v) {
280	if ($v->[$i] eq $new_child[0]) {
281	splice @$v, $i, 1, ();
282	last RP;
283	}
284	} # RP
285	} else {
286	@{$$new_child_parent->{child_nodes}} = ();
287	}
288	}
289
290	## -- Rewrite the \|parentNode\| properties
291	for my $nc (@new_child) {
292	$$nc->{parent_node} = $self;
293	Scalar::Util::weaken ($$nc->{parent_node});
294	}
295
296	## NOTE: Depends on method:
297	if ($index == -1) {
298	push @{$$self->{child_nodes}}, @new_child;
299	} else {
300	splice @{$$self->{child_nodes}}, $index, 0, @new_child;
301	}
302
303	## NOTE: Setting \|owner_document\| in \|Document\|.
304
305	return $_[1];
306	} # insert_before
307
308	sub replace_child ($$) {
309	my $self = $_[0];
310
311	## NOTE: Depends on $self->node_type:
312	my $self_od = $$self->{owner_document};
313
314	## -- Node Type check
315	my @new_child;
316	my $new_child_parent;
317	if ($_[1]->node_type == 11) { # DOCUMENT_FRAGMENT_NODE
318	push @new_child, @{$_[1]->child_nodes};
319	$new_child_parent = $_[1];
320	} else {
321	@new_child = ($_[1]);
322	$new_child_parent = $_[1]->parent_node;
323	}
324
325	## NOTE: Depends on $self->node_type:
326	if ($$self_od->{strict_error_checking}) {
327	my $child_od = $_[1]->owner_document \|\| $_[1]; # might be DocumentType
328	if ($self_od ne $child_od and $child_od->node_type != 10) {
329	report Message::DOM::DOMException # DOCUMENT_TYPE_NODE
330	-object => $self,
331	-type => 'WRONG_DOCUMENT_ERR',
332	-subtype => 'EXTERNAL_OBJECT_ERR';
333	}
334
335	if ($$self->{manakai_read_only} or
336	(@new_child and defined $new_child_parent and
337	$$new_child_parent->{manakai_read_only})) {
338	report Message::DOM::DOMException
339	-object => $self,
340	-type => 'NO_MODIFICATION_ALLOWED_ERR',
341	-subtype => 'READ_ONLY_NODE_ERR';
342	}
343
344	## NOTE: \|Document\| has children order check here.
345
346	for my $cn (@new_child) {
347	unless ({
348	3, 1, 5, 1, # TEXT_NODE, ENTITY_REFERENCE_NODE
349	}->{$cn->node_type}) {
350	report Message::DOM::DOMException
351	-object => $self,
352	-type => 'HIERARCHY_REQUEST_ERR',
353	-subtype => 'CHILD_NODE_TYPE_ERR';
354	}
355	}
356
357	## NOTE: Ancestor check here in \|Node\|.
358	}
359
360	## -- Insert at... ## NOTE: Only in insertBefore and replaceChild
361	my $index = -1; # last
362	if (defined $_[2]) {
363	## error if $_[1] eq $_[2];
364
365	my $cns = $self->child_nodes;
366	my $cnsl = @$cns;
367	C: {
368	$index = 0;
369	for my $i (0..($cnsl-1)) {
370	my $cn = $cns->[$i];
371	if ($cn eq $_[2]) {
372	$index += $i;
373	last C;
374	} elsif ($cn eq $_[1]) {
375	$index = -1; # offset
376	}
377	}
378
379	report Message::DOM::DOMException
380	-object => $self,
381	-type => 'NOT_FOUND_ERR',
382	-subtype => 'NOT_CHILD_ERR';
383	} # C
384	} else {
385	## NOTE: Only in replaceChild
386	report Message::DOM::DOMException
387	-object => $self,
388	-type => 'NOT_FOUND_ERR',
389	-subtype => 'NOT_CHILD_ERR';
390	}
391
392	## -- Removes from parent
393	if ($new_child_parent) {
394	if (@new_child == 1) {
395	my $v = $$new_child_parent->{child_nodes};
396	RP: for my $i (0..$#$v) {
397	if ($v->[$i] eq $new_child[0]) {
398	splice @$v, $i, 1, ();
399	last RP;
400	}
401	} # RP
402	} else {
403	@{$$new_child_parent->{child_nodes}} = ();
404	}
405	}
406
407	## -- Rewrite the \|parentNode\| properties
408	for my $nc (@new_child) {
409	$$nc->{parent_node} = $self;
410	Scalar::Util::weaken ($$nc->{parent_node});
411	}
412
413	## NOTE: Depends on method:
414	splice @{$$self->{child_nodes}}, $index, 1, @new_child;
415	delete ${$_[2]}->{parent_node};
416
417	## NOTE: Setting \|owner_document\| in \|Document\|.
418
419	return $_[2];
420	} # replace_child
421
422	## \|Attr\| attributes
423
424	sub manakai_attribute_type ($;$) {
425	my $self = $_[0];
426	if (@_ > 1) {
427	if (${$$self->{owner_document}}->{strict_error_checking}) {
428	if ($$self->{manakai_read_only}) {
429	report Message::DOM::DOMException
430	-object => $self,
431	-type => 'NO_MODIFICATION_ALLOWED_ERR',
432	-subtype => 'READ_ONLY_NODE_ERR';
433	}
434	}
435	if ($_[1]) {
436	$$self->{manakai_attribute_type} = 0+$_[1];
437	} else {
438	delete $$self->{manakai_attribute_type};
439	}
440	}
441
442	return $$self->{manakai_attribute_type} \|\| 0;
443	} # manakai_attribute_type
444
445	sub is_id ($;$) {
446	my $self = $_[0];
447
448	if (@_ > 1) {
449	## NOTE: The setter is a manakai extension.
450	## TODO: Document.
451
452	if (${$$self->{owner_document}}->{strict_error_checking}) {
453	if ($$self->{manakai_read_only}) {
454	report Message::DOM::DOMException
455	-object => $self,
456	-type => 'NO_MODIFICATION_ALLOWED_ERR',
457	-subtype => 'READ_ONLY_NODE_ERR';
458	}
459	}
460
461	if ($_[1]) {
462	$$self->{manakai_user_determined_id} = 1;
463	} else {
464	delete $$self->{manakai_user_determined_id};
465	}
466	}
467	return unless defined wantarray;
468
469	## DTD Attribute Type
470	my $type = $$self->{manakai_attribute_type};
471	if (defined $type and $type == 2) { # ID_ATTR
472	return 1;
473	}
474
475	## User-determined ID
476	if ($$self->{manakai_user_determined_id}) {
477	return 1;
478	}
479
480	## Application-determined ID
481	my $nsuri = $self->namespace_uri;
482	my $ln = $self->manakai_local_name;
483	if (defined $nsuri) {
484	if ($ln eq 'id') {
485	if ($nsuri eq q<http://www.w3.org/XML/1998/namespace>) {
486	return 1;
487	}
488	}
489	} else {
490	if ($ln eq 'xml:id') {
491	return 1;
492	}
493
494	my $oe = $$self->{owner_element};
495	if ($oe) {
496	my $oe_nsuri = $oe->namespace_uri;
497	if (defined $oe_nsuri) {
498	if ($ln eq 'id') {
499	if ($oe_nsuri eq q<http://www.w3.org/1999/xhtml>) {
500	return 1;
501	}
502	}
503	}
504	}
505	}
506
507	return 0;
508	} # is_id
509
510	## TODO: HTML5 case stuff?
511	sub name ($) {
512	my $self = shift;
513	if (defined $$self->{prefix}) {
514	return $$self->{prefix} . ':' . $$self->{local_name};
515	} else {
516	return $$self->{local_name};
517	}
518	} # name
519
520	## TODO: Documentation
521	sub manakai_name ($) {
522	my $self = shift;
523	if (defined $$self->{prefix}) {
524	return $$self->{prefix} . ':' . $$self->{local_name};
525	} else {
526	return $$self->{local_name};
527	}
528	} # manakai_name
529
530	sub schema_type_info ($) {
531	require Message::DOM::TypeInfo;
532	my $v = ${$_[0]}->{manakai_attribute_type} \|\| 0;
533	return bless \$v, 'Message::DOM::TypeInfo';
534	} # schema_type_info
535
536	sub specified ($;$) {
537	if (@_ > 1) {
538	## NOTE: A manakai extension.
539	if (${${$_[0]}->{owner_document}}->{strict_error_checking} and
540	${$_[0]}->{manakai_read_only}) {
541	report Message::DOM::DOMException
542	-object => $_[0],
543	-type => 'NO_MODIFICATION_ALLOWED_ERR',
544	-subtype => 'READ_ONLY_NODE_ERR';
545	}
546	if ($_[1] or not defined ${$_[0]}->{owner_element}) {
547	${$_[0]}->{specified} = 1;
548	} else {
549	delete ${$_[0]}->{specified};
550	}
551	}
552	return ${$_[0]}->{specified};
553	} # specified
554
555	*value = \&node_value;
556
557	package Message::IF::Attr;
558
559	package Message::DOM::Document;
560
561	sub create_attribute ($$) {
562	if (${$_[0]}->{strict_error_checking}) {
563	my $xv = $_[0]->xml_version;
564	## TODO: HTML Document ??
565	if (defined $xv) {
566	if ($xv eq '1.0' and
567	$_[1] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
568	#
569	} elsif ($xv eq '1.1' and
570	$_[1] =~ /\A\p{InXMLNameStartChar11}\p{InXMLNameChar11}*\z/) {
571	#
572	} else {
573	report Message::DOM::DOMException
574	-object => $_[0],
575	-type => 'INVALID_CHARACTER_ERR',
576	-subtype => 'MALFORMED_NAME_ERR';
577	}
578	}
579	}
580	## TODO: HTML5
581	return Message::DOM::Attr->____new ($_[0], undef, undef, undef, $_[1]);
582	} # create_attribute
583
584	sub create_attribute_ns ($$$) {
585	my ($prefix, $lname);
586	if (ref $_[2] eq 'ARRAY') {
587	($prefix, $lname) = @{$_[2]};
588	} else {
589	($prefix, $lname) = split /:/, $_[2], 2;
590	($prefix, $lname) = (undef, $prefix) unless defined $lname;
591	}
592	my $nsuri = defined $_[1] ? $_[1] eq '' ? undef : $_[1] : undef;
593
594	if (${$_[0]}->{strict_error_checking}) {
595	my $xv = $_[0]->xml_version;
596	## TODO: HTML Document ?? (NOT_SUPPORTED_ERR is different from what Web browsers do)
597	if (defined $xv) {
598	if ($xv eq '1.0') {
599	if (ref $_[2] eq 'ARRAY' or
600	$_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
601	if (defined $prefix) {
602	if ($prefix =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) {
603	#
604	} else {
605	report Message::DOM::DOMException
606	-object => $_[0],
607	-type => 'NAMESPACE_ERR',
608	-subtype => 'MALFORMED_QNAME_ERR';
609	}
610	}
611	if ($lname =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) {
612	#
613	} else {
614	report Message::DOM::DOMException
615	-object => $_[0],
616	-type => 'NAMESPACE_ERR',
617	-subtype => 'MALFORMED_QNAME_ERR';
618	}
619	} else {
620	report Message::DOM::DOMException
621	-object => $_[0],
622	-type => 'INVALID_CHARACTER_ERR',
623	-subtype => 'MALFORMED_NAME_ERR';
624	}
625	} elsif ($xv eq '1.1') {
626	if (ref $_[2] eq 'ARRAY' or
627	$_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
628	if (defined $prefix) {
629	if ($prefix =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) {
630	#
631	} else {
632	report Message::DOM::DOMException
633	-object => $_[0],
634	-type => 'NAMESPACE_ERR',
635	-subtype => 'MALFORMED_QNAME_ERR';
636	}
637	}
638	if ($lname =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) {
639	#
640	} else {
641	report Message::DOM::DOMException
642	-object => $_[0],
643	-type => 'NAMESPACE_ERR',
644	-subtype => 'MALFORMED_QNAME_ERR';
645	}
646	} else {
647	report Message::DOM::DOMException
648	-object => $_[0],
649	-type => 'INVALID_CHARACTER_ERR',
650	-subtype => 'MALFORMED_NAME_ERR';
651	}
652	} else {
653	die "create_attribute_ns: XML version \|$xv\| is not supported";
654	}
655	}
656
657	if (defined $prefix) {
658	if (not defined $nsuri) {
659	report Message::DOM::DOMException
660	-object => $_[0],
661	-type => 'NAMESPACE_ERR',
662	-subtype => 'PREFIXED_NULLNS_ERR';
663	} elsif ($prefix eq 'xml' and
664	$nsuri ne q<http://www.w3.org/XML/1998/namespace>) {
665	report Message::DOM::DOMException
666	-object => $_[0],
667	-type => 'NAMESPACE_ERR',
668	-subtype => 'XMLPREFIX_NONXMLNS_ERR';
669	} elsif ($prefix eq 'xmlns' and
670	$nsuri ne q<http://www.w3.org/2000/xmlns/>) {
671	report Message::DOM::DOMException
672	-object => $_[0],
673	-type => 'NAMESPACE_ERR',
674	-subtype => 'XMLNSPREFIX_NONXMLNSNS_ERR';
675	} elsif ($nsuri eq q<http://www.w3.org/2000/xmlns/> and
676	$prefix ne 'xmlns') {
677	report Message::DOM::DOMException
678	-object => $_[0],
679	-type => 'NAMESPACE_ERR',
680	-subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR';
681	}
682	} else { # no prefix
683	if ($lname eq 'xmlns' and
684	(not defined $nsuri or $nsuri ne q<http://www.w3.org/2000/xmlns/>)) {
685	report Message::DOM::DOMException
686	-object => $_[0],
687	-type => 'NAMESPACE_ERR',
688	-subtype => 'XMLNS_NONXMLNSNS_ERR';
689	} elsif (not defined $nsuri) {
690	#
691	} elsif ($nsuri eq q<http://www.w3.org/2000/xmlns/> and
692	$lname ne 'xmlns') {
693	report Message::DOM::DOMException
694	-object => $_[0],
695	-type => 'NAMESPACE_ERR',
696	-subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR';
697	}
698	}
699	}
700
701	## TODO: Older version of manakai set \|attribute_type\|
702	## attribute for \|xml:id\| attribute. Should we support this?
703
704	return Message::DOM::Attr->____new ($_[0], undef, $nsuri, $prefix, $lname);
705	} # create_attribute_ns
706
707	=head1 LICENSE
708
709	Copyright 2007 Wakaba <w@suika.fam.cx>
710
711	This program is free software; you can redistribute it and/or
712	modify it under the same terms as Perl itself.
713
714	=cut
715
716	1;
717	## $Date: 2007/07/08 13:04:36 $