t/event-target.t - metacpan.org

#!/usr/bin/perl -T

use strict; use warnings;
no warnings qw 'utf8 parenthesis regexp once qw bareword syntax';

use lib 't';
use HTML::DOM;
use HTML::DOM::EventTarget;
use HTML::DOM::Event ':all';

my $doc = new HTML::DOM;
{
	package MyEventTarget;
	our @ISA = HTML::DOM::EventTarget::;

	sub event_parent {
		${+shift}
	}
}

my $child = bless \do{my $x}, MyEventTarget=>;
my $grandchild = bless \do{my $x = $child}, 'MyEventTarget';

# -------------------------#
use tests 10; # (add|remove)EventListener and get_event_listeners

{
	my $sub1 = sub{};
	my $sub2 = sub{};
	my $sub3 = sub{};
	my $sub4 = sub{};
	is_deeply[$child->get_event_listeners('click')],[],
		'get_event_listeners initially returns nothing';
	is_deeply[$child->addEventListener(click=>$sub1)],[], 
		'addEventListener returns nothing';
	$child->addEventListener(click=>$sub2);
	is_deeply[sort $child->get_event_listeners('click')],
	         [sort $sub1, $sub2], 'get_event_listeners after adding 2';
	$child->addEventListener(click=>$sub3, 1);
	$child->addEventListener(click=>$sub4, 1);
	is_deeply[sort $child->get_event_listeners('click', 1)],
	         [sort $sub3, $sub4],
		'get_event_listeners (for capture phase) after adding 2';
	is_deeply[$child->removeEventListener(click=>$sub1)],[],
		'removeEventListener does nothing';
	is_deeply[$child->get_event_listeners('click')],
	         [$sub2],
		'get_event_listeners after removing one';
	$child->removeEventListener(click=>$sub3, 1);
	is_deeply[$child->get_event_listeners('click', 1)],
	         [$sub4],
		'get_event_listeners for capture phase after removing one';
	$child->addEventListener(focus => $sub3);
	$child->addEventListener(focus => $sub4);
	$child->addEventListener(focus => $sub2, 1);
	is_deeply[[$child->get_event_listeners('click')],
	          [$child->get_event_listeners('click', 1)],
	          [sort($child->get_event_listeners('focus'))],
	          [$child->get_event_listeners('focus', 1),]],
	         [[$sub2],
	          [$sub4],
	          [sort $sub3, $sub4],
	          [$sub2]],
	         'different slots for different event types and phases';
	$child->onsubmit($sub1);
	is +()=$child->get_event_listeners('submit'), 1,
	 'get_event_listeners with attribute event handlers';
	is +()=$child->get_event_listeners('submit',1), 0,
	 'event handlers to not apply to the capture phase';
}

# Let's clean up after ourselves:
clear_event_listeners($child, 'click', 'focus', 'submit');

sub clear_event_listeners {
	my $target = shift;
	for my $type(@_) {
		$target->removeEventListener($type, $_)
			for $target->get_event_listeners($type);
		$target->removeEventListener($type, $_, 1)
			for $target->get_event_listeners($type, 1);
	}
}


# -------------------------#
use tests 4; # event dispatch:
# First we'll make sure that the events are triggered in the right order,
# and for the right event type.

my $event = $doc->createEvent;
my $event2 = $doc->createEvent;
init $event type => click => cancellable => 1 => propagates_up => 1;
init $event2 type => focus => cancellable => 0 => propagates_up => 0;

our $e;

# some of these never get called--or shouldn't, if the module's work-
# ing correctly.
$child->addEventListener(click => sub { $e .= '-cclick1' });
$child->addEventListener(click => sub { $e .= '-cclick2' });
$child->addEventListener(click => sub { $e .= '-cclick1-capture' }, 1);
$child->addEventListener(click => sub { $e .= '-cclick2-capture' }, 1);
$grandchild->addEventListener(click => sub { $e .= '-gcclick1' });
$grandchild->addEventListener(click => sub { $e .= '-gcclick2' });
$grandchild->addEventListener(
	click => sub { $e .= '-gcclick1-capture' }, 1);
$grandchild->addEventListener(
	click => sub { $e .= '-gcclick2-capture' }, 1);
$child->addEventListener(focus => sub { $e .= '-cfocus1' });
$child->addEventListener(focus => sub { $e .= '-cfocus2' });
$child->addEventListener(focus => sub { $e .= '-cfocus1-capture' }, 1);
$child->addEventListener(focus => sub { $e .= '-cfocus2-capture' }, 1);
$grandchild->addEventListener(focus => sub { $e .= '-gcfocus1' });
$grandchild->addEventListener(focus => sub { $e .= '-gcfocus2' });
$grandchild->addEventListener(
	focus => sub { $e .= '-gcfocus1-capture' }, 1);
