Message/DOM/Node.pm

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

## NOTE:
##   Node
##   + Attr (2)
##   + AttributeDefinition (81002)
##   + CharacterData
##     + Comment (8)
##     + Text (3)
##       + CDATASection (4)
##   + Document (9)
##   + DocumentFragment (11)
##   + DocumentType (10)
##   + Element (1)
##   + ElementTypeDefinition (81001)
##   + Entity (6)
##   + EntityReference (5)
##   + Notation (12)
##   + ProcessingInstruction (7)

use overload
    '==' => sub {
      return 0 unless UNIVERSAL::isa ($_[0], 'Message::IF::Node');
      ## TODO: implement is_equal_node
      return $_[0]->is_equal_node ($_[1]);
    },
    '!=' => sub {
      return not ($_[0] == $_[1]);
    },
    fallback => 1;

## The |Node| interface - constants

## Definition group NodeType

## NOTE: Numeric codes up to 200 are reserved by W3C [DOM1SE, DOM2, DOM3].

sub ELEMENT_NODE () { 1 }
sub ATTRIBUTE_NODE () { 2 }
sub TEXT_NODE () { 3 }
sub CDATA_SECTION_NODE () { 4 }
sub ENTITY_REFERENCE_NODE () { 5 }
sub ENTITY_NODE () { 6 }
sub PROCESSING_INSTRUCTION_NODE () { 7 }
sub COMMENT_NODE () { 8 }
sub DOCUMENT_NODE () { 9 }
sub DOCUMENT_TYPE_NODE () { 10 }
sub DOCUMENT_FRAGMENT_NODE () { 11 }
sub NOTATION_NODE () { 12 }
sub ELEMENT_TYPE_DEFINITION_NODE () { 81001 }
sub ATTRIBUTE_DEFINITION_NODE () { 81002 }

## Definition group DocumentPosition

## Spec:
## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#DocumentPosition>

sub DOCUMENT_POSITION_DISCONNECTED () { 0x01 }
sub DOCUMENT_POSITION_PRECEDING () { 0x02 }
sub DOCUMENT_POSITION_FOLLOWING () { 0x04 }
sub DOCUMENT_POSITION_CONTAINS () { 0x08 }
sub DOCUMENT_POSITION_CONTAINED_BY () { 0x10 }
sub DOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC () { 0x20 }

sub ____new ($$) {
  my $self = bless \({}), shift;
  $$self->{owner_document} = shift;
  Scalar::Util::weaken ($$self->{owner_document});
  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)
    owner_document => 1,
    parent_node => 1,
    manakai_read_only => 1,
  }->{$method_name}) {
    no strict 'refs';
    eval qq{
      sub $method_name (\$) {
        return \${\$_[0]}->{$method_name}; 
      }
    };
    goto &{ $AUTOLOAD };
  } elsif ({
    ## Read-write attributes (DOMString, trivial accessors)
  }->{$method_name}) {
    no strict 'refs';
    eval qq{
      sub $method_name (\$;\$) {
        if (\@_ > 1) {
          \${\$_[0]}->{$method_name} = ''.\$_[1];
        }
        return \${\$_[0]}->{$method_name}; 
      }
    };
    goto &{ $AUTOLOAD };
  } else {
    require Carp;
    Carp::croak (qq<Can't locate method "$AUTOLOAD">);
  }
} # AUTOLOAD

## The |Node| interface - attribute

sub attributes ($) {
  ## NOTE: Overloaded by |Message::DOM::Element|.
  return undef;
} # attributes

## TODO: baseURI

sub child_nodes ($) {
  require Message::DOM::NodeList;
  return bless \\($_[0]), 'Message::DOM::NodeList::ChildNodeList';
} # child_nodes

sub first_child ($) {
  my $self = shift;
  return $$self->{child_nodes} ? $$self->{child_nodes}->[0] : undef;
} # first_child

sub last_child ($) {
  my $self = shift;
  return $$self->{child_nodes} && $$self->{child_nodes}->[0]
    ? $$self->{child_nodes}->[-1] : undef;
} # last_child

sub local_name ($) { undef }
sub manakai_local_name ($) { undef }

sub namespace_uri ($) { undef }

sub next_sibling ($) {
  my $self = shift;
  my $parent = $$self->{parent_node};
  return undef unless defined $parent;
  my $has_self;
  for (@{$parent->child_nodes}) {
    if ($_ eq $self) {
      $has_self = 1;
    } elsif ($has_self) {
      return $_;
    }
  }
  return undef;
} # next_sibling

sub node_name ($) {
  ## NOTE: Overloaded by subclasses.
  return undef;
} # node_name

sub node_type ($) {
  ## NOTE: Overloaded by subclasses.
  die "Node->node_type is not defined";
} # node_type

sub node_value ($;$) {
  ## NOTE: Overloaded by subclasses.
  return undef;
} # node_value

