Message/DOM/NamedNodeMap.pm

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

use overload
    '@{}' => sub {
      tie my @list, (ref $_[0]) . '::Array', $_[0];
      return \@list;
    },
    '%{}' => sub {
      tie my %list, ref $_[0], $_[0];
      return \%list;
    },
    eq => sub {
      return 0 unless UNIVERSAL::isa ($_[1], 'Message::DOM::NamedNodeMap');
      return 0 if $_[1]->isa ('Message::DOM::NamedNodeMap::ArrayMap');
      return (${$_[0]}->[0] eq ${$_[1]}->[0] and ${$_[0]}->[1] eq ${$_[1]}->[1]);
    },
    ne => sub {
      return not ($_[0] eq $_[1]);
    },
    '==' => sub {
      return 0 unless UNIVERSAL::isa ($_[1], 'Message::IF::NamedNodeMap');
      
      local $Error::Depth = $Error::Depth + 1;
      my $length1 = @{$_[0]};
      my $length2 = @{$_[1]};
      return 0 if $length1 != $length2;

      for my $i (0..($length1 - 1)) {
        my $node1 = $_[0]->[$i];
        my $node2 = $_[1]->[$i];
        return 0 if $node1 != $node2;
      }
      ## TODO: This ordering is only assumed in manakai...

      return 1;
    },
    '!=' => sub {
      return not ($_[0] == $_[1]);
    },
    fallback => 1;

sub ___report_error ($$) {
  $_[1]->throw;
} # ___report_error

sub TIEHASH ($$) { $_[1] }

## |NamedNodeMap| attributes

sub length ($) {
  return scalar @{[map {$_} values %{${${$_[0]}->[0]}->{${$_[0]}->[1]}}]};
} # length

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

## |NamedNodeMap| methods

sub get_named_item ($$) {
  return ${${$_[0]}->[0]}->{${$_[0]}->[1]}->{$_[1]};
} # get_named_item
*FETCH = \&get_named_item;

sub get_named_item_ns ($$$) { }

sub item ($$) {
  my $index = 0+$_[1];
  my $list = ${${$_[0]}->[0]}->{${$_[0]}->[1]};

  my $key = $index >= 0 ? [sort {$a cmp $b} keys %$list]->[$index] : undef;
  if (defined $key and defined $list->{$key}) {
    return $list->{$key};
  } else {
    return undef;
  }
} # item

sub remove_named_item ($$) {
  my $name = ''.$_[1];
  my $list = ${${$_[0]}->[0]}->{${$_[0]}->[1]};

  my $od = ${${$_[0]}->[0]}->{owner_document}; # might be undef, but no problem

  my $key = ${$_[0]}->[1] eq 'attribute_definitions'
      ? 'owner_element_type_definition' : 'owner_document_type_definition';

  if ($$od->{strict_error_checking}) {
    if (${${$_[0]}->[0]}->{manakai_read_only}) {
      report Message::DOM::DOMException
          -object => $_[0],
          -type => 'NO_MODIFICATION_ALLOWED_ERR',
          -subtype => 'READ_ONLY_NODE_ERR';
    }
  }

  if (defined $list->{$name}) {
    my $r = $list->{$name};
    delete $$r->{$key};
    delete $list->{$name};
    return $r;
  } else {
    report Message::DOM::DOMException
        -object => $_[0],
        -type => 'NOT_FOUND_ERR',
        -subtype => 'NOT_CHILD_ERR';
  }
} # remove_named_item

sub remove_named_item_ns ($$) {
  report Message::DOM::DOMException
      -object => $_[0],
      -type => 'NOT_FOUND_ERR',
      -subtype => 'NOT_CHILD_ERR';
} # remove_named_item_ns

sub DELETE ($$) {
  my $r;
  try {
    $r = $_[0]->remove_named_item ($_[1]);
  } catch Message::DOM::DOMException with {
    my $err = shift;
    unless ($err->subtype eq 'NOT_CHILD_ERR') {
      $err->throw;
    }
  };
  return $r; ## TODO: This return value is ok?
} # DELETE

