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;
our $VERSION=do{my @r=(q$Revision: 1.21 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

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 parent_node ($) {
  return shift->{parent_node};
} # parent_node

sub manakai_parent_element ($) {
  my $self = shift;
  my $parent = $self->{parent_node};
  while (defined $parent) {
    if ($parent->node_type == 1) {
      return $parent;
    } else {
      $parent = $parent->{parent_node};
    }
  }
  return undef;
} # manakai_parent_element

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;
  Scalar::Util::weaken ($new_child->{parent_node});
  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 first_child ($) {
  my $self = shift;
  return $self->{child_nodes}->[0];
} # first_child

## 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 prefix ($;$) {
  my $self = shift;
  if (@_) {
    $self->{prefix} = shift;
  }
  return $self->{prefix};
} # prefix

sub get_user_data ($$) {
  return $_[0]->{$_[1]};
} # get_user_data

sub set_user_data ($$;$$) {
  $_[0]->{$_[1]} = $_[2];
} # set_user_data

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_attribute_ns ($$$) {
  my ($self, $nsuri, $qn) = @_;
  return Whatpm::NanoDOM::Attr->new (undef, $nsuri, $qn->[0], $qn->[1], '');

  ## NOTE: Created attribute node should be set to an element node
  ## as far as possible.  |onwer_document| of the attribute node, for
  ## example, depends on the definedness of the |owner_element| attribute.
} # create_attribute_ns

## 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 create_processing_instruction ($$$) {
  return Whatpm::NanoDOM::ProcessingInstruction->new (@_);
} # creat_processing_instruction

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

sub document_element ($) {
  my $self = shift;
  for (@{$self->child_nodes}) {
    if ($_->node_type == 1) {
      return $_;
    }
  }
  return undef;
} # document_element

sub dom_config ($) {
  return {};
} # dom_config

sub adopt_node ($$) {
  my @node = ($_[1]);
  while (@node) {
    my $node = shift @node;
    $node->{owner_document} = $_[0];
    Scalar::Util::weaken ($node->{owner_document});
    push @node, @{$node->child_nodes};
    push @node, @{$node->attributes or []} if $node->can ('attributes');
  }
  return $_[1];
} # adopt_node

sub manakai_is_html ($;$) {
  if (@_ > 1) {
    if ($_[1]) {
      $_[0]->{manakai_is_html} = 1;
    } else {
      delete $_[0]->{manakai_is_html};
      delete $_[0]->{manakai_compat_mode};
    }
  }
  return $_[0]->{manakai_is_html};
} # manakai_is_html

sub compat_mode ($) {
  if ($_[0]->{manakai_is_html}) {
    if ($_[0]->{manakai_compat_mode} eq 'quirks') {
      return 'BackCompat';
    }
  }
  return 'CSS1Compat';
} # compat_mode

sub manakai_compat_mode ($;$) {
  if ($_[0]->{manakai_is_html}) {
    if (@_ > 1 and defined $_[1] and
        {'no quirks' => 1, 'limited quirks' => 1, 'quirks' => 1}->{$_[1]}) {
      $_[0]->{manakai_compat_mode} = $_[1];
    }
    return $_[0]->{manakai_compat_mode} || 'no quirks';
  } else {
    return 'no quirks';
  }
} # manakai_compat_mode

sub manakai_head ($) {
  my $html = $_[0]->manakai_html;
  return undef unless defined $html;
  for my $el (@{$html->child_nodes}) {
    next unless $el->node_type == 1; # ELEMENT_NODE
    my $nsuri = $el->namespace_uri;
    next unless defined $nsuri;
    next unless $nsuri eq q<http://www.w3.org/1999/xhtml>;
    next unless $el->manakai_local_name eq 'head';
    return $el;
  }
  return undef;
} # manakai_head

