whatpm/Whatpm/NanoDOM.pm

=head1 NAME

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

=head1 DESCRIPTION

The C<Whatpm::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<Whatpm::HTML> module.

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

=cut

package Whatpm::NanoDOM;
use strict;

require Scalar::Util;

package Whatpm::NanoDOM::DOMImplementation;

sub create_document ($) {
  return Whatpm::NanoDOM::Document->new;
} # create_document

package Whatpm::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;
  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; ## 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 Whatpm::NanoDOM::Document;
push our @ISA, 'Whatpm::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 Whatpm::NanoDOM::Text->new (shift);
} # create_text_node

sub create_comment ($$) {
  shift;
  return Whatpm::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 Whatpm::NanoDOM::Element->new ($self, $nsuri, $qn->[0], $qn->[1]);
} # create_element_ns

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

sub implementation ($) {
  return 'Whatpm::NanoDOM::DOMImplementation';
} # implementation

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

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

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

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 = Whatpm::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 local_name ($) { # TODO: HTML5 case
  return shift->{local_name};
} # local_name

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

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]}
    = Whatpm::NanoDOM::Attr->new ($nsuri, $qn->[0], $qn->[1], $value);
} # set_attribute_ns

package Whatpm::NanoDOM::Attr;
push our @ISA, 'Whatpm::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 Whatpm::NanoDOM::CharacterData;
push our @ISA, 'Whatpm::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 Whatpm::NanoDOM::Text;
push our @ISA, 'Whatpm::NanoDOM::CharacterData';

sub node_type () { 3 }

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

sub node_type () { 8 }

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