sub set_named_item ($$) {
  my $od = ${${$_[0]}->[0]}->{owner_document};
  if (not defined $od or
      $od ne ($_[1]->owner_document || $_[1])) {
    ## TODO: $od not defined case is manakai extension.  Document it!
    report Message::DOM::DOMException
        -object => $_[0],
        -type => 'WRONG_DOCUMENT_ERR',
        -subtype => 'EXTERNAL_OBJECT_ERR';
  }

  my $key = ${$_[0]}->[1] eq 'attribute_definitions'
      ? 'owner_element_type_definition' : 'owner_document_type_definition';

  if ($$od->{strict_error_checking}) {
    if ($_[1]->node_type !=
        {
         element_types => 81001, # ELEMENT_TYPE_DEFINITION_NODE
         attribute_definitions => 81002, # ATTRIBUTE_DEFINITION_NODE
         entities => 6, # ENTITY_NODE
         notations => 12, # NOTATION_NODE
        }->{${$_[0]}->[1]}) {
      report Message::DOM::DOMException
          -object => $_[0],
          -type => 'HIERARCHY_REQUEST_ERR',
          -subtype => 'CHILD_NODE_TYPE_ERR';
    }

    if (${${$_[0]}->[0]}->{manakai_read_only}) {
      report Message::DOM::DOMException
          -object => $_[0],
          -type => 'NO_MODIFICATION_ALLOWED_ERR',
          -subtype => 'READ_ONLY_NODE_ERR';
    }

    if (${$_[1]}->{$key} and not ${$_[1]}->{$key} eq ${$_[0]}->[0]) {
      ## TODO: This is manakai extension.  Document it!
      report Message::DOM::DOMException
          -object => $_[0],
          -type => 'HIERARCHY_REQUEST_ERR',
          -subtype => 'INUSE_DEFINITION_ERR';
    }
  }

  my $name = $_[1]->node_name;
  my $list = ${${$_[0]}->[0]}->{${$_[0]}->[1]};
  if (defined $list->{$name}) {
    my $r = $list->{$name};
    if ($r eq $_[1]) {
      ## NOTE: Replace by itself (implementation dependent).
      return undef;
    } else {
      $list->{$name} = $_[1];
      ${$_[1]}->{$key} = ${$_[0]}->[0];
      Scalar::Util::weaken (${$_[1]}->{$key});
      delete $$r->{$key};
      return $r;
    }
  } else {
    $list->{$name} = $_[1];
    ${$_[1]}->{$key} = ${$_[0]}->[0];
    Scalar::Util::weaken (${$_[1]}->{$key});
    return undef;
  }
} # set_named_item

sub set_named_item_ns ($$) {
  report Message::DOM::DOMException
      -object => $_[0],
      -type => 'HIERARCHY_REQUEST_ERR',
      -subtype => 'CHILD_NODE_TYPE_ERR';
} # set_named_item_ns

sub EXISTS ($$) {
  return exists ${${$_[0]}->[0]}->{${$_[0]}->[1]}->{$_[1]};
} # EXISTS

sub FIRSTKEY ($) {
  my $list = ${${$_[0]}->[0]}->{${$_[0]}->[1]};
  my $a = keys %$list; # reset
  return each %$list;
} # FIRSTKEY

sub NEXTKEY ($) {
  return each %{${${$_[0]}->[0]}->{${$_[0]}->[1]}};
} # NEXTKEY

sub SCALAR ($) {
  return scalar %{${${$_[0]}->[0]}->{${$_[0]}->[1]}};
} # SCALAR

package Message::DOM::NamedNodeMap::Array;
push our @ISA, 'Tie::Array';

sub DELETE ($$) {
  my $item = $_[0]->item ($_[1]);
  if ($item) {
    local $Error::Depth = $Error::Depth + 1;
    return $_[0]->remove_named_item ($item->node_name);
  } else {
    return undef;
  }
} # DELETE

