whatpm/What/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	=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 $