## TODO: node_value setter

sub owner_document ($);

sub parent_node ($);

sub prefix ($;$) { undef }

sub previous_sibling ($) {
  my $self = shift;
  my $parent = $$self->{parent_node};
  return undef unless defined $parent;
  my $prev;
  for (@{$parent->child_nodes}) {
    if ($_ eq $self) {
      return $prev;
    } else {
      $prev = $_;
    }
  }
  return undef;
} # previous_sibling

sub manakai_read_only ($);

sub text_content ($;$) {
  ## TODO: 
} # text_content

## TODO:
sub is_same_node ($$) {
  return $_[0] eq $_[1];
} # is_same_node

## TODO:
sub is_equal_node ($$) {
  return $_[0]->node_name eq $_[1]->node_name &&
    $_[0]->node_value eq $_[1]->node_value;
} # is_equal_node

sub manakai_parent_element ($) {
  my $self = shift;
  my $parent = $$self->{parent_node};
  while (defined $parent) {
    if ($parent->node_type == 1) { # ELEMENT_NODE
      return $parent;
    } else {
      $parent = $$parent->{parent_node};
    }
  }
  return undef;
} # manakai_parent_element

## NOTE: Only applied to Elements and Documents
sub append_child ($$) {
  my ($self, $new_child) = @_;
  if (defined $$new_child->{parent_node}) {
    my $parent_list = ${$$new_child->{parent_node}}->{child_nodes};
    for (0..$#$parent_list) {
      if ($parent_list->[$_] eq $new_child) {
        splice @$parent_list, $_, 1;
      }
    }
  }
  push @{$$self->{child_nodes}}, $new_child;
  $$new_child->{parent_node} = $self;
  Scalar::Util::weaken ($$new_child->{parent_node});
  return $new_child;
} # append_child

## NOTE: Only applied to Elements and Documents
sub insert_before ($$;$) {
  my ($self, $new_child, $ref_child) = @_;
  if (defined $$new_child->{parent_node}) {
    my $parent_list = ${$$new_child->{parent_node}}->{child_nodes};
    for (0..$#$parent_list) {
      if ($parent_list->[$_] eq $new_child) {
        splice @$parent_list, $_, 1;
      }
    }
  }
  my $i = @{$$self->{child_nodes}};
  if (defined $ref_child) {
    for (0..$#{$$self->{child_nodes}}) {
      if ($$self->{child_nodes}->[$_] eq $ref_child) {
        $i = $_;
        last;
      }
    }
  }
  splice @{$$self->{child_nodes}}, $i, 0, $new_child;
  $$new_child->{parent_node} = $self;
  Scalar::Util::weaken ($$new_child->{parent_node});
  return $new_child;
} # insert_before

## NOTE: Only applied to Elements and Documents
sub remove_child ($$) {
  my ($self, $old_child) = @_;
  my $parent_list = $$self->{child_nodes};
  for (0..$#$parent_list) {
    if ($parent_list->[$_] eq $old_child) {
      splice @$parent_list, $_, 1;
    }
  }
  delete $$old_child->{parent_node};
  return $old_child;
} # remove_child

## NOTE: Only applied to Elements and Documents
sub has_child_nodes ($) {
  return @{${+shift}->{child_nodes}} > 0;
} # has_child_nodes

sub manakai_set_read_only ($;$$) {
  my ($self, $value, $deep) = @_;
  ## TODO: deep
  $$self->{manakai_read_only} = $value;
} # manakai_set_read_only

package Message::IF::Node;

