Message/DOM/Node.pm

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

## The |Node| interface - constants

## Definition group NodeType

## Spec: 
## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#ID-1841493061>
## <http://suika.fam.cx/gate/2005/sw/manakai/DOM%20Extensions#anchor-23>

## 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)
    local_name => 1,
    namespace_uri => 1,
    owner_document => 1,
    parent_node => 1,
  }->{$method_name}) {
    no strict 'refs';
    eval qq{
      sub $method_name (\$) {
        if (\@_ > 1) {
          require Carp;
          Carp::croak (qq<Can't modify read-only attribute>);
        }
        return \${\$_[0]}->{$method_name}; 
      }
    };
    goto &{ $AUTOLOAD };
  } elsif ({
    ## Read-write attributes (DOMString, trivial accessors)
    prefix => 1,
  }->{$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
sub local_name ($);
sub namespace_uri ($);
sub owner_document ($);
sub parent_node ($);
sub prefix ($;$);

## The |Node| interface - attribute

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

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

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

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

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

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

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

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

sub is_equal_node ($$) {
  return shift eq shift;
} # is_equal_node

sub manakai_local_name ($) {
  if (@_ > 1) {
    require Carp;
    Carp::croak (qq<Can't modify read-only attribute>);  
  }
  return ${$_[0]}->{local_name};
} # manakai_local_name

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

sub child_nodes ($) {
  ## TODO: NodeList
  return ${+shift}->{child_nodes} || [];
} # child_nodes

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

## NOTE: Only applied to Elements and Documents
sub first_child ($) {
  my $self = shift;
  return $$self->{child_nodes}->[0];
} # first_child

## NOTE: Only applied to Elements and Documents
sub last_child ($) {
  my $self = shift;
  return @{$$self->{child_nodes}} ? $$self->{child_nodes}->[-1] : undef;
} # last_child

## NOTE: Only applied to Elements and Documents
sub previous_sibling ($) {
  my $self = shift;
  my $parent = $$self->{parent_node};
  return undef unless defined $parent;
  my $r;
  for (@{$$parent->{child_nodes}}) {
    if ($_ eq $self) {
      return $r;
    } else {
      $r = $_;
    }
  }
  return undef;
} # previous_sibling

package Message::IF::Node;

1;
## License: <http://suika.fam.cx/~wakaba/archive/2004/8/18/license#Perl+MPL>
## $Date: 2007/06/13 12:04:50 $
1	wakaba	1.1	package Message::DOM::Node;
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::Node';
5			require Scalar::Util;
6
7	wakaba	1.2	## The \|Node\| interface - constants
8
9			## Definition group NodeType
10
11			## Spec:
12			## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#ID-1841493061>
13			## <http://suika.fam.cx/gate/2005/sw/manakai/DOM%20Extensions#anchor-23>
14
15			## NOTE: Numeric codes up to 200 are reserved by W3C [DOM1SE, DOM2, DOM3].
16
17			sub ELEMENT_NODE () { 1 }
18			sub ATTRIBUTE_NODE () { 2 }
19			sub TEXT_NODE () { 3 }
20			sub CDATA_SECTION_NODE () { 4 }
21			sub ENTITY_REFERENCE_NODE () { 5 }
22			sub ENTITY_NODE () { 6 }
23			sub PROCESSING_INSTRUCTION_NODE () { 7 }
24			sub COMMENT_NODE () { 8 }
25			sub DOCUMENT_NODE () { 9 }
26			sub DOCUMENT_TYPE_NODE () { 10 }
27			sub DOCUMENT_FRAGMENT_NODE () { 11 }
28			sub NOTATION_NODE () { 12 }
29			sub ELEMENT_TYPE_DEFINITION_NODE () { 81001 }
30			sub ATTRIBUTE_DEFINITION_NODE () { 81002 }
31
32			## Definition group DocumentPosition
33
34			## Spec:
35			## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#DocumentPosition>
36
37			sub DOCUMENT_POSITION_DISCONNECTED () { 0x01 }
38			sub DOCUMENT_POSITION_PRECEDING () { 0x02 }
39			sub DOCUMENT_POSITION_FOLLOWING () { 0x04 }
40			sub DOCUMENT_POSITION_CONTAINS () { 0x08 }
41			sub DOCUMENT_POSITION_CONTAINED_BY () { 0x10 }
42			sub DOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC () { 0x20 }
43
44	wakaba	1.1	sub ____new ($$) {
45			my $self = bless \({}), shift;
46			$$self->{owner_document} = shift;
47			Scalar::Util::weaken ($$self->{owner_document});
48			return $self;
49			} # ____new
50
51			sub AUTOLOAD {
52			my $method_name = our $AUTOLOAD;
53			$method_name =~ s/.*:://;
54			return if $method_name eq 'DESTROY';
55
56			if ({
57			## Read-only attributes (trivial accessors)
58			local_name => 1,
59			namespace_uri => 1,
60			owner_document => 1,
61			parent_node => 1,
62			}->{$method_name}) {
63			no strict 'refs';
64			eval qq{
65			sub $method_name (\$) {
66			if (\@_ > 1) {
67			require Carp;
68			Carp::croak (qq<Can't modify read-only attribute>);
69			}
70			return \${\$_[0]}->{$method_name};
71			}
72			};
73			goto &{ $AUTOLOAD };
74			} elsif ({
75			## Read-write attributes (DOMString, trivial accessors)
76			prefix => 1,
77			}->{$method_name}) {
78			no strict 'refs';
79			eval qq{
80	wakaba	1.2	sub $method_name (\$;\$) {
81	wakaba	1.1	if (\@_ > 1) {
82	wakaba	1.2	\${\$_[0]}->{$method_name} = ''.\$_[1];
83	wakaba	1.1	}
84			return \${\$_[0]}->{$method_name};
85			}
86			};
87			goto &{ $AUTOLOAD };
88			} else {
89			require Carp;
90			Carp::croak (qq<Can't locate method "$AUTOLOAD">);
91			}
92			} # AUTOLOAD
93			sub local_name ($);
94			sub namespace_uri ($);
95			sub owner_document ($);
96			sub parent_node ($);
97			sub prefix ($;$);
98
99			## The \|Node\| interface - attribute
100
101	wakaba	1.2	## Spec:
102			## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#ID-84CF096>
103			## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#ID-1950641247>
104
105			sub attributes ($) {
106			## NOTE: Overloaded by \|Message::DOM::Element\|.
107			return undef;
108			} # attributes
109
110			## Spec:
111			## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#ID-F68D095>
112			## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#ID-1950641247>
113
114			sub node_name ($) {
115			## NOTE: Overloaded by subclasses.
116			return undef;
117			} # node_name
118
119			## Spec:
120			## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#ID-111237558>
121
122			sub node_type ($) {
123			## NOTE: Overloaded by subclasses.
124			die "Node->node_type is not defined";
125			} # node_type
126
127			## Spec:
128			## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#ID-F68D080>
129			## <http://www.w3.org/TR/2004/REC-DOM-Level-3-Core-20040407/core.html#ID-1950641247>
130
131			sub node_value ($;$) {
132			## NOTE: Overloaded by subclasses.
133			return undef;
134			} # node_value
135
136	wakaba	1.1	sub is_equal_node ($$) {
137			return shift eq shift;
138			} # is_equal_node
139
140			sub manakai_local_name ($) {
141			if (@_ > 1) {
142			require Carp;
143			Carp::croak (qq<Can't modify read-only attribute>);
144			}
145			return ${$_[0]}->{local_name};
146			} # manakai_local_name
147
148			sub manakai_parent_element ($) {
149			my $self = shift;
150			my $parent = $$self->{parent_node};
151			while (defined $parent) {
152			if ($parent->node_type == 1) { # ELEMENT_NODE
153			return $parent;
154			} else {
155			$parent = $$parent->{parent_node};
156			}
157			}
158			return undef;
159			} # manakai_parent_element
160
161			sub child_nodes ($) {
162			## TODO: NodeList
163			return ${+shift}->{child_nodes} \|\| [];
164			} # child_nodes
165
166			## NOTE: Only applied to Elements and Documents
167			sub append_child ($$) {
168			my ($self, $new_child) = @_;
169			if (defined $$new_child->{parent_node}) {
170			my $parent_list = $$new_child->{parent_node}->{child_nodes};
171			for (0..$#$parent_list) {
172			if ($parent_list->[$_] eq $new_child) {
173			splice @$parent_list, $_, 1;
174			}
175			}
176			}
177			push @{$$self->{child_nodes}}, $new_child;
178			$$new_child->{parent_node} = $self;
179			Scalar::Util::weaken ($$new_child->{parent_node});
180			return $new_child;
181			} # append_child
182
183			## NOTE: Only applied to Elements and Documents
184			sub insert_before ($$;$) {
185			my ($self, $new_child, $ref_child) = @_;
186			if (defined $$new_child->{parent_node}) {
187			my $parent_list = $$new_child->{parent_node}->{child_nodes};
188			for (0..$#$parent_list) {
189			if ($parent_list->[$_] eq $new_child) {
190			splice @$parent_list, $_, 1;
191			}
192			}
193			}
194			my $i = @{$$self->{child_nodes}};
195			if (defined $ref_child) {
196			for (0..$#{$$self->{child_nodes}}) {
197			if ($$self->{child_nodes}->[$_] eq $ref_child) {
198			$i = $_;
199			last;
200			}
201			}
202			}
203			splice @{$$self->{child_nodes}}, $i, 0, $new_child;
204			$$new_child->{parent_node} = $self;
205			Scalar::Util::weaken ($$new_child->{parent_node});
206			return $new_child;
207			} # insert_before
208
209			## NOTE: Only applied to Elements and Documents
210			sub remove_child ($$) {
211			my ($self, $old_child) = @_;
212			my $parent_list = $$self->{child_nodes};
213			for (0..$#$parent_list) {
214			if ($parent_list->[$_] eq $old_child) {
215			splice @$parent_list, $_, 1;
216			}
217			}
218			delete $$old_child->{parent_node};
219			return $old_child;
220			} # remove_child
221
222			## NOTE: Only applied to Elements and Documents
223			sub has_child_nodes ($) {
224			return @{${+shift}->{child_nodes}} > 0;
225			} # has_child_nodes
226
227			## NOTE: Only applied to Elements and Documents
228			sub first_child ($) {
229			my $self = shift;
230			return $$self->{child_nodes}->[0];
231			} # first_child
232
233			## NOTE: Only applied to Elements and Documents
234			sub last_child ($) {
235			my $self = shift;
236			return @{$$self->{child_nodes}} ? $$self->{child_nodes}->[-1] : undef;
237			} # last_child
238
239			## NOTE: Only applied to Elements and Documents
240			sub previous_sibling ($) {
241			my $self = shift;
242			my $parent = $$self->{parent_node};
243			return undef unless defined $parent;
244			my $r;
245			for (@{$$parent->{child_nodes}}) {
246			if ($_ eq $self) {
247			return $r;
248			} else {
249			$r = $_;
250			}
251			}
252			return undef;
253			} # previous_sibling
254
255			package Message::IF::Node;
256
257			1;
258			## License: <http://suika.fam.cx/~wakaba/archive/2004/8/18/license#Perl+MPL>
259	wakaba	1.2	## $Date: 2007/06/13 12:04:50 $