package HTML::DOM::Node;

our $VERSION = '0.016';


use strict;
use warnings;

use constant {
	ELEMENT_NODE                => 1,
	ATTRIBUTE_NODE              => 2,
	TEXT_NODE                   => 3,
	CDATA_SECTION_NODE          => 4,
	ENTITY_REFERENCE_NODE       => 5,
	ENTITY_NODE                 => 6,
	PROCESSING_INSTRUCTION_NODE => 7,
	COMMENT_NODE                => 8,
	DOCUMENT_NODE               => 9,
	DOCUMENT_TYPE_NODE          => 10,
	DOCUMENT_FRAGMENT_NODE      => 11,
	NOTATION_NODE               => 12,
};

use Carp 'croak';
use Exporter 5.57 'import';
use HTML::DOM::Event;
use HTML::DOM::Exception qw'NO_MODIFICATION_ALLOWED_ERR NOT_FOUND_ERR
                               HIERARCHY_REQUEST_ERR WRONG_DOCUMENT_ERR
                                 UNSPECIFIED_EVENT_TYPE_ERR';
use Scalar::Util qw'refaddr weaken blessed';

require HTML::DOM::Implementation;
require HTML::DOM::NodeList;
require HTML::Element;

our @ISA = 'HTML::Element'; # No, a node isn't an HTML element, but
                            # HTML::Element has some nice tree-handling
                            # methods (and, after all, TreeBuilder's
                            # pseudo-elements aren't elements either).

our @EXPORT_OK = qw'
	ELEMENT_NODE               
	ATTRIBUTE_NODE             
	TEXT_NODE                  
	CDATA_SECTION_NODE         
	ENTITY_REFERENCE_NODE      
	ENTITY_NODE                
	PROCESSING_INSTRUCTION_NODE
	COMMENT_NODE               
	DOCUMENT_NODE              
	DOCUMENT_TYPE_NODE         
	DOCUMENT_FRAGMENT_NODE     
	NOTATION_NODE              
';
our %EXPORT_TAGS = (all => \@EXPORT_OK);



=head1 NAME

HTML::DOM::Node - A Perl class for representing the nodes of an HTML DOM tree

=head1 SYNOPSIS

  use HTML::DOM::Node ':all'; # constants
  use HTML::DOM;
  $doc = HTML::DOM->new;
  $doc->isa('HTML::DOM::Node'); # true
  $doc->nodeType == DOCUMENT_NODE; # true

  $doc->firstChild;
  $doc->childNodes;
  # etc

=head1 DESCRIPTION

This is the base class for all nodes in an HTML::DOM tree. (See
L<HTML::DOM/CLASSES AND DOM INTERFACES>.) It implements the Node and 
EventTarget DOM interfaces.

=head1 METHODS

=head2 Attributes

The following DOM attributes are supported:

=over 4

=item nodeName

=item nodeType

These two are implemented not by HTML::DOM::Node itself, but by its
subclasses.

=item nodeValue

=item parentNode

=item childNodes

=item firstChild

=item lastChild

=item previousSibling

=item nextSibling

=item attributes

=item ownerDocument

=item namespaceURI

=item prefix

=item localName

Those last three always return nothing.

=back

There is also a C<_set_ownerDocument> method, which you probably do not
need to know about.

=cut

# ----------- ATTRIBUTE METHODS ------------- #

# sub nodeName {} # every subclass overrides this
# sub nodeType {} # likewise

sub nodeValue {
	if(@_ > 1) {
		die new HTML::DOM::Exception
			NO_MODIFICATION_ALLOWED_ERR,
			'Read-only node';# ~~~ only when the node is
		                                 #     readonly
	}
	return; # empty list
}

sub parentNode {
	my $p = $_[0]->parent;
	defined $p ? $p :()
}

sub childNodes {
	wantarray ? $_[0]->content_list :
		new HTML::DOM::NodeList $_[0]->content_array_ref;
}

sub firstChild {
	($_[0]->content_list)[0];
}

sub lastChild {
	($_[0]->content_list)[-1];
}