$grandchild->addEventListener(
	focus => sub { $e .= '-gcfocus2-capture' }, 1);

$@ = 'drit'; # Make sure event dispatch leaves this alone.

$e = '';
ok $grandchild->dispatchEvent($event), 'dispatchEvent returns true';
like $e, qr/^-cclick(\d)-capture      # Each pair can be run in any order,
             -cclick(?!\1)\d-capture  # hence the (\d) and (?!\1)\d.
             -gcclick(\d)
             -gcclick(?!\2)\d
             -cclick(\d)
             -cclick(?!\3)\d
         \z/x, 'order of fizzy event dispatch';

$e = '';
$grandchild->dispatchEvent($event2); # This event is not bubbly.
like $e, qr/^-cfocus(\d)-capture      # Each pair can be run in any order,
             -cfocus(?!\1)\d-capture  # hence the (\d) and (?!\1)\d.
             -gcfocus(\d)
             -gcfocus(?!\2)\d
          \z/x, 'order of flat event dispatch';

is $@, 'drit', 'event dispatch leaves $@ alone'; # bug in 0.033 and earlier

clear_event_listeners($child, 'click', 'focus');
clear_event_listeners($grandchild, 'click', 'focus');


# -------------------------#
use tests 1; # event dispatch:
# Now we need to see whether eventPhase is set correctly.

($event = $doc->createEvent)->initEvent(click => 1, 1);
$child->addEventListener(click => sub { $e .= $_[0]->eventPhase }, 1);
$child->addEventListener(click => sub { $e .= $_[0]->eventPhase }, 1);
$child->addEventListener(click => sub { $e .= $_[0]->eventPhase });
$child->addEventListener(click => sub { $e .= $_[0]->eventPhase });
$grandchild->addEventListener(click => sub { $e .= $_[0]->eventPhase });
$grandchild->addEventListener(click => sub { $e .= $_[0]->eventPhase });

$e = '';
$grandchild->dispatchEvent($event);
is $e, '112233', 'value of eventPhase during event dispatch';

clear_event_listeners($child, 'click');
clear_event_listeners($grandchild, 'click');


# -------------------------#
use tests 3; # event dispatch: stopPropagation

{
	# I put stopPropagation in both listeners for each phase, since
	# they could be called either order and I need to make sure that
	# the other handler at the same level is still called *after* the
	# first one has called stopPropagation.
	$child->addEventListener(click => my $capture1 = sub {
		$_[0]->stopPropagation;
		$e .= '-'
	}, 1);
	$child->addEventListener(click => my $capture2 = sub {
		$_[0]->stopPropagation;
		$e .= '-'
	}, 1);
	$grandchild->addEventListener(click => my $at_target1 = sub {
		$_[0]->stopPropagation; $e .= '='
	});
	$grandchild->addEventListener(click => my $at_target2 = sub {
		$_[0]->stopPropagation; $e .= '='
	});
	$child->addEventListener(click => my $fzz1 = sub {
		$_[0]->stopPropagation; $e .= '≡'
	});
	$child->addEventListener(click => my $fzz2 = sub {
		$_[0]->stopPropagation; $e .= '≡'
	});
	$doc->addEventListener(click => sub {
		$e = "You didn't expect this, did you?"
	});

	$e = '';
	($event = $doc->createEvent)->initEvent(click => 1, 1);
	$grandchild->dispatchEvent($event);
	is $e, '--', 'stopPropagation at capture phase';

	$child->removeEventListener(click => $_, 1)
		for $capture1, $capture2;

	$e = '';
	($event = $doc->createEvent)->initEvent(click => 1, 1);
	$grandchild->dispatchEvent($event);
	is $e, '==', 'stopPropagation at the target';

	$grandchild->removeEventListener(click => $_)
		for $at_target1, $at_target2;

	$e = '';
	($event = $doc->createEvent)->initEvent(click => 1, 1);
	$grandchild->dispatchEvent($event);
	is $e, '≡≡', 'stopPropagation at the bubbly phase';

}

clear_event_listeners($child, 'click');
clear_event_listeners($grandchild, 'click');
clear_event_listeners($doc, 'click');


# -------------------------#
use tests 10; # event dispatch:
#             qw/ target currentTarget preventDefault cancelable /
#    This section also makes sure that event types are indifferent to case.