sub manakai_html ($) {
  my $de = $_[0]->document_element;
  my $nsuri = $de->namespace_uri;
  if (defined $nsuri and $nsuri eq q<http://www.w3.org/1999/xhtml> and
      $de->manakai_local_name eq 'html') {
    return $de;
  } else {
    return undef;
  }
} # manakai_html

sub input_encoding ($;$) {
  $_[0]->{input_encoding} = $_[1] if @_ > 1;
  return $_[0]->{input_encoding};
}

sub manakai_charset ($;$) {
  $_[0]->{manakai_charset} = $_[1] if @_ > 1;
  return $_[0]->{manakai_charset};
}

sub manakai_has_bom ($;$) {
  $_[0]->{manakai_has_bom} = $_[1] if @_ > 1;
  return $_[0]->{manakai_has_bom};
}

sub xml_version ($;$) {
  $_[0]->{xml_version} = $_[1] if @_ > 1;
  return $_[0]->{xml_version};
}

sub xml_encoding ($;$) {
  $_[0]->{xml_encoding} = $_[1] if @_ > 1;
  return $_[0]->{xml_encoding};
}

sub xml_standalone ($;$) {
  $_[0]->{xml_standalone} = $_[1] if @_ > 1;
  return $_[0]->{xml_standalone};
}

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 text_content ($) {
  my $self = shift;
  my $r = '';
  for my $child (@{$self->child_nodes}) {
    if ($child->can ('data')) {
      $r .= $child->data;
    } else {
      $r .= $child->text_content;
    }
  }
  return $r;
} # text_content

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 manakai_local_name ($) {
  return shift->{local_name}; # no case fixing for HTML5
} # manakai_local_name

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

sub manakai_element_type_match ($$$) {
  my ($self, $nsuri, $ln) = @_;
  if (defined $nsuri) {
    if (defined $self->{namespace_uri} and $nsuri eq $self->{namespace_uri}) {
      return ($ln eq $self->{local_name});
    } else {
      return 0;
    }
  } else {
    if (not defined $self->{namespace_uri}) {
      return ($ln eq $self->{local_name});
    } else {
      return 0;
    }
  }
} # manakai_element_type_match

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 get_attribute_ns ($$$) {
  my ($self, $nsuri, $ln) = @_;
  $nsuri = '' unless defined $nsuri;
  return defined $self->{attributes}->{$nsuri}->{$ln}
    ? $self->{attributes}->{$nsuri}->{$ln}->value : undef;
} # get_attribute_ns

sub get_attribute_node_ns ($$$) {
  my ($self, $nsuri, $ln) = @_;
  $nsuri = '' unless defined $nsuri;
  return $self->{attributes}->{$nsuri}->{$ln};
} # get_attribute_node_ns

sub has_attribute_ns ($$$) {
  my ($self, $nsuri, $ln) = @_;
  $nsuri = '' unless defined $nsuri;
  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 ($self, $nsuri, $qn->[0], $qn->[1], $value);
} # set_attribute_ns

sub set_attribute_node_ns ($$) {
  my $self = shift;
  my $attr = shift;
  $self->{attributes}->{$attr->namespace_uri}->{$attr->manakai_local_name}
      = $attr;
  $attr->{owner_element} = $self;
  Scalar::Util::weaken ($attr->{owner_element});
} # set_attribute_node_ns

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

sub new ($$$$$$) {
  my $self = shift->SUPER::new;
  $self->{owner_element} = shift;
  Scalar::Util::weaken ($self->{owner_element});
  $self->{namespace_uri} = shift;
  $self->{prefix} = shift;
  $self->{local_name} = shift;
  $self->{value} = shift;
  return $self;
} # new

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

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

sub node_type { 2 }

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

## 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 ($;$) {
  if (@_ > 1) {
    $_[0]->{value} = $_[1];
  }
  return shift->{value};
} # value

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

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

sub public_id ($;$) {
  $_[0]->{public_id} = $_[1] if @_ > 1;
  return $_[0]->{public_id};
} # public_id

