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

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

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}}) {
      $clone->{attributes}->{$ns}->{$ln} = bless {
        prefix => $self->{attributes}->{$ns}->{$ln}->{prefix},
        value => $self->{attributes}->{$ns}->{$ln}->{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:$
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	sub remove_child ($$) {
67	my ($self, $old_child) = @_;
68	my $parent_list = $self->{child_nodes};
69	for (0..$#$parent_list) {
70	if ($parent_list->[$_] eq $old_child) {
71	splice @$parent_list, $_, 1;
72	}
73	}
74	delete $old_child->{parent_node};
75	return $old_child;
76	} # remove_child
77
78	## NOTE: Only applied to Elements and Documents
79	sub has_child_nodes ($) {
80	return @{shift->{child_nodes}} > 0;
81	} # has_child_nodes
82
83	sub ELEMENT_NODE () { 1 }
84	sub ATTRIBUTE_NODE () { 2 }
85	sub TEXT_NODE () { 3 }
86	sub CDATA_SECTION_NODE () { 4 }
87	sub ENTITY_REFERENCE_NODE () { 5 }
88	sub ENTITY_NODE () { 6 }
89	sub PROCESSING_INSTRUCTION_NODE () { 7 }
90	sub COMMENT_NODE () { 8 }
91	sub DOCUMENT_NODE () { 9 }
92	sub DOCUMENT_TYPE_NODE () { 10 }
93	sub DOCUMENT_FRAGMENT_NODE () { 11 }
94	sub NOTATION_NODE () { 12 }
95
96	package What::NanoDOM::Document;
97	push our @ISA, 'What::NanoDOM::Node';
98
99	sub new ($) {
100	my $self = shift->SUPER::new;
101	$self->{child_nodes} = [];
102	return $self;
103	} # new
104
105	## A manakai extension
106	sub manakai_append_text ($$) {
107	my $self = shift;
108	if (@{$self->{child_nodes}} and
109	$self->{child_nodes}->[-1]->node_type == 3) {
110	$self->{child_nodes}->[-1]->manakai_append_text (shift);
111	} else {
112	my $text = $self->create_text_node (shift);
113	$self->append_child ($text);
114	}
115	} # manakai_append_text
116
117	sub node_type () { 9 }
118
119	sub strict_error_checking {
120	return 0;
121	} # strict_error_checking
122
123	sub create_text_node ($$) {
124	shift;
125	return What::NanoDOM::Text->new (shift);
126	} # create_text_node
127
128	sub create_comment ($$) {
129	shift;
130	return What::NanoDOM::Comment->new (shift);
131	} # create_comment
132
133	## The second parameter only supports manakai extended way
134	## to specify qualified name - "[$prefix, $local_name]"
135	sub create_element_ns ($$$) {
136	my ($self, $nsuri, $qn) = @_;
137	return What::NanoDOM::Element->new ($nsuri, $qn->[0], $qn->[1]);
138	} # create_element_ns
139
140	## A manakai extension
141	sub create_document_type_definition ($$) {
142	shift;
143	return What::NanoDOM::DocumentType->new (shift);
144	} # create_document_type_definition
145
146	package What::NanoDOM::Element;
147	push our @ISA, 'What::NanoDOM::Node';
148
149	sub new ($$$$) {
150	my $self = shift->SUPER::new;
151	$self->{namespace_uri} = shift;
152	$self->{prefix} = shift;
153	$self->{local_name} = shift;
154	$self->{attributes} = {};
155	$self->{child_nodes} = [];
156	return $self;
157	} # new
158
159	sub clone_node ($$) {
160	my ($self, $deep) = @_; ## NOTE: Deep cloning is not supported
161	my $clone = bless {
162	namespace_uri => $self->{namespace_uri},
163	prefix => $self->{prefix},
164	local_name => $self->{local_name},
165	child_nodes => [],
166	}, ref $self;
167	for my $ns (keys %{$self->{attributes}}) {
168	for my $ln (keys %{$self->{attributes}->{$ns}}) {
169	$clone->{attributes}->{$ns}->{$ln} = bless {
170	prefix => $self->{attributes}->{$ns}->{$ln}->{prefix},
171	value => $self->{attributes}->{$ns}->{$ln}->{value},
172	}, ref $self->{attributes}->{$ns}->{$ln};
173	}
174	}
175	return $clone;
176	} # clone
177
178	## A manakai extension
179	sub manakai_append_text ($$) {
180	my $self = shift;
181	if (@{$self->{child_nodes}} and
182	$self->{child_nodes}->[-1]->node_type == 3) {
183	$self->{child_nodes}->[-1]->manakai_append_text (shift);
184	} else {
185	my $text = What::NanoDOM::Text->new (shift);
186	$self->append_child ($text);
187	}
188	} # manakai_append_text
189
190	sub attributes ($) {
191	my $self = shift;
192	my $r = [];
193	## Order MUST be stable
194	for my $ns (sort {$a cmp $b} keys %{$self->{attributes}}) {
195	for my $ln (sort {$a cmp $b} keys %{$self->{attributes}->{$ns}}) {
196	push @$r, $self->{attributes}->{$ns}->{$ln}
197	if defined $self->{attributes}->{$ns}->{$ln};
198	}
199	}
200	return $r;
201	} # attributes
202
203	sub node_type { 1 }
204
205	## TODO: HTML5 capitalization
206	sub tag_name ($) {
207	my $self = shift;
208	if (defined $self->{prefix}) {
209	return $self->{prefix} . ':' . $self->{local_name};
210	} else {
211	return $self->{local_name};
212	}
213	} # tag_name
214
215	sub has_attribute_ns ($$$) {
216	my ($self, $nsuri, $ln) = @_;
217	return defined $self->{attributes}->{$nsuri}->{$ln};
218	} # has_attribute_ns
219
220	## The second parameter only supports manakai extended way
221	## to specify qualified name - "[$prefix, $local_name]"
222	sub set_attribute_ns ($$$$) {
223	my ($self, $nsuri, $qn, $value) = @_;
224	$self->{attributes}->{$nsuri}->{$qn->[1]}
225	= What::NanoDOM::Attr->new ($nsuri, $qn->[0], $qn->[1], $value);
226	} # set_attribute_ns
227
228	package What::NanoDOM::Attr;
229	push our @ISA, 'What::NanoDOM::Node';
230
231	sub new ($$$$$) {
232	my $self = shift->SUPER::new;
233	$self->{namespace_uri} = shift;
234	$self->{prefix} = shift;
235	$self->{local_name} = shift;
236	$self->{value} = shift;
237	return $self;
238	} # new
239
240	sub node_type { 2 }
241
242	## TODO: HTML5 case stuff?
243	sub name ($) {
244	my $self = shift;
245	if (defined $self->{prefix}) {
246	return $self->{prefix} . ':' . $self->{local_name};
247	} else {
248	return $self->{local_name};
249	}
250	} # name
251
252	sub value ($) {
253	return shift->{value};
254	} # value
255
256	package What::NanoDOM::CharacterData;
257	push our @ISA, 'What::NanoDOM::Node';
258
259	sub new ($$) {
260	my $self = shift->SUPER::new;
261	$self->{data} = shift;
262	return $self;
263	} # new
264
265	## A manakai extension
266	sub manakai_append_text ($$) {
267	my ($self, $s) = @_;
268	$self->{data} .= $s;
269	} # manakai_append_text
270
271	sub data ($) {
272	return shift->{data};
273	} # data
274
275	package What::NanoDOM::Text;
276	push our @ISA, 'What::NanoDOM::CharacterData';
277
278	sub node_type () { 3 }
279
280	package What::NanoDOM::Comment;
281	push our @ISA, 'What::NanoDOM::CharacterData';
282
283	sub node_type () { 8 }
284
285	package What::NanoDOM::DocumentType;
286	push our @ISA, 'What::NanoDOM::Node';
287
288	sub new ($$) {
289	my $self = shift->SUPER::new;
290	$self->{name} = shift;
291	return $self;
292	} # new
293
294	sub node_type () { 10 }
295
296	sub name ($) {
297	return shift->{name};
298	} # name
299
300	1;
301	# $Date:$