$child->addEventListener(cLick => sub {
	is $_[0]->currentTarget, $child,
		'currentTarget at capture stage';
	is $_[0]->target, $grandchild,
		'"target" attr during capture phase';
}, 1);
$grandchild->addEventListener(clIck => sub {
	is $_[0]->currentTarget, $grandchild,
		'currentTarget at the target';
	is $_[0]->target, $grandchild,
		'"target" attr at the target';
});
$child->addEventListener(cliCk => sub {
	is scalar $_[0]->preventDefault, undef,
		'return val of preventDefault';
	is $_[0]->currentTarget, $child,
		'currentTarget while bubbles are being blown';
	is $_[0]->target, $grandchild,
		'"target" attr while froth is rising';
});

($event = $doc->createEvent)->initEvent(click => 1, 1);

ok! $grandchild->dispatchEvent($event),
	'preventDefault makes dispatchEvent return false';

clear_event_listeners($child, 'click');
clear_event_listeners($grandchild, 'click');

$grandchild->addEventListener(click => sub {
	$e = 'did it'; # make sure this handler is actually called
	$_[0]->preventDefault
});
($event = $doc->createEvent)->initEvent(click => 1, 0);
ok $grandchild->dispatchEvent($event),
	'preventDefault has no effect on uncancelable actions';
is $e, 'did it', 'And, yes, preventDefault *was* actually called.';

# -------------------------#
use tests 7; # event dispatch: event handlers
#  (accessors for event handlers are tested specifically further down)

clear_event_listeners($grandchild, 'click');
{
 ($event = $doc->createEvent)->initEvent('click',1,1);
 $grandchild->onclick(sub { 0 });
 ok !$grandchild->dispatchEvent($event),
  'defined false retval from attr event handler calls preventDefault';
 ($event = $doc->createEvent)->initEvent('click',1,1);
 $grandchild->onclick(sub{});
 ok $grandchild->dispatchEvent($event),
  'undef retval from attr event handler does not call preventDefault';
 ($event = $doc->createEvent)->initEvent('mouseover',1,1);
 $grandchild->onmouseover(sub{});
 ok $grandchild->dispatchEvent($event),
  'undef retval from onmouseover handler does not call preventDefault';
 ($event = $doc->createEvent)->initEvent('mouseover',1,1);
 $grandchild->onmouseover(sub{1});
 ok !$grandchild->dispatchEvent($event),
  'true retval from onmouseover handler calls preventDefault';
 my @scratch;
 *Function::call_with = sub { @scratch = @_ };
 $grandchild->onclick(bless[], 'Function');
 $grandchild->trigger_event('click');
 is $scratch[1], $grandchild, 'target is passed to call_with';
 isa_ok $scratch[2], 'HTML::DOM::Event', 'second arg to call_with';
 
 { package DelegatingEventTarget;
   our @ISA = HTML::DOM::EventTarget::;
   sub get_event_listeners { ${+shift}->get_event_listeners(@_) }
   sub event_handler       { ${+shift}->event_handler(@_) }
   sub addEventListener    { ${+shift}->addEventListener(@_) }
   sub removeEventListener { ${+shift}->removeEventListener(@_) }
 }
 my $delegate = bless \do{my $x = $grandchild}, DelegatingEventTarget::;
 $delegate->trigger_event('click');
 ($event = $doc->createEvent)->init(type => 'click');
 is $scratch[1], $delegate,
  'event handler wrappers can be transferred to other objects';
}

# -------------------------#
use tests 6; # exceptions thrown by dispatchEvent

$event = $doc->createEvent;
eval {
	$child->dispatchEvent($event);
};
isa_ok $@, 'HTML::DOM::Exception',
'$@ (after dispatchEvent with an uninited event)';
cmp_ok $@, '==', HTML::DOM::Exception::UNSPECIFIED_EVENT_TYPE_ERR,
    'dispatchEvent with an uninited event throws the ' .
    'appropriate error';

$event->initEvent(undef, 1, 1);
eval {
	$child->dispatchEvent($event);
};
isa_ok $@, 'HTML::DOM::Exception',
'$@ (after dispatchEvent with no event type)';
cmp_ok $@, '==', HTML::DOM::Exception::UNSPECIFIED_EVENT_TYPE_ERR,
    'dispatchEvent with an no event type throws the ' .
    'appropriate error';

$event->initEvent('' => 1, 1);
eval {
	$child->dispatchEvent($event);
};
isa_ok $@, 'HTML::DOM::Exception',
'$@ (after dispatchEvent with "" for the event type)';
cmp_ok $@, '==', HTML::DOM::Exception::UNSPECIFIED_EVENT_TYPE_ERR,
    'dispatchEvent with "" for the event type throws the ' .
    'appropriate error';