sub previousSibling {
	my $sib = scalar $_[0]->left;
	defined $sib ? $sib : ();
}

sub nextSibling {
	my $sib = scalar $_[0]->right;
	defined $sib ? $sib : ();
}

sub attributes {} # null for most nodes; overridden by Element

sub ownerDocument {
	my $self = shift;
	$$self{_HTML_DOM_Node_owner} || do {
		my $root = $self->root;
		# ~~~ I’m not sure this logic is right. I need to revisit
		#     this. Do we ever have a case in which ->root returns
		#     the wrong value? If so, can we guarantee that the
		#     ‘root’ has its _HTML_DOM_Node_owner attribute set?
		$$self{_HTML_DOM_Node_owner} = 
			$$root{_HTML_DOM_Node_owner} || $root;
		weaken $$self{_HTML_DOM_Node_owner};
		$$self{_HTML_DOM_Node_owner}
	};
}

sub _set_ownerDocument {
	$_[0]{_HTML_DOM_Node_owner} = $_[1];
	weaken $_[0]{_HTML_DOM_Node_owner};
}

*prefix = *localName = *namespaceURI = *attributes;


=head2 Other Methods

See the DOM spec. for descriptions of most of these. The first four
automatically trigger mutation events. (See L<HTML::DOM::Event::Mutation>.)

=over 4

=item insertBefore

=item replaceChild

=item removeChild

=item appendChild

=item hasChildNodes

=item cloneNode

=item normalize

=item hasAttributes

=item isSupported

=cut

# ----------- METHOD METHODS ------------- #

sub insertBefore {
	# ~~~ NO_MODIFICATION_ALLOWED_ERR is meant to be raised if the
	#     node is read-only.
	# ~~~ HIERARCHY_REQUEST_ERR is also supposed to be raised if the
	#     node type does not allow children of $new_node's type.

	my($self,$new_node,$before) = @_;

	$self->is_inside($new_node) and
		die new HTML::DOM::Exception HIERARCHY_REQUEST_ERR,
		'A node cannot be inserted into one of its descendants';

	my $doc = $new_node->ownerDocument; # not $self->... because $self
	                                    # might be the document, in
	                                    # which case its owner is null.
	$doc == $self || $doc == $self->ownerDocument or
		die new HTML::DOM::Exception WRONG_DOCUMENT_ERR,
		'The node to be inserted belongs to another document';

	my $index;
	my @kids = $self->content_list;
	if($before) { FIND_INDEX: {
		for (0..$#kids) {
			$kids[$_] == $before 
				and $index = $_, last FIND_INDEX;
		}
		die new HTML::DOM::Exception NOT_FOUND_ERR,
		'insertBefore\'s 2nd argument is not a child of this node';
	}}
	else {
		$index = @kids;
	}

	my $old_parent = $new_node->parent;
	$old_parent and $new_node->trigger_event('DOMNodeRemoved',
		rel_node => $old_parent);
	if($new_node->is_inside($doc)) {
		$_->trigger_event('DOMNodeRemovedFromDocument')
		  for $new_node, $new_node->descendants;
	}

	$self->splice_content($index, 0,
		$new_node->isa('HTML::DOM::DocumentFragment')
		? $new_node->childNodes
		: $new_node
	);

	$new_node->trigger_event('DOMNodeInserted', rel_node => $self);
	if($self->is_inside($doc)) {
		$_->trigger_event('DOMNodeInsertedIntoDocument')
		  for $new_node, $new_node->descendants;
	}
	$_->trigger_event('DOMSubtreeModified')
	  for _nearest_common_parent($old_parent, $self);

	$doc->_modified;

	$new_node;
}

