Message/DOM/Attr.pm

package Message::DOM::Attr;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.10 $=~/\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

## |AttributeDefinition| constants

## |DeclaredValueType|
sub NO_TYPE_ATTR () { 0 }
sub CDATA_ATTR () { 1 }
sub ID_ATTR () { 2 }
sub IDREF_ATTR () { 3 }
sub IDREFS_ATTR () { 4 }
sub ENTITY_ATTR () { 5 }
sub ENTITIES_ATTR () { 6 }
sub NMTOKEN_ATTR () { 7 }
sub NMTOKENS_ATTR () { 8 }
sub NOTATION_ATTR () { 9 }
sub ENUMERATION_ATTR () { 10 }
sub UNKNOWN_ATTR () { 11 }

## |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 owner_element ($);

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