Message/DOM/NodeList.pm

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

use overload
    '@{}' => sub {
      tie my @list, ref $_[0], $_[0];
      return \@list;
    },
    eq => sub {
      return 0 unless UNIVERSAL::isa ($_[1], 'Message::DOM::NodeList');
      return $${$_[0]} eq $${$_[1]};
    },
    ne => sub {
      return not ($_[0] eq $_[1]);
    },
    '==' => sub {
      return 0 unless UNIVERSAL::isa ($_[1], 'Message::IF::NodeList');
      
      local $Error::Depth = $Error::Depth + 1;
      my $l1 = $_[0]->length;
      my $l2 = $_[1]->length;
      return 0 unless $l1 == $l2;
      
      for my $i (0 .. ($l1-1)) {
        return 0 unless $_[0]->item ($i) == $_[1]->item ($i);
      }
      
      return 1;
    },
    '!=' => sub {
      return not ($_[0] == $_[1]);
    },
    fallback => 1;

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

package Message::DOM::NodeList::ChildNodeList;
push our @ISA, 'Message::DOM::NodeList';

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

## |NodeList| attributes

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

sub length ($) {
  return scalar @{${$${$_[0]}}->{child_nodes}};
} # length

*FETCHSIZE = \&length;

sub STORESIZE ($$) {
  my $node = $${$_[0]};
  my $list = $$node->{child_nodes};
  my $current_length = @{$list};
  my $count = $_[1];

  local $Error::Depth = $Error::Depth + 1;
  if ($current_length > $count) {
    for (my $i = $current_length - 1; $i >= $count; $i--) {
      $node->remove_child ($list->[$i]);
    }
  }
} # STORESIZE

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

## |NodeList| methods

sub item ($$) {
  my $index = 0+$_[1];
  return undef if $index < 0;
  return ${$${$_[0]}}->{child_nodes}->[$index];
} # item

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

sub STORE ($$$) {
  my $self = $_[0];
  my $list = ${$$$self}->{child_nodes};
  my $index = $_[1];
           
  local $Error::Depth = $Error::Depth + 1;
  if (exists $list->[$index]) {
    $$$self->replace_child ($_[2], $list->[$index]);
    ## ISSUE: This might not work if new_child is a sibling of ref_child
  } else {
    $$$self->append_child ($_[2]);
  }
} # STORE

sub DELETE ($$) {
  my $self = $_[0];
  my $list = ${$$$self}->{child_nodes};
  my $index = $_[1];

  if (exists $list->[$index]) {
    local $Error::Depth = $Error::Depth + 1;
    return $$$self->remove_child ($list->[$index]);
  } else {
    return undef;
  }
} # DELETE

sub CLEAR ($) {
  my $self = $_[0];
  my $list = ${$$$self}->{child_nodes};

  local $Error::Depth = $Error::Depth + 1;
  for (my @a = @$list) {
    $$$self->remove_child ($_);
  }
} # CLEAR

package Message::DOM::NodeList::EmptyNodeList;
push our @ISA, 'Message::DOM::NodeList';

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

## |NodeList| attributes

sub EXISTS ($$) { 0 }

sub length ($) { 0 }

*FETCHSIZE = \&length;

sub STORESIZE ($$) {
  report Message::DOM::DOMException
      -object => $_[0],
      -type => 'NO_MODIFICATION_ALLOWED_ERR',
      -subtype => 'READ_ONLY_NODE_LIST_ERR'
      unless $_[1] == 0;
} # STORESIZE

sub manakai_read_only ($) { 1 }

## |NodeList| methods

sub item ($$) { undef }

*FETCH = \&item;

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

*DELETE = \&STORE;

*CLEAR = \&STORE;

package Message::DOM::NodeList::GetElementsList;
push our @ISA, 'Message::DOM::NodeList::EmptyNodeList';

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

## |NodeList| attributes

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

  ## TODO: Improve!
  local $Error::Depth = $Error::Depth + 1;
  my @target = @{$$self->[0]->child_nodes};
  while (@target) {
    my $target = shift @target;
    if ($target->node_type == 1) { # ELEMENT_NODE
      if ($$self->[1]->($target)) {
        $r++;
      }
    }
    unshift @target, @{$target->child_nodes};
  }

  return $r;
} # length
*FETCHSIZE = \&length;