sub replaceChild {
	# ~~~ NO_MODIFICATION_ALLOWED_ERR is meant to be raised if the
	#     node is read-only.
	# ~~~ HIERARCHY_REQUEST_ERR is also supposed to be raised if the
	#     node type does not allow children of $new_node's type.

	my($self,$new_node,$old_node) = @_;

	$self->is_inside($new_node) and
		die new HTML::DOM::Exception HIERARCHY_REQUEST_ERR,
		'A node cannot be inserted into one of its descendants';

	my $doc = $new_node->ownerDocument; # not $self->... because $self
	                                    # might be the document, in
	                                    # which case its owner is null.
	$doc == $self || $doc == $self->ownerDocument or
		die new HTML::DOM::Exception WRONG_DOCUMENT_ERR,
		'The node to be inserted belongs to another document';

	no warnings 'uninitialized';
	$self == $old_node->parent or
		die new HTML::DOM::Exception NOT_FOUND_ERR,
		'replaceChild\'s 2nd argument is not a child of this node';

	$old_node->trigger_event('DOMNodeRemoved',
		rel_node => $self);
	my $in_doc = $self->is_inside($doc);
	if($in_doc) {
		$_->trigger_event('DOMNodeRemovedFromDocument')
		  for $old_node, $old_node->descendants;
	}
	my $old_parent = $new_node->parent;
	$old_parent and $new_node->trigger_event('DOMNodeRemoved',
		rel_node => $old_parent);
	if($new_node->is_inside($doc) && !$new_node->is_inside($old_node)){
		$_->trigger_event('DOMNodeRemovedFromDocument')
		  for $new_node, $new_node->descendants;
	}

	# If the owner is not set explicitly inside the node, it will lose
	# its owner.  The ownerDocument method  sets  it  if  it  is  not
	# already set.
	$old_node->ownerDocument;

	my $ret = $old_node->replace_with(
		$new_node->isa('HTML::DOM::DocumentFragment')
		? $new_node->childNodes
		: $new_node
	);

	$new_node->trigger_event('DOMNodeInserted', rel_node => $self);
	if($in_doc) {
		$_->trigger_event('DOMNodeInsertedIntoDocument')
		  for $new_node, $new_node->descendants;
	}
	$_->trigger_event('DOMSubtreeModified')
	  for _nearest_common_parent($old_parent, $self);

	$doc->_modified;

	$ret;
}

sub removeChild {
	# ~~~ NO_MODIFICATION_ALLOWED_ERR is meant to be raised if the
	#     node is read-only.

	my($self,$child) = @_;

	no warnings 'uninitialized';
	$self == $child->parent or
		die new HTML::DOM::Exception NOT_FOUND_ERR,
		'removeChild\'s argument is not a child of this node';

	# If the owner is not set explicitly inside the node, it will lose
	# its owner.  The ownerDocument method  sets  it  if  it  is  not
	# already set.
	my $doc = $child->ownerDocument;

	$child->trigger_event('DOMNodeRemoved',
		rel_node => $self);
	if($child->is_inside($doc)) {
		$_->trigger_event('DOMNodeRemovedFromDocument')
		  for $child, $child->descendants;
	}

	$child->detach;

	$self->trigger_event('DOMSubtreeModified');

	{($self->ownerDocument||next)->_modified;}

	$child;
}

sub appendChild {
	# ~~~ NO_MODIFICATION_ALLOWED_ERR is meant to be raised if the
	#     node is read-only.
	# ~~~ HIERARCHY_REQUEST_ERR is also supposed to be raised if the
	#     node type does not allow children of $new_node's type.

	my($self,$new_node) = @_;

	$self->is_inside($new_node) and
		die new HTML::DOM::Exception HIERARCHY_REQUEST_ERR,
		'A node cannot be inserted into one of its descendants';

	my $doc = $new_node->ownerDocument; # not $self->... because $self
	                                    # might be the document, in
	                                    # which case its owner is null.
	$doc == $self || $doc == $self->ownerDocument or
		die new HTML::DOM::Exception WRONG_DOCUMENT_ERR,
		'The node to be inserted belongs to another document';

	my $old_parent = $new_node->parent;
	$old_parent and $new_node->trigger_event('DOMNodeRemoved',
		rel_node => $old_parent);
	if($new_node->is_inside($doc)) {
		$_->trigger_event('DOMNodeRemovedFromDocument')
		  for $new_node, $new_node->descendants;
	}

	$self->push_content($new_node->isa('HTML::DOM::DocumentFragment')
		? $new_node->childNodes
		: $new_node);

	$new_node->trigger_event('DOMNodeInserted', rel_node => $self);
	if($self->is_inside($doc)) {
		$_->trigger_event('DOMNodeInsertedIntoDocument')
		  for $new_node, $new_node->descendants;
	}
	$_->trigger_event('DOMSubtreeModified')
	  for _nearest_common_parent($old_parent, $self);

	$doc->_modified;

	$new_node;
}

