whatpm/What/NanoDOM.pm

package What::NanoDOM;
use strict;

package What::NanoDOM::Node;

sub new ($) {
  my $class = shift;
  my $self = bless {}, $class;
  return $self;
} # new

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

sub parent_node ($) {
  return shift->{parent_node};
} # parent_node

## NOTE: Only applied to Elements and Documents
sub child_nodes ($) {
  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; ## TODO: weaken this ref
  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; ## TODO: weaken this ref
  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 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

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 }

package What::NanoDOM::Document;
push our @ISA, 'What::NanoDOM::Node';

sub new ($) {
  my $self = shift->SUPER::new;
  $self->{child_nodes} = [];
  return $self;
} # new

## A manakai extension
sub manakai_append_text ($$) {
  my $self = shift;
  if (@{$self->{child_nodes}} and
      $self->{child_nodes}->[-1]->node_type == 3) {
    $self->{child_nodes}->[-1]->manakai_append_text (shift);
  } else {
    my $text = $self->create_text_node (shift);
    $self->append_child ($text);
  }
} # manakai_append_text

sub node_type () { 9 }

sub strict_error_checking {
  return 0;
} # strict_error_checking

sub create_text_node ($$) {
  shift;
  return What::NanoDOM::Text->new (shift);
} # create_text_node

sub create_comment ($$) {
  shift;
  return What::NanoDOM::Comment->new (shift);
} # create_comment

## The second parameter only supports manakai extended way
## to specify qualified name - "[$prefix, $local_name]"
sub create_element_ns ($$$) {
  my ($self, $nsuri, $qn) = @_;
  return What::NanoDOM::Element->new ($nsuri, $qn->[0], $qn->[1]);
} # create_element_ns

## A manakai extension
sub create_document_type_definition ($$) {
  shift;
  return What::NanoDOM::DocumentType->new (shift);
} # create_document_type_definition

package What::NanoDOM::Element;
push our @ISA, 'What::NanoDOM::Node';

sub new ($$$$) {
  my $self = shift->SUPER::new;
  $self->{namespace_uri} = shift;
  $self->{prefix} = shift;
  $self->{local_name} = shift;
  $self->{attributes} = {};
  $self->{child_nodes} = [];
  return $self;
} # new

sub clone_node ($$) {
  my ($self, $deep) = @_; ## NOTE: Deep cloning is not supported
  my $clone = bless {
    namespace_uri => $self->{namespace_uri},
    prefix => $self->{prefix},
    local_name => $self->{local_name},      
    child_nodes => [],
  }, ref $self;
  for my $ns (keys %{$self->{attributes}}) {
    for my $ln (keys %{$self->{attributes}->{$ns}}) {
      my $attr = $self->{attributes}->{$ns}->{$ln};
      $clone->{attributes}->{$ns}->{$ln} = bless {
        namespace_uri => $attr->{namespace_uri},
        prefix => $attr->{prefix},
        local_name => $attr->{local_name},
        value => $attr->{value},
      }, ref $self->{attributes}->{$ns}->{$ln};
    }
  }
  return $clone;
} # clone

## A manakai extension
sub manakai_append_text ($$) {
  my $self = shift;
  if (@{$self->{child_nodes}} and
      $self->{child_nodes}->[-1]->node_type == 3) {
    $self->{child_nodes}->[-1]->manakai_append_text (shift);
  } else {
    my $text = What::NanoDOM::Text->new (shift);
    $self->append_child ($text);
  }
} # manakai_append_text

sub attributes ($) {
  my $self = shift;
  my $r = [];
  ## Order MUST be stable
  for my $ns (sort {$a cmp $b} keys %{$self->{attributes}}) {
    for my $ln (sort {$a cmp $b} keys %{$self->{attributes}->{$ns}}) {
      push @$r, $self->{attributes}->{$ns}->{$ln}
        if defined $self->{attributes}->{$ns}->{$ln};
    }
  }
  return $r;
} # attributes

sub node_type { 1 }

## TODO: HTML5 capitalization
sub tag_name ($) {
  my $self = shift;
  if (defined $self->{prefix}) {
    return $self->{prefix} . ':' . $self->{local_name};
  } else {
    return $self->{local_name};
  }
} # tag_name

sub has_attribute_ns ($$$) {
  my ($self, $nsuri, $ln) = @_;
  return defined $self->{attributes}->{$nsuri}->{$ln};
} # has_attribute_ns

