Message/DOM/Attr.pm

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

## The name of the attribute [DOM1, DOM2].
## Same as |Attr.name| [DOM3].

*node_name = \&name;

sub node_type () { 2 } # ATTRIBUTE_NODE

## The value of the attribute [DOM1, DOM2].
## Same as |Attr.value| [DOM3].

*node_value = \&value;

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

## 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

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

sub value ($;$) {
  ## TODO:
  shift->text_content (@_);
} # 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;
  }

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