# This is used to determine who gets a DOMSubtreeModified event. Despite
# its name, it may choose one of the two nodes passed to it if one is the
# parent of the other. If neither of the nodes is in the same tree, they
# are both returned. The first arg may be undef, in which case the 2nd
# is returned.
sub _nearest_common_parent {
	my ($node1,$node2)=@_;
	!defined $node1 and return $node2;
	$node1->root != $node2->root and return $node1, $node2;
	my $addr1 = $node1->address;
	my $addr2 = $node2->address;
	while(substr $addr1, 0, length $addr2, ne $addr2 and
	      substr $addr2, 0, length $addr1, ne $addr1) {
		s/\.[^.]*\z// for $addr1, $addr2;
	}
	$node2->address(
	  length $addr1 < length $addr2 ? $addr1 : $addr2
	)
}

sub hasChildNodes {
	!!$_[0]->content_list
}

sub cloneNode {
	my($self,$deep) = @_;
	if($deep) {
		$self->clone
	}
	else {
		# ~~~ Do I need to reweaken any attributes?
		bless +(my $clone = { %$self }), ref $self;
		$clone->_set_ownerDocument($self->ownerDocument);
		delete $clone->{$_} for qw/ _parent _content /;
		$clone
	}
}

sub normalize {
	my @pile = my $self = shift;
	while(@pile) {
		if($pile[0]{_tag} eq '~text') {
			if($pile[0]{text} eq '') {
				shift(@pile)->detach, next
			}
			_:{while((my $next = $pile[0]->nextSibling||next _)
			       ->{_tag} eq '~text') {
				$pile[0]{text}.=$next->{text};
				$next->detach;
			}}
			shift @pile;
		}
		else {
			unshift @pile, @{(shift@pile)->{'_content'}||[]};
		}
	}
	return
}

sub hasAttributes {
	(shift->attributes||return 0)->length
}

sub isSupported {
	my $self = shift;
	$HTML::DOM::Implementation::it->hasFeature(@_)
}

# ----------- EventTarget INTERFACE ------------- #

=item addEventListener($event_name, $listener, $capture)

The C<$listener> should be either a coderef or an object with a
C<handleEvent> method. (HTML::DOM does not implement any such object since
it would just be a wrapper around a coderef anyway, but has support for
them.) An object with C<&{}> overloading will also do.

C<$capture> is a boolean indicating whether this is to be triggered during
the 'capture' phase.

=cut

sub addEventListener {
	my ($self,$name,$listener, $capture) = @_;
	$$self{'_HTML_DOM_' . ('capture_' x !!$capture) . 'events'}
		{lc $name}{refaddr $listener} = $listener;
	return;
}

# Though this only applies to elements, I'm putting it here, since only
# H:D:N is supposed to access _HTML_DOM_events.
sub _add_attr_event { # special secret method that keys the event listener
                      # by the string 'attr', rather than by its refaddr
	my ($self,$name,$listener) = @_;
	$$self{'_HTML_DOM_events'}{lc $name}{attr} = $listener;
	return;
}

=item removeEventListener($event_name, $listener, $capture)

The C<$listener> should be the same reference passed to 
C<addEventListener>.

=cut

sub removeEventListener {
	my ($self,$name,$listener, $capture) = @_;
	$name = lc $name;
	my $key = '_HTML_DOM_' . ('capture_' x !!$capture) . 'events';
	exists $$self{$key} && exists $$self{$key}{$name} &&
		delete $$self{$key}{$name}{refaddr $listener};
	return;
}

