whatpm/Whatpm/NanoDOM.pm

=head1 NAME

What::NanoDOM - A Non-Conforming Implementation of DOM Subset

=head1 DESCRIPTION

The C<What::NanoDOM> module contains a non-conforming implementation
of a subset of DOM.  It is the intention that this module is
used only for the purpose of testing the C<What::HTML> module.

See source code if you would like to know what it does.

=cut

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

=head1 SEE ALSO

L<What::HTML>

=head1 AUTHOR

Wakaba <w@suika.fam.cx>.

=head1 LICENSE

Copyright 2007 Wakaba <w@suika.fam.cx>

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

=cut

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