# -------------------------#
use tests 5; # trigger_event

clear_event_listeners($grandchild, 'click');

$grandchild->addEventListener(clink => sub {
	$_[0]->preventDefault
});

my @def = (default => sub {
	$e = $_[0];
});

$e = '';
($event = $doc->createEvent)->initEvent(clink => 1, 1);
$grandchild->trigger_event($event, @def);
is $e, '', 'event objects passed to trigger_event can be stopped';

$grandchild->trigger_event('clink', @def);
is $e, '', 'event names passed to trigger_event can be stopped';

$e = '';
($event = $doc->createEvent)->initEvent(clink => 1, 0);
$grandchild->trigger_event($event, @def);
is $e, $event,
    'the default event was run when an obj was passed to trigger_event';

clear_event_listeners($grandchild, 'clink');
$e = '';
$grandchild->trigger_event('clink', @def);
is $e->type, 'clink',
	'$event->type when an event name is passed to trigger_event';
is $e->target, $grandchild,
	'$event->target when an event name is passed to trigger_event';

undef $e; # remove circularities


# -------------------------#
use tests 1; # error_handler
# This doesn’t test $target->ownerDocument->error_handler; event-basics.t
# takes care of that.

{
	no warnings 'once';
	my $e;
	local *MyEventTarget'error_handler = sub{ sub{ $e = $@ }};
	$grandchild->addEventListener(foo => sub { die "67\n" });
	$grandchild->trigger_event('foo');
	is $e, "67\n", 'error_handler gets called';
}


# -------------------------#
use tests 7;  # event_listeners_enabled
{
	no warnings qw 'redefine once';
	my $e;
	local *MyEventTarget'event_listeners_enabled = sub{ 1 };
	$grandchild->addEventListener(foo => sub { ++$e });
	$grandchild->trigger_event('foo');
	is $e, 1,
	  'event handlers run when event_listeners_enabled returns true';
	local *MyEventTarget'event_listeners_enabled = sub{ 0 };
	$grandchild->trigger_event('foo');
	is $e, 1,
	  'event handlers don\'t run if event_listeners_enabled is false';
	local *MyEventTarget'event_listeners_enabled = sub{ 1 };
	local *MyDoc'event_listeners_enabled = sub { 0 };
	local *MyEventTarget'ownerDocument = sub { bless[], 'MyDoc' };
	$grandchild->trigger_event('foo');
	is $e, 2, 'An event_listeners_enabled method on the event';
	local *MyEventTarget'event_listeners_enabled = sub{ 0 };
	local *MyDoc'event_listeners_enabled = sub { 1 };
	$grandchild->trigger_event('foo');
	is $e, 2, ' target prevents ownerDocument from being checked.';
	undef *MyEventTarget'event_listeners_enabled;
	$grandchild->trigger_event('foo');
	is $e, 3, 'fallback to event_listeners_enabled';
	local *MyDoc'event_listeners_enabled = sub { 0 };
	$grandchild->trigger_event('foo');
	is $e, 3, '  on the ownerDocument';

	$grandchild->trigger_event('foo', default => sub {
	  is $_[0]->target, $grandchild,
	    'the event’s target is set when event handlers are disabled'
	    # something I got wrong at first
	});
	
}


# -------------------------#
use tests 8;  # on* and attr_event_listener
{
 my $scratch;
 my $sub1 = sub { $scratch .= "one called "};
 my $sub2 = sub {  $scratch .= "two called " };
 is +()=$child->onbdext, 0, 'null retval from on*';
 is +()=$child->onbdext($sub1),0,'null retval from on* initial assignment';
 is $child->onbdext($sub2), $sub1, 'on* returns old value';
 is $child->onbdext, $sub2, 'on* with no args after assignment';
 $child->trigger_event('bdext');
 is $scratch, "two called ",
  'on* registers event listener and removes old one';
 is $child->attr_event_listener('bdext'), $sub2,
  'attr_event_listener returns the same thing as on*';
 is $child->attr_event_listener('bdext',$sub1),$sub2,
  'setting attr_event_listener returns old val';
 is $child->onbdext, $sub1, 'and the change applies to on*';
}

# -------------------------#
use tests 1;  # error messages for invalid methods
{             # (Testing this is necessary since we implement AUTOLOAD.)
 eval { 'dwext'->HTML::DOM::Node::dwed; };
 like $@,
  qr/^Can't locate object method "dwed" via package "HTML::DOM::Node"/;
}
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)