=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/06/16 08:05:48 $
1	wakaba	1.1	package Message::DOM::Node;
2			use strict;
3	wakaba	1.5	our $VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4	wakaba	1.1	push our @ISA, 'Message::IF::Node';
5			require Scalar::Util;
6
7	wakaba	1.4	## NOTE:
8			## Node
9			## + Attr (2)
10			## + AttributeDefinition (81002)
11			## + CharacterData
12			## + Comment (8)
13			## + Text (3)
14			## + CDATASection (4)
15			## + Document (9)
16			## + DocumentFragment (11)
17			## + DocumentType (10)
18			## + Element (1)
19			## + ElementTypeDefinition (81001)
20			## + Entity (6)
21			## + EntityReference (5)
22			## + Notation (12)
23			## + ProcessingInstruction (7)
24
25			use overload
26			'==' => sub {
27			return 0 unless UNIVERSAL::isa ($_[0], 'Message::IF::Node');
28			## TODO: implement is_equal_node
29			return $_[0]->is_equal_node ($_[1]);
30			},
31			'!=' => sub {
32			return not ($_[0] == $_[1]);
33			},
34			fallback => 1;
35
36	wakaba	1.2	## The \|Node\| interface - constants
37
38			## Definition group NodeType
39
40			## NOTE: Numeric codes up to 200 are reserved by W3C [DOM1SE, DOM2, DOM3].
41
42			sub ELEMENT_NODE () { 1 }
43			sub ATTRIBUTE_NODE () { 2 }
44			sub TEXT_NODE () { 3 }
45			sub CDATA_SECTION_NODE () { 4 }
46			sub ENTITY_REFERENCE_NODE () { 5 }
47			sub ENTITY_NODE () { 6 }
48			sub PROCESSING_INSTRUCTION_NODE () { 7 }
49			sub COMMENT_NODE () { 8 }
50			sub DOCUMENT_NODE () { 9 }
51			sub DOCUMENT_TYPE_NODE () { 10 }
52			sub DOCUMENT_FRAGMENT_NODE () { 11 }
53			sub NOTATION_NODE () { 12 }
54			sub ELEMENT_TYPE_DEFINITION_NODE () { 81001 }
55			sub ATTRIBUTE_DEFINITION_NODE () { 81002 }
56
57			## Definition group DocumentPosition
58
59			## Spec:
60			## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#DocumentPosition>
61
62			sub DOCUMENT_POSITION_DISCONNECTED () { 0x01 }
63			sub DOCUMENT_POSITION_PRECEDING () { 0x02 }
64			sub DOCUMENT_POSITION_FOLLOWING () { 0x04 }
65			sub DOCUMENT_POSITION_CONTAINS () { 0x08 }
66			sub DOCUMENT_POSITION_CONTAINED_BY () { 0x10 }
67			sub DOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC () { 0x20 }
68
69	wakaba	1.1	sub ____new ($$) {
70			my $self = bless \({}), shift;
71			$$self->{owner_document} = shift;
72			Scalar::Util::weaken ($$self->{owner_document});
73			return $self;
74			} # ____new
75
76			sub AUTOLOAD {
77			my $method_name = our $AUTOLOAD;
78			$method_name =~ s/.*:://;
79			return if $method_name eq 'DESTROY';
80
81			if ({
82			## Read-only attributes (trivial accessors)
83			owner_document => 1,
84			parent_node => 1,
85	wakaba	1.4	manakai_read_only => 1,
86	wakaba	1.1	}->{$method_name}) {
87			no strict 'refs';
88			eval qq{
89			sub $method_name (\$) {
90			return \${\$_[0]}->{$method_name};
91			}
92			};
93			goto &{ $AUTOLOAD };
94			} elsif ({
95			## Read-write attributes (DOMString, trivial accessors)
96			}->{$method_name}) {
97			no strict 'refs';
98			eval qq{
99	wakaba	1.2	sub $method_name (\$;\$) {
100	wakaba	1.1	if (\@_ > 1) {
101	wakaba	1.2	\${\$_[0]}->{$method_name} = ''.\$_[1];
102	wakaba	1.1	}
103			return \${\$_[0]}->{$method_name};
104			}
105			};
106			goto &{ $AUTOLOAD };
107			} else {
108			require Carp;
109			Carp::croak (qq<Can't locate method "$AUTOLOAD">);
110			}
111			} # AUTOLOAD
112
113			## The \|Node\| interface - attribute
114
115	wakaba	1.2	sub attributes ($) {
116			## NOTE: Overloaded by \|Message::DOM::Element\|.
117			return undef;
118			} # attributes
119
120	wakaba	1.3	## TODO: baseURI
121
122			sub child_nodes ($) {
123	wakaba	1.4	require Message::DOM::NodeList;
124			return bless \\($_[0]), 'Message::DOM::NodeList::ChildNodeList';
125	wakaba	1.3	} # child_nodes
126
127			sub first_child ($) {
128			my $self = shift;
129			return $$self->{child_nodes} ? $$self->{child_nodes}->[0] : undef;
130			} # first_child
131
132			sub last_child ($) {
133			my $self = shift;
134			return $$self->{child_nodes} && $$self->{child_nodes}->[0]
135			? $$self->{child_nodes}->[-1] : undef;
136			} # last_child
137
138			sub local_name ($) { undef }
139			sub manakai_local_name ($) { undef }
140
141			sub namespace_uri ($) { undef }
142
143			sub next_sibling ($) {
144			my $self = shift;
145			my $parent = $$self->{parent_node};
146			return undef unless defined $parent;
147			my $has_self;
148			for (@{$parent->child_nodes}) {
149			if ($_ eq $self) {
150			$has_self = 1;
151			} elsif ($has_self) {
152			return $_;
153			}
154			}
155			return undef;
156			} # next_sibling
157	wakaba	1.2
158			sub node_name ($) {
159			## NOTE: Overloaded by subclasses.
160			return undef;
161			} # node_name
162
163			sub node_type ($) {
164			## NOTE: Overloaded by subclasses.
165			die "Node->node_type is not defined";
166			} # node_type
167
168			sub node_value ($;$) {
169			## NOTE: Overloaded by subclasses.
170			return undef;
171			} # node_value
172
173	wakaba	1.3	## TODO: node_value setter
174
175			sub owner_document ($);
176
177			sub parent_node ($);
178
179			sub prefix ($;$) { undef }
180
181			sub previous_sibling ($) {
182			my $self = shift;
183			my $parent = $$self->{parent_node};
184			return undef unless defined $parent;
185			my $prev;
186			for (@{$parent->child_nodes}) {
187			if ($_ eq $self) {
188			return $prev;
189			} else {
190			$prev = $_;
191			}
192			}
193			return undef;
194			} # previous_sibling
195
196	wakaba	1.4	sub manakai_read_only ($);
197
198	wakaba	1.3	sub text_content ($;$) {
199			## TODO:
200			} # text_content
201
202	wakaba	1.4	## TODO:
203			sub is_same_node ($$) {
204			return $_[0] eq $_[1];
205			} # is_same_node
206
207			## TODO:
208	wakaba	1.1	sub is_equal_node ($$) {
209	wakaba	1.4	return $_[0]->node_name eq $_[1]->node_name &&
210			$_[0]->node_value eq $_[1]->node_value;
211	wakaba	1.1	} # is_equal_node
212
213			sub manakai_parent_element ($) {
214			my $self = shift;
215			my $parent = $$self->{parent_node};
216			while (defined $parent) {
217			if ($parent->node_type == 1) { # ELEMENT_NODE
218			return $parent;
219			} else {
220			$parent = $$parent->{parent_node};
221			}
222			}
223			return undef;
224			} # manakai_parent_element
225
226			## NOTE: Only applied to Elements and Documents
227			sub append_child ($$) {
228			my ($self, $new_child) = @_;
229			if (defined $$new_child->{parent_node}) {
230	wakaba	1.5	my $parent_list = ${$$new_child->{parent_node}}->{child_nodes};
231	wakaba	1.1	for (0..$#$parent_list) {
232			if ($parent_list->[$_] eq $new_child) {
233			splice @$parent_list, $_, 1;
234			}
235			}
236			}
237			push @{$$self->{child_nodes}}, $new_child;
238			$$new_child->{parent_node} = $self;
239			Scalar::Util::weaken ($$new_child->{parent_node});
240			return $new_child;
241			} # append_child
242
243			## NOTE: Only applied to Elements and Documents
244			sub insert_before ($$;$) {
245			my ($self, $new_child, $ref_child) = @_;
246			if (defined $$new_child->{parent_node}) {
247	wakaba	1.5	my $parent_list = ${$$new_child->{parent_node}}->{child_nodes};
248	wakaba	1.1	for (0..$#$parent_list) {
249			if ($parent_list->[$_] eq $new_child) {
250			splice @$parent_list, $_, 1;
251			}
252			}
253			}
254			my $i = @{$$self->{child_nodes}};
255			if (defined $ref_child) {
256			for (0..$#{$$self->{child_nodes}}) {
257			if ($$self->{child_nodes}->[$_] eq $ref_child) {
258			$i = $_;
259			last;
260			}
261			}
262			}
263			splice @{$$self->{child_nodes}}, $i, 0, $new_child;
264			$$new_child->{parent_node} = $self;
265			Scalar::Util::weaken ($$new_child->{parent_node});
266			return $new_child;
267			} # insert_before
268
269			## NOTE: Only applied to Elements and Documents
270			sub remove_child ($$) {
271			my ($self, $old_child) = @_;
272			my $parent_list = $$self->{child_nodes};
273			for (0..$#$parent_list) {
274			if ($parent_list->[$_] eq $old_child) {
275			splice @$parent_list, $_, 1;
276			}
277			}
278			delete $$old_child->{parent_node};
279			return $old_child;
280			} # remove_child
281
282			## NOTE: Only applied to Elements and Documents
283			sub has_child_nodes ($) {
284			return @{${+shift}->{child_nodes}} > 0;
285			} # has_child_nodes
286
287	wakaba	1.4	sub manakai_set_read_only ($;$$) {
288			my ($self, $value, $deep) = @_;
289			## TODO: deep
290			$$self->{manakai_read_only} = $value;
291			} # manakai_set_read_only
292
293			package Message::IF::Node;
294
295			=head1 LICENSE
296	wakaba	1.1
297	wakaba	1.4	Copyright 2007 Wakaba <w@suika.fam.cx>
298	wakaba	1.1
299	wakaba	1.4	This program is free software; you can redistribute it and/or
300			modify it under the same terms as Perl itself.
301	wakaba	1.1
302	wakaba	1.4	=cut
303	wakaba	1.1
304			1;
305	wakaba	1.5	## $Date: 2007/06/16 08:05:48 $