sub EXISTS ($$) {
  return ($_[1] < $_[0]->length);
} # EXISTS

*FETCH = \&Message::DOM::NamedNodeMap::item;

*FETCHSIZE = \&Message::DOM::NamedNodeMap::length;

## TODO: |STORE|

sub STORESIZE ($) {
  local $Error::Depth = $Error::Depth + 1;
  my $length = $_[0]->length;
  if ($length > $_[1]) {
    for (my $i = $length - 1; $i >= $_[1]; $i--) {
      my $item = $_[0]->item ($i);
      $_[0]->remove_named_item ($item->node_name);
    }
  }
} # STORESIZE

sub TIEARRAY ($$) { bless \[${$_[1]}->[0], ${$_[1]}->[1]], __PACKAGE__ }

package Message::DOM::NamedNodeMap::AttrMap;
push our @ISA, 'Message::DOM::NamedNodeMap';

use overload
    eq => sub {
      return 0 unless UNIVERSAL::isa ($_[1], 'Message::DOM::NamedNodeMap');
      return $${$_[0]} eq $${$_[1]};
    },
    fallback => 1;

sub TIEHASH ($$) { $_[1] }

## |NamedNodeMap| attributes

sub length ($) {
  my $list = ${$${$_[0]}}->{manakai_content_attribute_list};
  if (defined $list) {
    return scalar @$list;
  } else {
    $list = ${$${$_[0]}}->{attributes};
    my $r = 0;
    for my $l (values %$list) {
      $r += grep {$l->{$_}} keys %$l;
    }
    return $r;
  }
} # length

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

## |NamedNodeMap| methods

sub get_named_item ($$) {
  local $Error::Depth = $Error::Depth + 1;
  return $${$_[0]}->get_attribute_node ($_[1]);
} # get_named_item
*FETCH = \&get_named_item;

sub get_named_item_ns ($$$) {
  local $Error::Depth = $Error::Depth + 1;
  return $${$_[0]}->get_attribute_node_ns ($_[1], $_[2]);
} # get_named_item_ns

sub item ($$) {
  ## Update the sorted content attribute name list
  my $list = ${$${$_[0]}}->{manakai_content_attribute_list};
  my $attrs = ${$${$_[0]}}->{attributes};
  unless (defined $list) {
    $list = [];
    for my $ns (sort {$a cmp $b} keys %{$attrs}) {
      push @$list, map {[$ns => $_]} sort {$a cmp $b} keys %{$attrs->{$ns}};
    }
    ${$${$_[0]}}->{manakai_content_attribute_list} = $list;
  }

  my $index = 0+$_[1];
  return $attrs->{$list->[$index]->[0]}->{$list->[$index]->[1]};
} # item

sub remove_named_item ($$) {
  my $el = $${$_[0]};
  local $Error::Depth = $Error::Depth + 1;
  my $node = $el->get_attribute_node ($_[1]);
  unless ($node) {
    local $Error::Depth = $Error::Depth - 1;
    report Message::DOM::DOMException
        -object => $_[0],
        -type => 'NOT_FOUND_ERR',
        -subtype => 'NOT_CHILD_ERR';
  }
  return $el->remove_attribute_node ($node);
} # remove_named_item

sub remove_named_item_ns ($$) {
  my $el = $${$_[0]};
  local $Error::Depth = $Error::Depth + 1;
  my $node = $el->get_attribute_node_ns ($_[1], $_[2]);
  unless ($node) {
    local $Error::Depth = $Error::Depth - 1;
    report Message::DOM::DOMException
        -object => $_[0],
        -type => 'NOT_FOUND_ERR',
        -subtype => 'NOT_CHILD_ERR';
  }
  return $el->remove_attribute_node ($node);
} # remove_named_item_ns