=item get_event_listeners($event_name, $capture)

This is not a DOM method (hence the underscores in the name). It returns a
list of all event listeners for the given event name. C<$capture> is a
boolean that indicates which list to return, either 'capture' listeners or
normal ones.

=cut

sub get_event_listeners { # uses underscores because it is not a DOM method
	my($self,$name,$capture) = @_;
	$name = lc $name;
	my $key = '_HTML_DOM_' . ('capture_' x !!$capture) . 'events';
	exists $$self{$key} && exists $$self{$key}{$name}
		? values %{$$self{$key}{$name}}
		: ()
}

=item dispatchEvent($event_object)

$event_object is an object returned by HTML::DOM's C<createEvent> method,
or any object that implements the interface documented in 
L<HTML::DOM::Event>.

C<dispatchEvent> does not automatically call the handler passed to the
document's C<default_event_handler>. It is expected that the code that
calls this method will do that (see also L</trigger_event>).

The return value is a boolean indicating whether the default action
should be taken (i.e., whether preventDefault was I<not> called).

=cut

sub dispatchEvent { # This is where all the work is.
	my ($target, $event) = @_;
	my $name = $event->type;

	die HTML::DOM::Exception->new(UNSPECIFIED_EVENT_TYPE_ERR,
		'The type of event has not been specified')
		unless defined $name and length $name;
	
	# Basic event flow is as follows:
	# 1.  The  'capturing'  phase:  Go through the  node's  ancestors,
	#     starting from the top of the tree. For each one, trigger any
	#     capture events it might have.
	# 2.  Trigger events on the $target.
	# 3. 'Bubble-blowing' phase: Trigger events on the target's ances-
	#     tors in reverse order (top last).

	my $eh = ($target->ownerDocument || $target)->error_handler;

	$event->_set_target($target);

	my @lineage = lineage $target; # $lineage[-1] is the root

	$event->_set_eventPhase(HTML::DOM::Event::CAPTURING_PHASE);
	for (reverse @lineage) { # root first
		$event-> _set_currentTarget($_);
		eval {
			defined blessed $_ && $_->can('handleEvent') ?
				$_->handleEvent($event) : &$_($event);
			1
		} or $eh and &$eh() for($_->get_event_listeners($name, 1));
		return !cancelled $event if $event->propagation_stopped;
	}

	$event->_set_eventPhase(HTML::DOM::Event::AT_TARGET);
	$event->_set_currentTarget($target);
	eval {
		defined blessed $_ && $_->can('handleEvent') ?
			$_->handleEvent($event) : &$_($event);
		1
	} or $eh and &$eh() for $target->get_event_listeners($name);
	return !cancelled $event if $event->propagation_stopped
	                         or!$event->bubbles;

	$event->_set_eventPhase(HTML::DOM::Event::BUBBLING_PHASE);
	for (@lineage) { # root last
		$event-> _set_currentTarget($_);
		eval {
			defined blessed $_ && $_->can('handleEvent') ?
				$_->handleEvent($event) : &$_($event);
			1
		} or $eh and &$eh() for($_->get_event_listeners($name));
		return !cancelled $event if $event->propagation_stopped;
	}
	return !cancelled $event;
}

=item trigger_event($event, ...)

Here is another non-DOM method. C<$event> can be an event object or simply 
an event name. This method triggers an
event for real, first calling C<dispatchEvent> and then running the default
action for the event unless an event listener cancels it.

=begin comment
The interface for this is very clunky, so I’m keeping it private for now.
It only exists for the sake of the implementation, anyway. Actually, I’ve
changed it so that it’s DOMActivate_default => \&sub instead of default =>
{ DOMActivate => \&sub }, because that makes it easier for multiple classes
to say SUPER::trigger_event($evnt, ..._default => ) without clobbering each
other.

It can take named args following the C<$event> arg. The C<default> arg, if
present, must be a hash of subroutines to be called if C<dispatchEvent>
returns true. The keys of the hash are event names. Whichever applies will
be used. If omitted, the
default event handler associated with the document will be used. Certain
HTML elements override C<trigger_event> to provide their
own default event handler (this is where HTML::DOM's
default_event_handler_for business comes into play), but if you specify a
default it will override.