## |NodeList| methods

sub item ($;$) {
  my $self = $_[0];
  my $index = 0+($_[1] or 0);

  ## TODO: Improve!
  local $Error::Depth = $Error::Depth + 1;
  my @target = @{$$self->[0]->child_nodes};
  my $i = -1;
  while (@target) {
    my $target = shift @target;
    if ($target->node_type == 1) { # ELEMENT_NODE
      if ($$self->[1]->($target)) {
        if (++$i == $index) {
          return $target;
        }
      }
    }
    unshift @target, @{$target->child_nodes};
  }

  return undef;
} # item
*FETCH = \&item;

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

package Message::IF::NodeList;

=head1 LICENSE

Copyright 2007 Wakaba <[email protected]>

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

=cut

1;
## $Date: 2007/06/17 13:37:40 $
1	wakaba	1.1	package Message::DOM::NodeList;
2			use strict;
3	wakaba	1.4	our $VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4	wakaba	1.2	push our @ISA, 'Tie::Array', 'Message::IF::NodeList';
5	wakaba	1.1	require Message::DOM::DOMException;
6	wakaba	1.2	require Tie::Array;
7	wakaba	1.1
8			use overload
9			'@{}' => sub {
10			tie my @list, ref $_[0], $_[0];
11			return \@list;
12			},
13			eq => sub {
14			return 0 unless UNIVERSAL::isa ($_[1], 'Message::DOM::NodeList');
15			return $${$_[0]} eq $${$_[1]};
16			},
17			ne => sub {
18			return not ($_[0] eq $_[1]);
19			},
20			'==' => sub {
21			return 0 unless UNIVERSAL::isa ($_[1], 'Message::IF::NodeList');
22
23			local $Error::Depth = $Error::Depth + 1;
24			my $l1 = $_[0]->length;
25			my $l2 = $_[1]->length;
26			return 0 unless $l1 == $l2;
27
28			for my $i (0 .. ($l1-1)) {
29			return 0 unless $_[0]->item ($i) == $_[1]->item ($i);
30			}
31
32			return 1;
33			},
34			'!=' => sub {
35			return not ($_[0] == $_[1]);
36			},
37			fallback => 1;
38
39			sub TIEARRAY ($$) { $_[1] }
40
41			package Message::DOM::NodeList::ChildNodeList;
42			push our @ISA, 'Message::DOM::NodeList';
43
44			sub ___report_error ($$) {
45			$_[1]->throw;
46			} # ___report_error
47
48			## \|NodeList\| attributes
49
50			sub EXISTS ($$) {
51			return exists ${$${$_[0]}}->{child_nodes}->[$_[1]];
52			} # EXISTS
53
54			sub length ($) {
55			return scalar @{${$${$_[0]}}->{child_nodes}};
56			} # length
57
58			*FETCHSIZE = \&length;
59
60			sub STORESIZE ($$) {
61			my $node = $${$_[0]};
62			my $list = $$node->{child_nodes};
63			my $current_length = @{$list};
64			my $count = $_[1];
65
66			local $Error::Depth = $Error::Depth + 1;
67			if ($current_length > $count) {
68			for (my $i = $current_length - 1; $i >= $count; $i--) {
69			$node->remove_child ($list->[$i]);
70			}
71			}
72			} # STORESIZE
73
74			sub manakai_read_only ($) {
75			local $Error::Depth = $Error::Depth + 1;
76			return $${$_[0]}->manakai_read_only;
77			} # manakai_read_only
78
79			## \|NodeList\| methods
80
81			sub item ($$) {
82			my $index = 0+$_[1];
83			return undef if $index < 0;
84			return ${$${$_[0]}}->{child_nodes}->[$index];
85			} # item
86
87			sub FETCH ($$) {
88			return ${$${$_[0]}}->{child_nodes}->[$_[1]];
89			} # FETCH
90
91			sub STORE ($$$) {
92			my $self = $_[0];
93			my $list = ${$$$self}->{child_nodes};
94			my $index = $_[1];
95
96			local $Error::Depth = $Error::Depth + 1;
97			if (exists $list->[$index]) {
98			$$$self->replace_child ($_[2], $list->[$index]);
99	wakaba	1.3	## ISSUE: This might not work if new_child is a sibling of ref_child
100	wakaba	1.1	} else {
101			$$$self->append_child ($_[2]);
102			}
103			} # STORE
104
105			sub DELETE ($$) {
106			my $self = $_[0];
107			my $list = ${$$$self}->{child_nodes};
108			my $index = $_[1];
109
110			if (exists $list->[$index]) {
111			local $Error::Depth = $Error::Depth + 1;
112			return $$$self->remove_child ($list->[$index]);
113			} else {
114			return undef;
115			}
116			} # DELETE
117
118			sub CLEAR ($) {
119			my $self = $_[0];
120			my $list = ${$$$self}->{child_nodes};
121
122			local $Error::Depth = $Error::Depth + 1;
123	wakaba	1.2	for (my @a = @$list) {
124	wakaba	1.1	$$$self->remove_child ($_);
125			}
126			} # CLEAR
127
128			package Message::DOM::NodeList::EmptyNodeList;
129			push our @ISA, 'Message::DOM::NodeList';
130
131			sub ___report_error ($$) {
132			$_[1]->throw;
133			} # ___report_error
134
135			## \|NodeList\| attributes
136
137			sub EXISTS ($$) { 0 }
138
139			sub length ($) { 0 }
140
141			*FETCHSIZE = \&length;
142
143			sub STORESIZE ($$) {
144			report Message::DOM::DOMException
145			-object => $_[0],
146			-type => 'NO_MODIFICATION_ALLOWED_ERR',
147			-subtype => 'READ_ONLY_NODE_LIST_ERR'
148			unless $_[1] == 0;
149			} # STORESIZE
150
151			sub manakai_read_only ($) { 1 }
152
153			## \|NodeList\| methods
154
155			sub item ($$) { undef }
156
157			*FETCH = \&item;
158
159			sub STORE ($$$) {
160			report Message::DOM::DOMException
161			-object => $_[0],
162			-type => 'NO_MODIFICATION_ALLOWED_ERR',
163			-subtype => 'READ_ONLY_NODE_LIST_ERR';
164			} # STORE
165
166			*DELETE = \&STORE;
167
168			*CLEAR = \&STORE;
169
170	wakaba	1.4	package Message::DOM::NodeList::GetElementsList;
171			push our @ISA, 'Message::DOM::NodeList::EmptyNodeList';
172
173			sub ___report_error ($$) {
174			$_[1]->throw;
175			} # ___report_error
176
177			## \|NodeList\| attributes
178
179			sub length ($) {
180			my $self = $_[0];
181			my $r = 0;
182
183			## TODO: Improve!
184			local $Error::Depth = $Error::Depth + 1;
185			my @target = @{$$self->[0]->child_nodes};
186			while (@target) {
187			my $target = shift @target;
188			if ($target->node_type == 1) { # ELEMENT_NODE
189			if ($$self->[1]->($target)) {
190			$r++;
191			}
192			}
193			unshift @target, @{$target->child_nodes};
194			}
195
196			return $r;
197			} # length
198			*FETCHSIZE = \&length;
199
200			## \|NodeList\| methods
201
202			sub item ($;$) {
203			my $self = $_[0];
204			my $index = 0+($_[1] or 0);
205
206			## TODO: Improve!
207			local $Error::Depth = $Error::Depth + 1;
208			my @target = @{$$self->[0]->child_nodes};
209			my $i = -1;
210			while (@target) {
211			my $target = shift @target;
212			if ($target->node_type == 1) { # ELEMENT_NODE
213			if ($$self->[1]->($target)) {
214			if (++$i == $index) {
215			return $target;
216			}
217			}
218			}
219			unshift @target, @{$target->child_nodes};
220			}
221
222			return undef;
223			} # item
224			*FETCH = \&item;
225
226			sub EXISTS ($$) {
227			return defined $_[0]->item ($_[1]);
228			} # EXISTS
229
230	wakaba	1.1	package Message::IF::NodeList;
231
232			=head1 LICENSE
233
234			Copyright 2007 Wakaba <[email protected]>
235
236			This program is free software; you can redistribute it and/or
237			modify it under the same terms as Perl itself.
238
239			=cut
240
241			1;
242	wakaba	1.4	## $Date: 2007/06/17 13:37:40 $