sub set_named_item ($$) {
  if ($_[1]->node_type != 2) { # ATTRIBUTE_NODE
    report Message::DOM::DOMException
        -object => $_[0],
        -type => 'HIERARCHY_REQUEST_ERR',
        -subtype => 'CHILD_NODE_TYPE_ERR';
  }

  local $Error::Depth = $Error::Depth + 1;
  return $${$_[0]}->set_attribute_node ($_[1]);
} # set_named_item

sub set_named_item_ns ($$) {
  if ($_[1]->node_type != 2) { # ATTRIBUTE_NODE
    report Message::DOM::DOMException
        -object => $_[0],
        -type => 'HIERARCHY_REQUEST_ERR',
        -subtype => 'CHILD_NODE_TYPE_ERR';
  }

  local $Error::Depth = $Error::Depth + 1;
  return $${$_[0]}->set_attribute_node_ns ($_[1]);
} # set_named_item_ns

sub EXISTS ($$) {
  local $Error::Depth = $Error::Depth + 1;
  return defined ($_[0]->get_named_item ($_[1]));
} # EXISTS

sub FIRSTKEY ($) {
  local $Error::Depth = $Error::Depth + 1;
  my $node = $_[0]->item (0);
  ${$${$_[0]}}->{manakai_hash_position} = 1;
  return $node ? $node->node_name : undef;
} # FIRSTKEY

sub NEXTKEY ($) {
  my $i = ${$${$_[0]}}->{manakai_hash_position}++;
  my $node = $_[0]->item ($i);
  return $node ? $node->node_name : undef;
} # NEXTKEY

sub SCALAR ($) {
  local $Error::Depth = $Error::Depth + 1;
  return $${$_[0]}->has_attributes;
} # SCALAR

package Message::DOM::NamedNodeMap::AttrMap::Array;
push our @ISA, 'Tie::Array';

sub DELETE ($$) {
  my $item = $_[0]->item ($_[1]);
  if ($item) {
    local $Error::Depth = $Error::Depth + 1;
    return $_[0]->remove_named_item_ns
        ($item->namespace_uri, $item->manakai_local_name);
  } else {
    return undef;
  }
} # DELETE

sub EXISTS ($$) {
  return ($_[1] < $_[0]->length);
} # EXISTS

*FETCH = \&Message::DOM::NamedNodeMap::AttrMap::item;

*FETCHSIZE = \&Message::DOM::NamedNodeMap::AttrMap::length;

sub STORESIZE ($) {
  local $Error::Depth = $Error::Depth + 1;
  my $length = $_[0]->length;
  if ($length > $_[1]) {
    for (my $i = $length - 1; $i >= $_[1]; $i--) {
      my $item = $_[0]->item ($i);
      $_[0]->remove_named_item_ns
          ($item->namespace_uri, $item->manakai_local_name);
    }
  }
} # STORESIZE

sub TIEARRAY ($$) { bless \\$${$_[1]}, __PACKAGE__ }

package Message::IF::NamedNodeMap;

