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.20 $=~/\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 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};
}

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

=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: 2008/03/20 03:37:19 $
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	wakaba	1.21	our $VERSION=do{my @r=(q$Revision: 1.20 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18	wakaba	1.1
19	wakaba	1.3	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	wakaba	1.2	package Whatpm::NanoDOM::Node;
28	wakaba	1.1
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	wakaba	1.4	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	wakaba	1.1	sub child_nodes ($) {
53	wakaba	1.7	return shift->{child_nodes} \|\| [];
54	wakaba	1.1	} # 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	wakaba	1.3	$new_child->{parent_node} = $self;
69			Scalar::Util::weaken ($new_child->{parent_node});
70	wakaba	1.1	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	wakaba	1.5	$new_child->{parent_node} = $self;
95			Scalar::Util::weaken ($new_child->{parent_node});
96	wakaba	1.1	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	wakaba	1.8	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	wakaba	1.1	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	wakaba	1.6	sub prefix ($;$) {
146			my $self = shift;
147			if (@_) {
148			$self->{prefix} = shift;
149			}
150			return $self->{prefix};
151			} # prefix
152
153	wakaba	1.18	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	wakaba	1.1	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	wakaba	1.2	package Whatpm::NanoDOM::Document;
175			push our @ISA, 'Whatpm::NanoDOM::Node';
176	wakaba	1.1
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	wakaba	1.2	return Whatpm::NanoDOM::Text->new (shift);
204	wakaba	1.1	} # create_text_node
205
206			sub create_comment ($$) {
207			shift;
208	wakaba	1.2	return Whatpm::NanoDOM::Comment->new (shift);
209	wakaba	1.1	} # create_comment
210
211			## The second parameter only supports manakai extended way
212			## to specify qualified name - "[$prefix, $local_name]"
213	wakaba	1.20	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	wakaba	1.1	sub create_element_ns ($$$) {
225			my ($self, $nsuri, $qn) = @_;
226	wakaba	1.3	return Whatpm::NanoDOM::Element->new ($self, $nsuri, $qn->[0], $qn->[1]);
227	wakaba	1.1	} # create_element_ns
228
229			## A manakai extension
230			sub create_document_type_definition ($$) {
231			shift;
232	wakaba	1.2	return Whatpm::NanoDOM::DocumentType->new (shift);
233	wakaba	1.1	} # create_document_type_definition
234
235	wakaba	1.3	sub implementation ($) {
236			return 'Whatpm::NanoDOM::DOMImplementation';
237			} # implementation
238
239	wakaba	1.4	sub document_element ($) {
240			my $self = shift;
241			for (@{$self->child_nodes}) {
242			if ($_->node_type == 1) {
243			return $_;
244			}
245			}
246			return undef;
247			} # document_element
248
249	wakaba	1.21	sub dom_config ($) {
250			return {};
251			} # dom_config
252
253	wakaba	1.12	sub adopt_node ($$) {
254	wakaba	1.11	my @node = ($_[1]);
255			while (@node) {
256			my $node = shift @node;
257			$node->{owner_document} = $_[0];
258			Scalar::Util::weaken ($node->{owner_document});
259			push @node, @{$node->child_nodes};
260			push @node, @{$node->attributes or []} if $node->can ('attributes');
261			}
262			return $_[1];
263			} # adopt_node
264
265	wakaba	1.12	sub manakai_is_html ($;$) {
266			if (@_ > 1) {
267			if ($_[1]) {
268			$_[0]->{manakai_is_html} = 1;
269			} else {
270	wakaba	1.13	delete $_[0]->{manakai_is_html};
271	wakaba	1.12	delete $_[0]->{manakai_compat_mode};
272			}
273			}
274			return $_[0]->{manakai_is_html};
275			} # manakai_is_html
276
277			sub compat_mode ($) {
278			if ($_[0]->{manakai_is_html}) {
279			if ($_[0]->{manakai_compat_mode} eq 'quirks') {
280			return 'BackCompat';
281			}
282			}
283			return 'CSS1Compat';
284			} # compat_mode
285
286			sub manakai_compat_mode ($;$) {
287			if ($_[0]->{manakai_is_html}) {
288			if (@_ > 1 and defined $_[1] and
289			{'no quirks' => 1, 'limited quirks' => 1, 'quirks' => 1}->{$_[1]}) {
290			$_[0]->{manakai_compat_mode} = $_[1];
291			}
292			return $_[0]->{manakai_compat_mode} \|\| 'no quirks';
293			} else {
294			return 'no quirks';
295			}
296			} # manakai_compat_mode
297
298	wakaba	1.19	sub manakai_head ($) {
299			my $html = $_[0]->manakai_html;
300			return undef unless defined $html;
301			for my $el (@{$html->child_nodes}) {
302			next unless $el->node_type == 1; # ELEMENT_NODE
303			my $nsuri = $el->namespace_uri;
304			next unless defined $nsuri;
305			next unless $nsuri eq q<http://www.w3.org/1999/xhtml>;
306			next unless $el->manakai_local_name eq 'head';
307			return $el;
308			}
309			return undef;
310			} # manakai_head
311
312			sub manakai_html ($) {
313			my $de = $_[0]->document_element;
314			my $nsuri = $de->namespace_uri;
315			if (defined $nsuri and $nsuri eq q<http://www.w3.org/1999/xhtml> and
316			$de->manakai_local_name eq 'html') {
317			return $de;
318			} else {
319			return undef;
320			}
321			} # manakai_html
322
323	wakaba	1.17	sub input_encoding ($;$) {
324			$_[0]->{input_encoding} = $_[1] if @_ > 1;
325			return $_[0]->{input_encoding};
326			}
327
328			sub manakai_charset ($;$) {
329			$_[0]->{manakai_charset} = $_[1] if @_ > 1;
330			return $_[0]->{manakai_charset};
331			}
332
333			sub manakai_has_bom ($;$) {
334			$_[0]->{manakai_has_bom} = $_[1] if @_ > 1;
335			return $_[0]->{manakai_has_bom};
336			}
337
338	wakaba	1.2	package Whatpm::NanoDOM::Element;
339			push our @ISA, 'Whatpm::NanoDOM::Node';
340	wakaba	1.1
341	wakaba	1.3	sub new ($$$$$) {
342	wakaba	1.1	my $self = shift->SUPER::new;
343	wakaba	1.3	$self->{owner_document} = shift;
344			Scalar::Util::weaken ($self->{owner_document});
345	wakaba	1.1	$self->{namespace_uri} = shift;
346			$self->{prefix} = shift;
347			$self->{local_name} = shift;
348			$self->{attributes} = {};
349			$self->{child_nodes} = [];
350			return $self;
351			} # new
352
353	wakaba	1.3	sub owner_document ($) {
354			return shift->{owner_document};
355			} # owner_document
356
357	wakaba	1.1	sub clone_node ($$) {
358			my ($self, $deep) = @_; ## NOTE: Deep cloning is not supported
359			my $clone = bless {
360			namespace_uri => $self->{namespace_uri},
361			prefix => $self->{prefix},
362			local_name => $self->{local_name},
363			child_nodes => [],
364			}, ref $self;
365			for my $ns (keys %{$self->{attributes}}) {
366			for my $ln (keys %{$self->{attributes}->{$ns}}) {
367			my $attr = $self->{attributes}->{$ns}->{$ln};
368			$clone->{attributes}->{$ns}->{$ln} = bless {
369			namespace_uri => $attr->{namespace_uri},
370			prefix => $attr->{prefix},
371			local_name => $attr->{local_name},
372			value => $attr->{value},
373			}, ref $self->{attributes}->{$ns}->{$ln};
374			}
375			}
376			return $clone;
377			} # clone
378
379			## A manakai extension
380			sub manakai_append_text ($$) {
381			my $self = shift;
382			if (@{$self->{child_nodes}} and
383			$self->{child_nodes}->[-1]->node_type == 3) {
384			$self->{child_nodes}->[-1]->manakai_append_text (shift);
385			} else {
386	wakaba	1.2	my $text = Whatpm::NanoDOM::Text->new (shift);
387	wakaba	1.1	$self->append_child ($text);
388			}
389			} # manakai_append_text
390
391	wakaba	1.7	sub text_content ($) {
392			my $self = shift;
393			my $r = '';
394			for my $child (@{$self->child_nodes}) {
395			if ($child->can ('data')) {
396			$r .= $child->data;
397			} else {
398			$r .= $child->text_content;
399			}
400			}
401			return $r;
402			} # text_content
403
404	wakaba	1.1	sub attributes ($) {
405			my $self = shift;
406			my $r = [];
407			## Order MUST be stable
408			for my $ns (sort {$a cmp $b} keys %{$self->{attributes}}) {
409			for my $ln (sort {$a cmp $b} keys %{$self->{attributes}->{$ns}}) {
410			push @$r, $self->{attributes}->{$ns}->{$ln}
411			if defined $self->{attributes}->{$ns}->{$ln};
412			}
413			}
414			return $r;
415			} # attributes
416
417	wakaba	1.3	sub local_name ($) { # TODO: HTML5 case
418			return shift->{local_name};
419			} # local_name
420
421	wakaba	1.4	sub manakai_local_name ($) {
422			return shift->{local_name}; # no case fixing for HTML5
423			} # manakai_local_name
424
425	wakaba	1.3	sub namespace_uri ($) {
426			return shift->{namespace_uri};
427			} # namespace_uri
428
429	wakaba	1.4	sub manakai_element_type_match ($$$) {
430			my ($self, $nsuri, $ln) = @_;
431			if (defined $nsuri) {
432			if (defined $self->{namespace_uri} and $nsuri eq $self->{namespace_uri}) {
433			return ($ln eq $self->{local_name});
434			} else {
435			return 0;
436			}
437			} else {
438			if (not defined $self->{namespace_uri}) {
439			return ($ln eq $self->{local_name});
440			} else {
441			return 0;
442			}
443			}
444			} # manakai_element_type_match
445
446	wakaba	1.1	sub node_type { 1 }
447
448			## TODO: HTML5 capitalization
449			sub tag_name ($) {
450			my $self = shift;
451			if (defined $self->{prefix}) {
452			return $self->{prefix} . ':' . $self->{local_name};
453			} else {
454			return $self->{local_name};
455			}
456			} # tag_name
457
458	wakaba	1.8	sub get_attribute_ns ($$$) {
459			my ($self, $nsuri, $ln) = @_;
460			$nsuri = '' unless defined $nsuri;
461			return defined $self->{attributes}->{$nsuri}->{$ln}
462			? $self->{attributes}->{$nsuri}->{$ln}->value : undef;
463			} # get_attribute_ns
464
465	wakaba	1.9	sub get_attribute_node_ns ($$$) {
466			my ($self, $nsuri, $ln) = @_;
467			$nsuri = '' unless defined $nsuri;
468			return $self->{attributes}->{$nsuri}->{$ln};
469			} # get_attribute_node_ns
470
471	wakaba	1.1	sub has_attribute_ns ($$$) {
472			my ($self, $nsuri, $ln) = @_;
473	wakaba	1.8	$nsuri = '' unless defined $nsuri;
474	wakaba	1.1	return defined $self->{attributes}->{$nsuri}->{$ln};
475			} # has_attribute_ns
476
477			## The second parameter only supports manakai extended way
478			## to specify qualified name - "[$prefix, $local_name]"
479			sub set_attribute_ns ($$$$) {
480			my ($self, $nsuri, $qn, $value) = @_;
481			$self->{attributes}->{$nsuri}->{$qn->[1]}
482	wakaba	1.5	= Whatpm::NanoDOM::Attr->new ($self, $nsuri, $qn->[0], $qn->[1], $value);
483	wakaba	1.1	} # set_attribute_ns
484
485	wakaba	1.20	sub set_attribute_node_ns ($$) {
486			my $self = shift;
487			my $attr = shift;
488			$self->{attributes}->{$attr->namespace_uri}->{$attr->manakai_local_name}
489			= $attr;
490			$attr->{owner_element} = $self;
491			Scalar::Util::weaken ($attr->{owner_element});
492			} # set_attribute_node_ns
493
494	wakaba	1.2	package Whatpm::NanoDOM::Attr;
495			push our @ISA, 'Whatpm::NanoDOM::Node';
496	wakaba	1.1
497	wakaba	1.5	sub new ($$$$$$) {
498	wakaba	1.1	my $self = shift->SUPER::new;
499	wakaba	1.5	$self->{owner_element} = shift;
500			Scalar::Util::weaken ($self->{owner_element});
501	wakaba	1.1	$self->{namespace_uri} = shift;
502			$self->{prefix} = shift;
503			$self->{local_name} = shift;
504			$self->{value} = shift;
505			return $self;
506			} # new
507
508	wakaba	1.5	sub namespace_uri ($) {
509			return shift->{namespace_uri};
510			} # namespace_uri
511
512			sub manakai_local_name ($) {
513			return shift->{local_name};
514			} # manakai_local_name
515
516	wakaba	1.1	sub node_type { 2 }
517
518	wakaba	1.14	sub owner_document ($) {
519			return shift->owner_element->owner_document;
520			} # owner_document
521
522	wakaba	1.1	## TODO: HTML5 case stuff?
523			sub name ($) {
524			my $self = shift;
525			if (defined $self->{prefix}) {
526			return $self->{prefix} . ':' . $self->{local_name};
527			} else {
528			return $self->{local_name};
529			}
530			} # name
531
532	wakaba	1.20	sub value ($;$) {
533			if (@_ > 1) {
534			$_[0]->{value} = $_[1];
535			}
536	wakaba	1.1	return shift->{value};
537			} # value
538
539	wakaba	1.5	sub owner_element ($) {
540			return shift->{owner_element};
541			} # owner_element
542
543	wakaba	1.2	package Whatpm::NanoDOM::CharacterData;
544			push our @ISA, 'Whatpm::NanoDOM::Node';
545	wakaba	1.1
546			sub new ($$) {
547			my $self = shift->SUPER::new;
548			$self->{data} = shift;
549			return $self;
550			} # new
551
552			## A manakai extension
553			sub manakai_append_text ($$) {
554			my ($self, $s) = @_;
555			$self->{data} .= $s;
556			} # manakai_append_text
557
558			sub data ($) {
559			return shift->{data};
560			} # data
561
562	wakaba	1.2	package Whatpm::NanoDOM::Text;
563			push our @ISA, 'Whatpm::NanoDOM::CharacterData';
564	wakaba	1.1
565			sub node_type () { 3 }
566
567	wakaba	1.2	package Whatpm::NanoDOM::Comment;
568			push our @ISA, 'Whatpm::NanoDOM::CharacterData';
569	wakaba	1.1
570			sub node_type () { 8 }
571
572	wakaba	1.2	package Whatpm::NanoDOM::DocumentType;
573			push our @ISA, 'Whatpm::NanoDOM::Node';
574	wakaba	1.1
575			sub new ($$) {
576			my $self = shift->SUPER::new;
577			$self->{name} = shift;
578			return $self;
579			} # new
580
581			sub node_type () { 10 }
582
583			sub name ($) {
584			return shift->{name};
585			} # name
586
587	wakaba	1.16	sub public_id ($;$) {
588			$_[0]->{public_id} = $_[1] if @_ > 1;
589			return $_[0]->{public_id};
590			} # public_id
591
592			sub system_id ($;$) {
593			$_[0]->{system_id} = $_[1] if @_ > 1;
594			return $_[0]->{system_id};
595			} # system_id
596
597	wakaba	1.1	=head1 SEE ALSO
598
599	wakaba	1.2	L<Whatpm::HTML>
600	wakaba	1.1
601			=head1 AUTHOR
602
603			Wakaba <w@suika.fam.cx>.
604
605			=head1 LICENSE
606
607			Copyright 2007 Wakaba <w@suika.fam.cx>
608
609			This library is free software; you can redistribute it
610			and/or modify it under the same terms as Perl itself.
611
612			=cut
613
614			1;
615	wakaba	1.21	# $Date: 2008/03/20 03:37:19 $