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	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			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:$