The rest
of the arguments (which are ignored if C<$event> is an event object)
are the same as those passed to an event object's C<init> method. Any
omitted args will be filled in with reasonable defaults.

=end comment

It can take named args following the C<$event> arg. These are passed to the
event object's C<init> method. Any
omitted args will be filled in with reasonable defaults. These are
completely ignored if C<$event> is an event object.

When C<$event> is an event name, C<trigger_event> automatically chooses the
right event class and a set of default args for that event name, so you can
supply just a few. E.g.,

  $elem->trigger_event('click',  shift => 1, button => 1);

=cut

sub trigger_event { # non-DOM method
# ~~~ When I implement mutation events, I need, for efficiency’s sake, to
#     skip creating the event object here, and have dispatchEvent (or
#    _dispatch_event or some such) create the object on demand.
	my ($target, $event, %args) = @_;
	my $doc;
	my $type;
	defined blessed $event && $event->isa('HTML::DOM::Event')
	? $type =  $event->type 
	: do {
		$type = $event;
		require HTML'DOM'Event;
		$event = ($doc = $target->ownerDocument||$target)
			->createEvent((
				my (undef, @init_args) =
					HTML'DOM'Event'defaults($type)
			)[0]);
		$event->init(
			type=>$type,
			@init_args,
			$event->can('view')
				? ( view =>
					($target->ownerDocument||$target)
						->defaultView
				):(),
			%args
		);
	};

	$target->dispatchEvent($event) and &{
		$args{"$type\_default"} ||
		($doc || $target->ownerDocument)->default_event_handler
		|| return
	}($event);
	return;
}

=item as_text

=item as_HTML

These two (non-DOM) methods of L<HTML::Element> are overridden, so that
they work correctly with comment and text nodes.

=cut

sub as_text{
	(my $clone = shift->clone)->deobjectify_text;
	$clone->SUPER::as_text;
}

sub as_HTML{
	(my $clone = shift->clone)->deobjectify_text;
	$clone->SUPER::as_HTML;
}

sub push_content {
	my $self  = shift; 
	my $count = ()=$self->content_list;
	$self->SUPER::push_content(@_);
	my $ary = $self->{_content};
	ref and weaken $_->{_parent} for @$ary[$count-@$ary..-1];
	$self
}

sub unshift_content {
	my $self  = shift; 
	my $count = ()=$self->content_list;
	$self->SUPER::unshift_content(@_);
	my $ary = $self->{_content};
	ref and weaken $_->{_parent} for @$ary[0..$#$ary-$count];
	$self
}

sub splice_content {
	my($self,$start,$deleted) = (shift,@_); 
	my $orig_count = ()=$self->content_list;
	$self->SUPER::splice_content(@_);
	my $ary = $self->{_content};

	# orig_length - deleted_items + x = final_length,
	# where x is the number of items added (to be weakened), so
	# x = final_length - orig_length + deleted_items.
	# x needs to be adjusted so it is an ending offset, so we use
	# $#$ary instead of the final length (@$ary) and add $start
	ref and weaken $_->{_parent}
		for @$ary[$start..$#$ary-$orig_count+$deleted+$start];

	$self
}


=back

=cut

1;
__END__





=head1 EXPORTS

The following node type constants are exportable:

=over 4

=item ELEMENT_NODE (1)

=item ATTRIBUTE_NODE (2)

=item TEXT_NODE (3)

=item CDATA_SECTION_NODE (4)

=item ENTITY_REFERENCE_NODE (5)

=item ENTITY_NODE (6)

=item PROCESSING_INSTRUCTION_NODE (7)

=item COMMENT_NODE (8)

=item DOCUMENT_NODE (9)

=item DOCUMENT_TYPE_NODE (10)

=item DOCUMENT_FRAGMENT_NODE (11)

=item NOTATION_NODE (12)

=back

=head1 SEE ALSO

L<HTML::DOM>