## The second parameter only supports manakai extended way
## to specify qualified name - "[$prefix, $local_name]"
sub set_attribute_ns ($$$$) {
  my ($self, $nsuri, $qn, $value) = @_;
  $self->{attributes}->{$nsuri}->{$qn->[1]}
    = What::NanoDOM::Attr->new ($nsuri, $qn->[0], $qn->[1], $value);
} # set_attribute_ns

package What::NanoDOM::Attr;
push our @ISA, 'What::NanoDOM::Node';

sub new ($$$$$) {
  my $self = shift->SUPER::new;
  $self->{namespace_uri} = shift;
  $self->{prefix} = shift;
  $self->{local_name} = shift;
  $self->{value} = shift;
  return $self;
} # new

sub node_type { 2 }

## 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 value ($) {
  return shift->{value};
} # value

package What::NanoDOM::CharacterData;
push our @ISA, 'What::NanoDOM::Node';

sub new ($$) {
  my $self = shift->SUPER::new;
  $self->{data} = shift;
  return $self;
} # new

## A manakai extension
sub manakai_append_text ($$) {
  my ($self, $s) = @_;
  $self->{data} .= $s;
} # manakai_append_text

sub data ($) {
  return shift->{data};
} # data

package What::NanoDOM::Text;
push our @ISA, 'What::NanoDOM::CharacterData';

sub node_type () { 3 }

package What::NanoDOM::Comment;
push our @ISA, 'What::NanoDOM::CharacterData';

sub node_type () { 8 }

package What::NanoDOM::DocumentType;
push our @ISA, 'What::NanoDOM::Node';

sub new ($$) {
  my $self = shift->SUPER::new;
  $self->{name} = shift;
  return $self;
} # new

sub node_type () { 10 }

sub name ($) {
  return shift->{name};
} # name