sub system_id ($;$) {
  $_[0]->{system_id} = $_[1] if @_ > 1;
  return $_[0]->{system_id};
} # system_id

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

sub new ($$$$) {
  my $self = shift->SUPER::new;
  shift;
#  $self->{owner_document} = shift;
#  Scalar::Util::weaken ($self->{owner_document});
  $self->{target} = shift;
  $self->{data} = shift;
  return $self;
} # new

sub node_type () { 7 }

sub target ($) {
  return $_[0]->{target};
} # target

sub data ($;$) {
  $_[0]->{data} = $_[1] if @_ > 1;
  return $_[0]->{data};
} # data

=head1 SEE ALSO

L<Whatpm::HTML|Whatpm::HTML>

L<Whatpm::XML::Parser|Whatpm::XML::Parser>

L<Whatpm::ContentChecker|Whatpm::ContentChecker>

=head1 AUTHOR

Wakaba <[email protected]>.

=head1 LICENSE

Copyright 2007-2008 Wakaba <[email protected]>

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

=cut

1;
# $Date: 2008/10/14 09:00:57 $
1	=head1 NAME
2
3	Whatpm::NanoDOM - A Non-Conforming Implementation of DOM Subset
4
5	=head1 DESCRIPTION
6
7	The C<Whatpm::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<Whatpm::HTML> module.
10
11	See source code if you would like to know what it does.
12
13	=cut
14
15	package Whatpm::NanoDOM;
16	use strict;
17	our $VERSION=do{my @r=(q$Revision: 1.21 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18
19	require Scalar::Util;
20
21	package Whatpm::NanoDOM::DOMImplementation;
22
23	sub create_document ($) {
24	return Whatpm::NanoDOM::Document->new;
25	} # create_document
26
27	package Whatpm::NanoDOM::Node;
28
29	sub new ($) {
30	my $class = shift;
31	my $self = bless {}, $class;
32	return $self;
33	} # new
34
35	sub parent_node ($) {
36	return shift->{parent_node};
37	} # parent_node
38
39	sub manakai_parent_element ($) {
40	my $self = shift;
41	my $parent = $self->{parent_node};
42	while (defined $parent) {
43	if ($parent->node_type == 1) {
44	return $parent;
45	} else {
46	$parent = $parent->{parent_node};
47	}
48	}
49	return undef;
50	} # manakai_parent_element
51
52	sub child_nodes ($) {
53	return shift->{child_nodes} \|\| [];
54	} # child_nodes
55
56	## NOTE: Only applied to Elements and Documents
57	sub append_child ($$) {
58	my ($self, $new_child) = @_;
59	if (defined $new_child->{parent_node}) {
60	my $parent_list = $new_child->{parent_node}->{child_nodes};
61	for (0..$#$parent_list) {
62	if ($parent_list->[$_] eq $new_child) {
63	splice @$parent_list, $_, 1;
64	}
65	}
66	}
67	push @{$self->{child_nodes}}, $new_child;
68	$new_child->{parent_node} = $self;
69	Scalar::Util::weaken ($new_child->{parent_node});
70	return $new_child;
71	} # append_child
72
73	## NOTE: Only applied to Elements and Documents
74	sub insert_before ($$;$) {
75	my ($self, $new_child, $ref_child) = @_;
76	if (defined $new_child->{parent_node}) {
77	my $parent_list = $new_child->{parent_node}->{child_nodes};
78	for (0..$#$parent_list) {
79	if ($parent_list->[$_] eq $new_child) {
80	splice @$parent_list, $_, 1;
81	}
82	}
83	}
84	my $i = @{$self->{child_nodes}};
85	if (defined $ref_child) {
86	for (0..$#{$self->{child_nodes}}) {
87	if ($self->{child_nodes}->[$_] eq $ref_child) {
88	$i = $_;
89	last;
90	}
91	}
92	}
93	splice @{$self->{child_nodes}}, $i, 0, $new_child;
94	$new_child->{parent_node} = $self;
95	Scalar::Util::weaken ($new_child->{parent_node});
96	return $new_child;
97	} # insert_before
98
99	## NOTE: Only applied to Elements and Documents
100	sub remove_child ($$) {
101	my ($self, $old_child) = @_;
102	my $parent_list = $self->{child_nodes};
103	for (0..$#$parent_list) {
104	if ($parent_list->[$_] eq $old_child) {
105	splice @$parent_list, $_, 1;
106	}
107	}
108	delete $old_child->{parent_node};
109	return $old_child;
110	} # remove_child
111
112	## NOTE: Only applied to Elements and Documents
113	sub has_child_nodes ($) {
114	return @{shift->{child_nodes}} > 0;
115	} # has_child_nodes
116
117	## NOTE: Only applied to Elements and Documents
118	sub first_child ($) {
119	my $self = shift;
120	return $self->{child_nodes}->[0];
121	} # first_child
122
123	## NOTE: Only applied to Elements and Documents
124	sub last_child ($) {
125	my $self = shift;
126	return @{$self->{child_nodes}} ? $self->{child_nodes}->[-1] : undef;
127	} # last_child
128
129	## NOTE: Only applied to Elements and Documents
130	sub previous_sibling ($) {
131	my $self = shift;
132	my $parent = $self->{parent_node};
133	return undef unless defined $parent;
134	my $r;
135	for (@{$parent->{child_nodes}}) {
136	if ($_ eq $self) {
137	return $r;
138	} else {
139	$r = $_;
140	}
141	}
142	return undef;
143	} # previous_sibling
144
145	sub prefix ($;$) {
146	my $self = shift;
147	if (@_) {
148	$self->{prefix} = shift;
149	}
150	return $self->{prefix};
151	} # prefix
152
153	sub get_user_data ($$) {
154	return $_[0]->{$_[1]};
155	} # get_user_data
156
157	sub set_user_data ($$;$$) {
158	$_[0]->{$_[1]} = $_[2];
159	} # set_user_data
160
161	sub ELEMENT_NODE () { 1 }
162	sub ATTRIBUTE_NODE () { 2 }
163	sub TEXT_NODE () { 3 }
164	sub CDATA_SECTION_NODE () { 4 }
165	sub ENTITY_REFERENCE_NODE () { 5 }
166	sub ENTITY_NODE () { 6 }
167	sub PROCESSING_INSTRUCTION_NODE () { 7 }
168	sub COMMENT_NODE () { 8 }
169	sub DOCUMENT_NODE () { 9 }
170	sub DOCUMENT_TYPE_NODE () { 10 }
171	sub DOCUMENT_FRAGMENT_NODE () { 11 }
172	sub NOTATION_NODE () { 12 }
173
174	package Whatpm::NanoDOM::Document;
175	push our @ISA, 'Whatpm::NanoDOM::Node';
176
177	sub new ($) {
178	my $self = shift->SUPER::new;
179	$self->{child_nodes} = [];
180	return $self;
181	} # new
182
183	## A manakai extension
184	sub manakai_append_text ($$) {
185	my $self = shift;
186	if (@{$self->{child_nodes}} and
187	$self->{child_nodes}->[-1]->node_type == 3) {
188	$self->{child_nodes}->[-1]->manakai_append_text (shift);
189	} else {
190	my $text = $self->create_text_node (shift);
191	$self->append_child ($text);
192	}
193	} # manakai_append_text
194
195	sub node_type () { 9 }
196
197	sub strict_error_checking {
198	return 0;
199	} # strict_error_checking
200
201	sub create_text_node ($$) {
202	shift;
203	return Whatpm::NanoDOM::Text->new (shift);
204	} # create_text_node
205
206	sub create_comment ($$) {
207	shift;
208	return Whatpm::NanoDOM::Comment->new (shift);
209	} # create_comment
210
211	## The second parameter only supports manakai extended way
212	## to specify qualified name - "[$prefix, $local_name]"
213	sub create_attribute_ns ($$$) {
214	my ($self, $nsuri, $qn) = @_;
215	return Whatpm::NanoDOM::Attr->new (undef, $nsuri, $qn->[0], $qn->[1], '');
216
217	## NOTE: Created attribute node should be set to an element node
218	## as far as possible. \|onwer_document\| of the attribute node, for
219	## example, depends on the definedness of the \|owner_element\| attribute.
220	} # create_attribute_ns
221
222	## The second parameter only supports manakai extended way
223	## to specify qualified name - "[$prefix, $local_name]"
224	sub create_element_ns ($$$) {
225	my ($self, $nsuri, $qn) = @_;
226	return Whatpm::NanoDOM::Element->new ($self, $nsuri, $qn->[0], $qn->[1]);
227	} # create_element_ns
228
229	## A manakai extension
230	sub create_document_type_definition ($$) {
231	shift;
232	return Whatpm::NanoDOM::DocumentType->new (shift);
233	} # create_document_type_definition
234
235	sub create_processing_instruction ($$$) {
236	return Whatpm::NanoDOM::ProcessingInstruction->new (@_);
237	} # creat_processing_instruction
238
239	sub implementation ($) {
240	return 'Whatpm::NanoDOM::DOMImplementation';
241	} # implementation
242
243	sub document_element ($) {
244	my $self = shift;
245	for (@{$self->child_nodes}) {
246	if ($_->node_type == 1) {
247	return $_;
248	}
249	}
250	return undef;
251	} # document_element
252
253	sub dom_config ($) {
254	return {};
255	} # dom_config
256
257	sub adopt_node ($$) {
258	my @node = ($_[1]);
259	while (@node) {
260	my $node = shift @node;
261	$node->{owner_document} = $_[0];
262	Scalar::Util::weaken ($node->{owner_document});
263	push @node, @{$node->child_nodes};
264	push @node, @{$node->attributes or []} if $node->can ('attributes');
265	}
266	return $_[1];
267	} # adopt_node
268
269	sub manakai_is_html ($;$) {
270	if (@_ > 1) {
271	if ($_[1]) {
272	$_[0]->{manakai_is_html} = 1;
273	} else {
274	delete $_[0]->{manakai_is_html};
275	delete $_[0]->{manakai_compat_mode};
276	}
277	}
278	return $_[0]->{manakai_is_html};
279	} # manakai_is_html
280
281	sub compat_mode ($) {
282	if ($_[0]->{manakai_is_html}) {
283	if ($_[0]->{manakai_compat_mode} eq 'quirks') {
284	return 'BackCompat';
285	}
286	}
287	return 'CSS1Compat';
288	} # compat_mode
289
290	sub manakai_compat_mode ($;$) {
291	if ($_[0]->{manakai_is_html}) {
292	if (@_ > 1 and defined $_[1] and
293	{'no quirks' => 1, 'limited quirks' => 1, 'quirks' => 1}->{$_[1]}) {
294	$_[0]->{manakai_compat_mode} = $_[1];
295	}
296	return $_[0]->{manakai_compat_mode} \|\| 'no quirks';
297	} else {
298	return 'no quirks';
299	}
300	} # manakai_compat_mode
301
302	sub manakai_head ($) {
303	my $html = $_[0]->manakai_html;
304	return undef unless defined $html;
305	for my $el (@{$html->child_nodes}) {
306	next unless $el->node_type == 1; # ELEMENT_NODE
307	my $nsuri = $el->namespace_uri;
308	next unless defined $nsuri;
309	next unless $nsuri eq q<http://www.w3.org/1999/xhtml>;
310	next unless $el->manakai_local_name eq 'head';
311	return $el;
312	}
313	return undef;
314	} # manakai_head
315
316	sub manakai_html ($) {
317	my $de = $_[0]->document_element;
318	my $nsuri = $de->namespace_uri;
319	if (defined $nsuri and $nsuri eq q<http://www.w3.org/1999/xhtml> and
320	$de->manakai_local_name eq 'html') {
321	return $de;
322	} else {
323	return undef;
324	}
325	} # manakai_html
326
327	sub input_encoding ($;$) {
328	$_[0]->{input_encoding} = $_[1] if @_ > 1;
329	return $_[0]->{input_encoding};
330	}
331
332	sub manakai_charset ($;$) {
333	$_[0]->{manakai_charset} = $_[1] if @_ > 1;
334	return $_[0]->{manakai_charset};
335	}
336
337	sub manakai_has_bom ($;$) {
338	$_[0]->{manakai_has_bom} = $_[1] if @_ > 1;
339	return $_[0]->{manakai_has_bom};
340	}
341
342	sub xml_version ($;$) {
343	$_[0]->{xml_version} = $_[1] if @_ > 1;
344	return $_[0]->{xml_version};
345	}
346
347	sub xml_encoding ($;$) {
348	$_[0]->{xml_encoding} = $_[1] if @_ > 1;
349	return $_[0]->{xml_encoding};
350	}
351
352	sub xml_standalone ($;$) {
353	$_[0]->{xml_standalone} = $_[1] if @_ > 1;
354	return $_[0]->{xml_standalone};
355	}
356
357	package Whatpm::NanoDOM::Element;
358	push our @ISA, 'Whatpm::NanoDOM::Node';
359
360	sub new ($$$$$) {
361	my $self = shift->SUPER::new;
362	$self->{owner_document} = shift;
363	Scalar::Util::weaken ($self->{owner_document});
364	$self->{namespace_uri} = shift;
365	$self->{prefix} = shift;
366	$self->{local_name} = shift;
367	$self->{attributes} = {};
368	$self->{child_nodes} = [];
369	return $self;
370	} # new
371
372	sub owner_document ($) {
373	return shift->{owner_document};
374	} # owner_document
375
376	sub clone_node ($$) {
377	my ($self, $deep) = @_; ## NOTE: Deep cloning is not supported
378	my $clone = bless {
379	namespace_uri => $self->{namespace_uri},
380	prefix => $self->{prefix},
381	local_name => $self->{local_name},
382	child_nodes => [],
383	}, ref $self;
384	for my $ns (keys %{$self->{attributes}}) {
385	for my $ln (keys %{$self->{attributes}->{$ns}}) {
386	my $attr = $self->{attributes}->{$ns}->{$ln};
387	$clone->{attributes}->{$ns}->{$ln} = bless {
388	namespace_uri => $attr->{namespace_uri},
389	prefix => $attr->{prefix},
390	local_name => $attr->{local_name},
391	value => $attr->{value},
392	}, ref $self->{attributes}->{$ns}->{$ln};
393	}
394	}
395	return $clone;
396	} # clone
397
398	## A manakai extension
399	sub manakai_append_text ($$) {
400	my $self = shift;
401	if (@{$self->{child_nodes}} and
402	$self->{child_nodes}->[-1]->node_type == 3) {
403	$self->{child_nodes}->[-1]->manakai_append_text (shift);
404	} else {
405	my $text = Whatpm::NanoDOM::Text->new (shift);
406	$self->append_child ($text);
407	}
408	} # manakai_append_text
409
410	sub text_content ($) {
411	my $self = shift;
412	my $r = '';
413	for my $child (@{$self->child_nodes}) {
414	if ($child->can ('data')) {
415	$r .= $child->data;
416	} else {
417	$r .= $child->text_content;
418	}
419	}
420	return $r;
421	} # text_content
422
423	sub attributes ($) {
424	my $self = shift;
425	my $r = [];
426	## Order MUST be stable
427	for my $ns (sort {$a cmp $b} keys %{$self->{attributes}}) {
428	for my $ln (sort {$a cmp $b} keys %{$self->{attributes}->{$ns}}) {
429	push @$r, $self->{attributes}->{$ns}->{$ln}
430	if defined $self->{attributes}->{$ns}->{$ln};
431	}
432	}
433	return $r;
434	} # attributes
435
436	sub local_name ($) { # TODO: HTML5 case
437	return shift->{local_name};
438	} # local_name
439
440	sub manakai_local_name ($) {
441	return shift->{local_name}; # no case fixing for HTML5
442	} # manakai_local_name
443
444	sub namespace_uri ($) {
445	return shift->{namespace_uri};
446	} # namespace_uri
447
448	sub manakai_element_type_match ($$$) {
449	my ($self, $nsuri, $ln) = @_;
450	if (defined $nsuri) {
451	if (defined $self->{namespace_uri} and $nsuri eq $self->{namespace_uri}) {
452	return ($ln eq $self->{local_name});
453	} else {
454	return 0;
455	}
456	} else {
457	if (not defined $self->{namespace_uri}) {
458	return ($ln eq $self->{local_name});
459	} else {
460	return 0;
461	}
462	}
463	} # manakai_element_type_match
464
465	sub node_type { 1 }
466
467	## TODO: HTML5 capitalization
468	sub tag_name ($) {
469	my $self = shift;
470	if (defined $self->{prefix}) {
471	return $self->{prefix} . ':' . $self->{local_name};
472	} else {
473	return $self->{local_name};
474	}
475	} # tag_name
476
477	sub get_attribute_ns ($$$) {
478	my ($self, $nsuri, $ln) = @_;
479	$nsuri = '' unless defined $nsuri;
480	return defined $self->{attributes}->{$nsuri}->{$ln}
481	? $self->{attributes}->{$nsuri}->{$ln}->value : undef;
482	} # get_attribute_ns
483
484	sub get_attribute_node_ns ($$$) {
485	my ($self, $nsuri, $ln) = @_;
486	$nsuri = '' unless defined $nsuri;
487	return $self->{attributes}->{$nsuri}->{$ln};
488	} # get_attribute_node_ns
489
490	sub has_attribute_ns ($$$) {
491	my ($self, $nsuri, $ln) = @_;
492	$nsuri = '' unless defined $nsuri;
493	return defined $self->{attributes}->{$nsuri}->{$ln};
494	} # has_attribute_ns
495
496	## The second parameter only supports manakai extended way
497	## to specify qualified name - "[$prefix, $local_name]"
498	sub set_attribute_ns ($$$$) {
499	my ($self, $nsuri, $qn, $value) = @_;
500	$self->{attributes}->{$nsuri}->{$qn->[1]}
501	= Whatpm::NanoDOM::Attr->new ($self, $nsuri, $qn->[0], $qn->[1], $value);
502	} # set_attribute_ns
503
504	sub set_attribute_node_ns ($$) {
505	my $self = shift;
506	my $attr = shift;
507	$self->{attributes}->{$attr->namespace_uri}->{$attr->manakai_local_name}
508	= $attr;
509	$attr->{owner_element} = $self;
510	Scalar::Util::weaken ($attr->{owner_element});
511	} # set_attribute_node_ns
512
513	package Whatpm::NanoDOM::Attr;
514	push our @ISA, 'Whatpm::NanoDOM::Node';
515
516	sub new ($$$$$$) {
517	my $self = shift->SUPER::new;
518	$self->{owner_element} = shift;
519	Scalar::Util::weaken ($self->{owner_element});
520	$self->{namespace_uri} = shift;
521	$self->{prefix} = shift;
522	$self->{local_name} = shift;
523	$self->{value} = shift;
524	return $self;
525	} # new
526
527	sub namespace_uri ($) {
528	return shift->{namespace_uri};
529	} # namespace_uri
530
531	sub manakai_local_name ($) {
532	return shift->{local_name};
533	} # manakai_local_name
534
535	sub node_type { 2 }
536
537	sub owner_document ($) {
538	return shift->owner_element->owner_document;
539	} # owner_document
540
541	## TODO: HTML5 case stuff?
542	sub name ($) {
543	my $self = shift;
544	if (defined $self->{prefix}) {
545	return $self->{prefix} . ':' . $self->{local_name};
546	} else {
547	return $self->{local_name};
548	}
549	} # name
550
551	sub value ($;$) {
552	if (@_ > 1) {
553	$_[0]->{value} = $_[1];
554	}
555	return shift->{value};
556	} # value
557
558	sub owner_element ($) {
559	return shift->{owner_element};
560	} # owner_element
561
562	package Whatpm::NanoDOM::CharacterData;
563	push our @ISA, 'Whatpm::NanoDOM::Node';
564
565	sub new ($$) {
566	my $self = shift->SUPER::new;
567	$self->{data} = shift;
568	return $self;
569	} # new
570
571	## A manakai extension
572	sub manakai_append_text ($$) {
573	my ($self, $s) = @_;
574	$self->{data} .= $s;
575	} # manakai_append_text
576
577	sub data ($) {
578	return shift->{data};
579	} # data
580
581	package Whatpm::NanoDOM::Text;
582	push our @ISA, 'Whatpm::NanoDOM::CharacterData';
583
584	sub node_type () { 3 }
585
586	package Whatpm::NanoDOM::Comment;
587	push our @ISA, 'Whatpm::NanoDOM::CharacterData';
588
589	sub node_type () { 8 }
590
591	package Whatpm::NanoDOM::DocumentType;
592	push our @ISA, 'Whatpm::NanoDOM::Node';
593
594	sub new ($$) {
595	my $self = shift->SUPER::new;
596	$self->{name} = shift;
597	return $self;
598	} # new
599
600	sub node_type () { 10 }
601
602	sub name ($) {
603	return shift->{name};
604	} # name
605
606	sub public_id ($;$) {
607	$_[0]->{public_id} = $_[1] if @_ > 1;
608	return $_[0]->{public_id};
609	} # public_id
610
611	sub system_id ($;$) {
612	$_[0]->{system_id} = $_[1] if @_ > 1;
613	return $_[0]->{system_id};
614	} # system_id
615
616	package Whatpm::NanoDOM::ProcessingInstruction;
617	push our @ISA, 'Whatpm::NanoDOM::Node';
618
619	sub new ($$$$) {
620	my $self = shift->SUPER::new;
621	shift;
622	# $self->{owner_document} = shift;
623	# Scalar::Util::weaken ($self->{owner_document});
624	$self->{target} = shift;
625	$self->{data} = shift;
626	return $self;
627	} # new
628
629	sub node_type () { 7 }
630
631	sub target ($) {
632	return $_[0]->{target};
633	} # target
634
635	sub data ($;$) {
636	$_[0]->{data} = $_[1] if @_ > 1;
637	return $_[0]->{data};
638	} # data
639
640	=head1 SEE ALSO
641
642	L<Whatpm::HTML\|Whatpm::HTML>
643
644	L<Whatpm::XML::Parser\|Whatpm::XML::Parser>
645
646	L<Whatpm::ContentChecker\|Whatpm::ContentChecker>
647
648	=head1 AUTHOR
649
650	Wakaba <[email protected]>.
651
652	=head1 LICENSE
653
654	Copyright 2007-2008 Wakaba <[email protected]>
655
656	This library is free software; you can redistribute it
657	and/or modify it under the same terms as Perl itself.
658
659	=cut
660
661	1;
662	# $Date: 2008/10/14 09:00:57 $