=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 07:59:02 $
1	wakaba	1.1	package Message::DOM::NamedNodeMap;
2			use strict;
3	wakaba	1.2	our $VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4	wakaba	1.1	push our @ISA, 'Message::IF::NamedNodeMap';
5			require Message::DOM::DOMException;
6			require Tie::Array;
7
8			use overload
9			'@{}' => sub {
10			tie my @list, (ref $_[0]) . '::Array', $_[0];
11			return \@list;
12			},
13			'%{}' => sub {
14			tie my %list, ref $_[0], $_[0];
15			return \%list;
16			},
17			eq => sub {
18			return 0 unless UNIVERSAL::isa ($_[1], 'Message::DOM::NamedNodeMap');
19			return 0 if $_[1]->isa ('Message::DOM::NamedNodeMap::ArrayMap');
20			return (${$_[0]}->[0] eq ${$_[1]}->[0] and ${$_[0]}->[1] eq ${$_[1]}->[1]);
21			},
22			ne => sub {
23			return not ($_[0] eq $_[1]);
24			},
25			'==' => sub {
26			return 0 unless UNIVERSAL::isa ($_[1], 'Message::IF::NamedNodeMap');
27
28			local $Error::Depth = $Error::Depth + 1;
29			my $length1 = @{$_[0]};
30			my $length2 = @{$_[1]};
31			return 0 if $length1 != $length2;
32
33			for my $i (0..($length1 - 1)) {
34			my $node1 = $_[0]->[$i];
35			my $node2 = $_[1]->[$i];
36			return 0 if $node1 != $node2;
37			}
38			## TODO: This ordering is only assumed in manakai...
39
40			return 1;
41			},
42			'!=' => sub {
43			return not ($_[0] == $_[1]);
44			},
45			fallback => 1;
46
47			sub ___report_error ($$) {
48			$_[1]->throw;
49			} # ___report_error
50
51	wakaba	1.2	sub TIEHASH ($$) { $_[1] }
52
53	wakaba	1.1	## \|NamedNodeMap\| attributes
54
55			sub length ($) {
56			return scalar @{[map {$_} values %{${${$_[0]}->[0]}->{${$_[0]}->[1]}}]};
57			} # length
58
59			sub manakai_read_only ($) {
60			return ${${$_[0]}->[0]}->{manakai_read_only};
61			} # manakai_read_only
62
63			## \|NamedNodeMap\| methods
64
65			sub get_named_item ($$) {
66			return ${${$_[0]}->[0]}->{${$_[0]}->[1]}->{$_[1]};
67			} # get_named_item
68			*FETCH = \&get_named_item;
69
70			sub get_named_item_ns ($$$) { }
71
72			sub item ($$) {
73			my $index = 0+$_[1];
74			my $list = ${${$_[0]}->[0]}->{${$_[0]}->[1]};
75
76			my $key = $index >= 0 ? [sort {$a cmp $b} keys %$list]->[$index] : undef;
77			if (defined $key and defined $list->{$key}) {
78			return $list->{$key};
79			} else {
80			return undef;
81			}
82			} # item
83
84			sub remove_named_item ($$) {
85			my $name = ''.$_[1];
86			my $list = ${${$_[0]}->[0]}->{${$_[0]}->[1]};
87
88			my $od = ${${$_[0]}->[0]}->{owner_document}; # might be undef, but no problem
89
90			my $key = ${$_[0]}->[1] eq 'attribute_definitions'
91			? 'owner_element_type_definition' : 'owner_document_type_definition';
92
93			if ($$od->{strict_error_checking}) {
94			if (${${$_[0]}->[0]}->{manakai_read_only}) {
95			report Message::DOM::DOMException
96			-object => $_[0],
97			-type => 'NO_MODIFICATION_ALLOWED_ERR',
98			-subtype => 'READ_ONLY_NODE_ERR';
99			}
100			}
101
102			if (defined $list->{$name}) {
103			my $r = $list->{$name};
104			delete $$r->{$key};
105			delete $list->{$name};
106			return $r;
107			} else {
108			report Message::DOM::DOMException
109			-object => $_[0],
110			-type => 'NOT_FOUND_ERR',
111			-subtype => 'NOT_CHILD_ERR';
112			}
113			} # remove_named_item
114
115			sub remove_named_item_ns ($$) {
116			report Message::DOM::DOMException
117			-object => $_[0],
118			-type => 'NOT_FOUND_ERR',
119			-subtype => 'NOT_CHILD_ERR';
120			} # remove_named_item_ns
121
122			sub DELETE ($$) {
123			my $r;
124			try {
125			$r = $_[0]->remove_named_item ($_[1]);
126			} catch Message::DOM::DOMException with {
127			my $err = shift;
128			unless ($err->subtype eq 'NOT_CHILD_ERR') {
129			$err->throw;
130			}
131			};
132			return $r; ## TODO: This return value is ok?
133			} # DELETE
134
135			sub set_named_item ($$) {
136			my $od = ${${$_[0]}->[0]}->{owner_document};
137			if (not defined $od or
138			$od ne ($_[1]->owner_document \|\| $_[1])) {
139			## TODO: $od not defined case is manakai extension. Document it!
140			report Message::DOM::DOMException
141			-object => $_[0],
142			-type => 'WRONG_DOCUMENT_ERR',
143			-subtype => 'EXTERNAL_OBJECT_ERR';
144			}
145
146			my $key = ${$_[0]}->[1] eq 'attribute_definitions'
147			? 'owner_element_type_definition' : 'owner_document_type_definition';
148
149			if ($$od->{strict_error_checking}) {
150			if ($_[1]->node_type !=
151			{
152			element_types => 81001, # ELEMENT_TYPE_DEFINITION_NODE
153			attribute_definitions => 81002, # ATTRIBUTE_DEFINITION_NODE
154			entities => 6, # ENTITY_NODE
155			notations => 12, # NOTATION_NODE
156			}->{${$_[0]}->[1]}) {
157			report Message::DOM::DOMException
158			-object => $_[0],
159			-type => 'HIERARCHY_REQUEST_ERR',
160			-subtype => 'CHILD_NODE_TYPE_ERR';
161			}
162
163			if (${${$_[0]}->[0]}->{manakai_read_only}) {
164			report Message::DOM::DOMException
165			-object => $_[0],
166			-type => 'NO_MODIFICATION_ALLOWED_ERR',
167			-subtype => 'READ_ONLY_NODE_ERR';
168			}
169
170			if (${$_[1]}->{$key} and not ${$_[1]}->{$key} eq ${$_[0]}->[0]) {
171			## TODO: This is manakai extension. Document it!
172			report Message::DOM::DOMException
173			-object => $_[0],
174			-type => 'HIERARCHY_REQUEST_ERR',
175			-subtype => 'INUSE_DEFINITION_ERR';
176			}
177			}
178
179			my $name = $_[1]->node_name;
180			my $list = ${${$_[0]}->[0]}->{${$_[0]}->[1]};
181			if (defined $list->{$name}) {
182			my $r = $list->{$name};
183			if ($r eq $_[1]) {
184			## NOTE: Replace by itself (implementation dependent).
185			return undef;
186			} else {
187			$list->{$name} = $_[1];
188			${$_[1]}->{$key} = ${$_[0]}->[0];
189			Scalar::Util::weaken (${$_[1]}->{$key});
190			delete $$r->{$key};
191			return $r;
192			}
193			} else {
194			$list->{$name} = $_[1];
195			${$_[1]}->{$key} = ${$_[0]}->[0];
196			Scalar::Util::weaken (${$_[1]}->{$key});
197			return undef;
198			}
199			} # set_named_item
200
201			sub set_named_item_ns ($$) {
202			report Message::DOM::DOMException
203			-object => $_[0],
204			-type => 'HIERARCHY_REQUEST_ERR',
205			-subtype => 'CHILD_NODE_TYPE_ERR';
206			} # set_named_item_ns
207
208			sub EXISTS ($$) {
209			return exists ${${$_[0]}->[0]}->{${$_[0]}->[1]}->{$_[1]};
210			} # EXISTS
211
212			sub FIRSTKEY ($) {
213			my $list = ${${$_[0]}->[0]}->{${$_[0]}->[1]};
214			my $a = keys %$list; # reset
215			return each %$list;
216			} # FIRSTKEY
217
218			sub NEXTKEY ($) {
219			return each %{${${$_[0]}->[0]}->{${$_[0]}->[1]}};
220			} # NEXTKEY
221
222			sub SCALAR ($) {
223			return scalar %{${${$_[0]}->[0]}->{${$_[0]}->[1]}};
224			} # SCALAR
225
226			package Message::DOM::NamedNodeMap::Array;
227			push our @ISA, 'Tie::Array';
228
229			sub DELETE ($$) {
230			my $item = $_[0]->item ($_[1]);
231			if ($item) {
232			local $Error::Depth = $Error::Depth + 1;
233			return $_[0]->remove_named_item ($item->node_name);
234			} else {
235			return undef;
236			}
237			} # DELETE
238
239			sub EXISTS ($$) {
240			return ($_[1] < $_[0]->length);
241			} # EXISTS
242
243			*FETCH = \&Message::DOM::NamedNodeMap::item;
244
245			*FETCHSIZE = \&Message::DOM::NamedNodeMap::length;
246
247			## TODO: \|STORE\|
248
249			sub STORESIZE ($) {
250			local $Error::Depth = $Error::Depth + 1;
251			my $length = $_[0]->length;
252			if ($length > $_[1]) {
253			for (my $i = $length - 1; $i >= $_[1]; $i--) {
254			my $item = $_[0]->item ($i);
255			$_[0]->remove_named_item ($item->node_name);
256			}
257			}
258			} # STORESIZE
259
260			sub TIEARRAY ($$) { bless \[${$_[1]}->[0], ${$_[1]}->[1]], __PACKAGE__ }
261
262			package Message::DOM::NamedNodeMap::AttrMap;
263			push our @ISA, 'Message::DOM::NamedNodeMap';
264
265			use overload
266			eq => sub {
267			return 0 unless UNIVERSAL::isa ($_[1], 'Message::DOM::NamedNodeMap');
268			return $${$_[0]} eq $${$_[1]};
269			},
270			fallback => 1;
271
272	wakaba	1.2	sub TIEHASH ($$) { $_[1] }
273
274	wakaba	1.1	## \|NamedNodeMap\| attributes
275
276			sub length ($) {
277			my $list = ${$${$_[0]}}->{manakai_content_attribute_list};
278			if (defined $list) {
279			return scalar @$list;
280			} else {
281			$list = ${$${$_[0]}}->{attributes};
282			my $r = 0;
283			for my $l (values %$list) {
284			$r += grep {$l->{$_}} keys %$l;
285			}
286			return $r;
287			}
288			} # length
289
290			sub manakai_read_only ($) {
291			return ${$${$_[0]}}->{manakai_read_only};
292			} # manakai_read_only
293
294			## \|NamedNodeMap\| methods
295
296			sub get_named_item ($$) {
297			local $Error::Depth = $Error::Depth + 1;
298			return $${$_[0]}->get_attribute_node ($_[1]);
299			} # get_named_item
300			*FETCH = \&get_named_item;
301
302			sub get_named_item_ns ($$$) {
303			local $Error::Depth = $Error::Depth + 1;
304			return $${$_[0]}->get_attribute_node_ns ($_[1], $_[2]);
305			} # get_named_item_ns
306
307			sub item ($$) {
308			## Update the sorted content attribute name list
309			my $list = ${$${$_[0]}}->{manakai_content_attribute_list};
310			my $attrs = ${$${$_[0]}}->{attributes};
311			unless (defined $list) {
312			$list = [];
313			for my $ns (sort {$a cmp $b} keys %{$attrs}) {
314			push @$list, map {[$ns => $_]} sort {$a cmp $b} keys %{$attrs->{$ns}};
315			}
316			${$${$_[0]}}->{manakai_content_attribute_list} = $list;
317			}
318
319			my $index = 0+$_[1];
320			return $attrs->{$list->[$index]->[0]}->{$list->[$index]->[1]};
321			} # item
322
323			sub remove_named_item ($$) {
324			my $el = $${$_[0]};
325			local $Error::Depth = $Error::Depth + 1;
326			my $node = $el->get_attribute_node ($_[1]);
327			unless ($node) {
328			local $Error::Depth = $Error::Depth - 1;
329			report Message::DOM::DOMException
330			-object => $_[0],
331			-type => 'NOT_FOUND_ERR',
332			-subtype => 'NOT_CHILD_ERR';
333			}
334			return $el->remove_attribute_node ($node);
335			} # remove_named_item
336
337			sub remove_named_item_ns ($$) {
338			my $el = $${$_[0]};
339			local $Error::Depth = $Error::Depth + 1;
340			my $node = $el->get_attribute_node_ns ($_[1], $_[2]);
341			unless ($node) {
342			local $Error::Depth = $Error::Depth - 1;
343			report Message::DOM::DOMException
344			-object => $_[0],
345			-type => 'NOT_FOUND_ERR',
346			-subtype => 'NOT_CHILD_ERR';
347			}
348			return $el->remove_attribute_node ($node);
349			} # remove_named_item_ns
350
351			sub set_named_item ($$) {
352			if ($_[1]->node_type != 2) { # ATTRIBUTE_NODE
353			report Message::DOM::DOMException
354			-object => $_[0],
355			-type => 'HIERARCHY_REQUEST_ERR',
356			-subtype => 'CHILD_NODE_TYPE_ERR';
357			}
358
359			local $Error::Depth = $Error::Depth + 1;
360			return $${$_[0]}->set_attribute_node ($_[1]);
361			} # set_named_item
362
363			sub set_named_item_ns ($$) {
364			if ($_[1]->node_type != 2) { # ATTRIBUTE_NODE
365			report Message::DOM::DOMException
366			-object => $_[0],
367			-type => 'HIERARCHY_REQUEST_ERR',
368			-subtype => 'CHILD_NODE_TYPE_ERR';
369			}
370
371			local $Error::Depth = $Error::Depth + 1;
372			return $${$_[0]}->set_attribute_node_ns ($_[1]);
373			} # set_named_item_ns
374
375			sub EXISTS ($$) {
376			local $Error::Depth = $Error::Depth + 1;
377			return defined ($_[0]->get_named_item ($_[1]));
378			} # EXISTS
379
380			sub FIRSTKEY ($) {
381			local $Error::Depth = $Error::Depth + 1;
382			my $node = $_[0]->item (0);
383			${$${$_[0]}}->{manakai_hash_position} = 1;
384			return $node ? $node->node_name : undef;
385			} # FIRSTKEY
386
387			sub NEXTKEY ($) {
388			my $i = ${$${$_[0]}}->{manakai_hash_position}++;
389			my $node = $_[0]->item ($i);
390			return $node ? $node->node_name : undef;
391			} # NEXTKEY
392
393			sub SCALAR ($) {
394			local $Error::Depth = $Error::Depth + 1;
395			return $${$_[0]}->has_attributes;
396			} # SCALAR
397
398			package Message::DOM::NamedNodeMap::AttrMap::Array;
399			push our @ISA, 'Tie::Array';
400
401			sub DELETE ($$) {
402			my $item = $_[0]->item ($_[1]);
403			if ($item) {
404			local $Error::Depth = $Error::Depth + 1;
405			return $_[0]->remove_named_item_ns
406			($item->namespace_uri, $item->manakai_local_name);
407			} else {
408			return undef;
409			}
410			} # DELETE
411
412			sub EXISTS ($$) {
413			return ($_[1] < $_[0]->length);
414			} # EXISTS
415
416			*FETCH = \&Message::DOM::NamedNodeMap::AttrMap::item;
417
418			*FETCHSIZE = \&Message::DOM::NamedNodeMap::AttrMap::length;
419
420			sub STORESIZE ($) {
421			local $Error::Depth = $Error::Depth + 1;
422			my $length = $_[0]->length;
423			if ($length > $_[1]) {
424			for (my $i = $length - 1; $i >= $_[1]; $i--) {
425			my $item = $_[0]->item ($i);
426			$_[0]->remove_named_item_ns
427			($item->namespace_uri, $item->manakai_local_name);
428			}
429			}
430			} # STORESIZE
431
432			sub TIEARRAY ($$) { bless \\$${$_[1]}, __PACKAGE__ }
433
434			package Message::IF::NamedNodeMap;
435
436			=head1 LICENSE
437
438			Copyright 2007 Wakaba <w@suika.fam.cx>
439
440			This program is free software; you can redistribute it and/or
441			modify it under the same terms as Perl itself.
442
443			=cut
444
445			1;
446	wakaba	1.2	## $Date: 2007/07/08 07:59:02 $