1;
# $Date: 2007/04/30 14:12:02 $
1	wakaba	1.1	package What::NanoDOM;
2			use strict;
3
4			package What::NanoDOM::Node;
5
6			sub new ($) {
7			my $class = shift;
8			my $self = bless {}, $class;
9			return $self;
10			} # new
11
12			sub is_equal_node ($$) {
13			return shift eq shift;
14			} # is_equal_node
15
16			sub parent_node ($) {
17			return shift->{parent_node};
18			} # parent_node
19
20			## NOTE: Only applied to Elements and Documents
21			sub child_nodes ($) {
22			return shift->{child_nodes};
23			} # child_nodes
24
25			## NOTE: Only applied to Elements and Documents
26			sub append_child ($$) {
27			my ($self, $new_child) = @_;
28			if (defined $new_child->{parent_node}) {
29			my $parent_list = $new_child->{parent_node}->{child_nodes};
30			for (0..$#$parent_list) {
31			if ($parent_list->[$_] eq $new_child) {
32			splice @$parent_list, $_, 1;
33			}
34			}
35			}
36			push @{$self->{child_nodes}}, $new_child;
37			$new_child->{parent_node} = $self; ## TODO: weaken this ref
38			return $new_child;
39			} # append_child
40
41			## NOTE: Only applied to Elements and Documents
42			sub insert_before ($$;$) {
43			my ($self, $new_child, $ref_child) = @_;
44			if (defined $new_child->{parent_node}) {
45			my $parent_list = $new_child->{parent_node}->{child_nodes};
46			for (0..$#$parent_list) {
47			if ($parent_list->[$_] eq $new_child) {
48			splice @$parent_list, $_, 1;
49			}
50			}
51			}
52			my $i = @{$self->{child_nodes}};
53			if (defined $ref_child) {
54			for (0..$#{$self->{child_nodes}}) {
55			if ($self->{child_nodes}->[$_] eq $ref_child) {
56			$i = $_;
57			last;
58			}
59			}
60			}
61			splice @{$self->{child_nodes}}, $i, 0, $new_child;
62			$new_child->{parent_node} = $self; ## TODO: weaken this ref
63			return $new_child;
64			} # insert_before
65
66	wakaba	1.2	## NOTE: Only applied to Elements and Documents
67	wakaba	1.1	sub remove_child ($$) {
68			my ($self, $old_child) = @_;
69			my $parent_list = $self->{child_nodes};
70			for (0..$#$parent_list) {
71			if ($parent_list->[$_] eq $old_child) {
72			splice @$parent_list, $_, 1;
73			}
74			}
75			delete $old_child->{parent_node};
76			return $old_child;
77			} # remove_child
78
79			## NOTE: Only applied to Elements and Documents
80			sub has_child_nodes ($) {
81			return @{shift->{child_nodes}} > 0;
82			} # has_child_nodes
83
84	wakaba	1.2	## NOTE: Only applied to Elements and Documents
85			sub last_child ($) {
86			my $self = shift;
87			return @{$self->{child_nodes}} ? $self->{child_nodes}->[-1] : undef;
88			} # last_child
89
90			## NOTE: Only applied to Elements and Documents
91			sub previous_sibling ($) {
92			my $self = shift;
93			my $parent = $self->{parent_node};
94			return undef unless defined $parent;
95			my $r;
96			for (@{$parent->{child_nodes}}) {
97			if ($_ eq $self) {
98			return $r;
99			} else {
100			$r = $_;
101			}
102			}
103			return undef;
104			} # previous_sibling
105
106	wakaba	1.1	sub ELEMENT_NODE () { 1 }
107			sub ATTRIBUTE_NODE () { 2 }
108			sub TEXT_NODE () { 3 }
109			sub CDATA_SECTION_NODE () { 4 }
110			sub ENTITY_REFERENCE_NODE () { 5 }
111			sub ENTITY_NODE () { 6 }
112			sub PROCESSING_INSTRUCTION_NODE () { 7 }
113			sub COMMENT_NODE () { 8 }
114			sub DOCUMENT_NODE () { 9 }
115			sub DOCUMENT_TYPE_NODE () { 10 }
116			sub DOCUMENT_FRAGMENT_NODE () { 11 }
117			sub NOTATION_NODE () { 12 }
118
119			package What::NanoDOM::Document;
120			push our @ISA, 'What::NanoDOM::Node';
121
122			sub new ($) {
123			my $self = shift->SUPER::new;
124			$self->{child_nodes} = [];
125			return $self;
126			} # new
127
128			## A manakai extension
129			sub manakai_append_text ($$) {
130			my $self = shift;
131			if (@{$self->{child_nodes}} and
132			$self->{child_nodes}->[-1]->node_type == 3) {
133			$self->{child_nodes}->[-1]->manakai_append_text (shift);
134			} else {
135			my $text = $self->create_text_node (shift);
136			$self->append_child ($text);
137			}
138			} # manakai_append_text
139
140			sub node_type () { 9 }
141
142			sub strict_error_checking {
143			return 0;
144			} # strict_error_checking
145
146			sub create_text_node ($$) {
147			shift;
148			return What::NanoDOM::Text->new (shift);
149			} # create_text_node
150
151			sub create_comment ($$) {
152			shift;
153			return What::NanoDOM::Comment->new (shift);
154			} # create_comment
155
156			## The second parameter only supports manakai extended way
157			## to specify qualified name - "[$prefix, $local_name]"
158			sub create_element_ns ($$$) {
159			my ($self, $nsuri, $qn) = @_;
160			return What::NanoDOM::Element->new ($nsuri, $qn->[0], $qn->[1]);
161			} # create_element_ns
162
163			## A manakai extension
164			sub create_document_type_definition ($$) {
165			shift;
166			return What::NanoDOM::DocumentType->new (shift);
167			} # create_document_type_definition
168
169			package What::NanoDOM::Element;
170			push our @ISA, 'What::NanoDOM::Node';
171
172			sub new ($$$$) {
173			my $self = shift->SUPER::new;
174			$self->{namespace_uri} = shift;
175			$self->{prefix} = shift;
176			$self->{local_name} = shift;
177			$self->{attributes} = {};
178			$self->{child_nodes} = [];
179			return $self;
180			} # new
181
182			sub clone_node ($$) {
183			my ($self, $deep) = @_; ## NOTE: Deep cloning is not supported
184			my $clone = bless {
185			namespace_uri => $self->{namespace_uri},
186			prefix => $self->{prefix},
187			local_name => $self->{local_name},
188			child_nodes => [],
189			}, ref $self;
190			for my $ns (keys %{$self->{attributes}}) {
191			for my $ln (keys %{$self->{attributes}->{$ns}}) {
192	wakaba	1.2	my $attr = $self->{attributes}->{$ns}->{$ln};
193	wakaba	1.1	$clone->{attributes}->{$ns}->{$ln} = bless {
194	wakaba	1.2	namespace_uri => $attr->{namespace_uri},
195			prefix => $attr->{prefix},
196			local_name => $attr->{local_name},
197			value => $attr->{value},
198	wakaba	1.1	}, ref $self->{attributes}->{$ns}->{$ln};
199			}
200			}
201			return $clone;
202			} # clone
203
204			## A manakai extension
205			sub manakai_append_text ($$) {
206			my $self = shift;
207			if (@{$self->{child_nodes}} and
208			$self->{child_nodes}->[-1]->node_type == 3) {
209			$self->{child_nodes}->[-1]->manakai_append_text (shift);
210			} else {
211			my $text = What::NanoDOM::Text->new (shift);
212			$self->append_child ($text);
213			}
214			} # manakai_append_text
215
216			sub attributes ($) {
217			my $self = shift;
218			my $r = [];
219			## Order MUST be stable
220			for my $ns (sort {$a cmp $b} keys %{$self->{attributes}}) {
221			for my $ln (sort {$a cmp $b} keys %{$self->{attributes}->{$ns}}) {
222			push @$r, $self->{attributes}->{$ns}->{$ln}
223			if defined $self->{attributes}->{$ns}->{$ln};
224			}
225			}
226			return $r;
227			} # attributes
228
229			sub node_type { 1 }
230
231			## TODO: HTML5 capitalization
232			sub tag_name ($) {
233			my $self = shift;
234			if (defined $self->{prefix}) {
235			return $self->{prefix} . ':' . $self->{local_name};
236			} else {
237			return $self->{local_name};
238			}
239			} # tag_name
240
241			sub has_attribute_ns ($$$) {
242			my ($self, $nsuri, $ln) = @_;
243			return defined $self->{attributes}->{$nsuri}->{$ln};
244			} # has_attribute_ns
245
246			## The second parameter only supports manakai extended way
247			## to specify qualified name - "[$prefix, $local_name]"
248			sub set_attribute_ns ($$$$) {
249			my ($self, $nsuri, $qn, $value) = @_;
250			$self->{attributes}->{$nsuri}->{$qn->[1]}
251			= What::NanoDOM::Attr->new ($nsuri, $qn->[0], $qn->[1], $value);
252			} # set_attribute_ns
253
254			package What::NanoDOM::Attr;
255			push our @ISA, 'What::NanoDOM::Node';
256
257			sub new ($$$$$) {
258			my $self = shift->SUPER::new;
259			$self->{namespace_uri} = shift;
260			$self->{prefix} = shift;
261			$self->{local_name} = shift;
262			$self->{value} = shift;
263			return $self;
264			} # new
265
266			sub node_type { 2 }
267
268			## TODO: HTML5 case stuff?
269			sub name ($) {
270			my $self = shift;
271			if (defined $self->{prefix}) {
272			return $self->{prefix} . ':' . $self->{local_name};
273			} else {
274			return $self->{local_name};
275			}
276			} # name
277
278			sub value ($) {
279			return shift->{value};
280			} # value
281
282			package What::NanoDOM::CharacterData;
283			push our @ISA, 'What::NanoDOM::Node';
284
285			sub new ($$) {
286			my $self = shift->SUPER::new;
287			$self->{data} = shift;
288			return $self;
289			} # new
290
291			## A manakai extension
292			sub manakai_append_text ($$) {
293			my ($self, $s) = @_;
294			$self->{data} .= $s;
295			} # manakai_append_text
296
297			sub data ($) {
298			return shift->{data};
299			} # data
300
301			package What::NanoDOM::Text;
302			push our @ISA, 'What::NanoDOM::CharacterData';
303
304			sub node_type () { 3 }
305
306			package What::NanoDOM::Comment;
307			push our @ISA, 'What::NanoDOM::CharacterData';
308
309			sub node_type () { 8 }
310
311			package What::NanoDOM::DocumentType;
312			push our @ISA, 'What::NanoDOM::Node';
313
314			sub new ($$) {
315			my $self = shift->SUPER::new;
316			$self->{name} = shift;
317			return $self;
318			} # new
319
320			sub node_type () { 10 }
321
322			sub name ($) {
323			return shift->{name};
324			} # name
325
326			1;
327	wakaba	1.2	# $Date: 2007/04/30 14:12:02 $