t/attr.t - metacpan.org

#!/usr/bin/perl -T

# This script contains a full test of the Node and EventTarget interfaces,
# since H:D:Attr implements them itself, and does not inherit
# from H:D:Node.

use strict; use warnings; use lib 't';

use Scalar::Util 'refaddr';
use HTML::DOM;

# -------------------------#
use tests 5; # constructors

my $doc = new HTML::DOM;
isa_ok $doc, 'HTML::DOM';

my $elem = $doc->createElement('a');
isa_ok $elem, 'HTML::DOM::Element';

$elem->setAttribute(href => 'about:blank');

my $attr = $elem->getAttributeNode('href');
isa_ok $attr, 'HTML::DOM::Attr';
ok $attr->DOES('HTML::DOM::Node'), '$attr does HTML::DOM::Node';
isa_ok $attr, 'HTML::DOM::EventTarget', '$attr';


# -------------------------#
use tests 1; # overloading

is $attr, 'about:blank', '""';

# -------------------------#
use tests 1; # name

is name $attr, 'href', 'name';


# -------------------------#
use tests 41; # specified

{
	for(
		[qw[ br clear none ]],
		[qw[ td colspan 1 ]],
		[qw[ th colspan 1 ]],
		[qw[ form enctype application/x-www-form-urlencoded ]],
		[qw[ frame frameborder 1 ]],
		[qw[ iframe frameborder 1 ]],
		[qw[ form method GET ]],
		[qw[ td rowspan 1 ]],
		[qw[ th rowspan 1 ]],
		[qw[ frame scrolling auto ]],
		[qw[ iframe scrolling auto ]],
		[qw[ area shape rect ]],
		[qw[ a shape rect ]],
		[qw[ col span 1 ]],
		[qw[ colgroup span 1 ]],
		[qw[ input type TEXT ]],
		[qw[ button type submit ]],
		[qw[ param valuetype DATA ]],
	) {
		my $elem = $doc->createElement($$_[0]);
		my $attr = $elem->getAttributeNode($$_[1]);
		ok !$attr->specified, "@$_[0,1] !specified";
		is $attr->value, $$_[2], "default value of @$_[0,1]";
	}
	my $doc = new HTML::DOM;
	$doc->write('
		<!DOCTYPE HTML PUBLIC
			"-//W3C//DTD HTML 4.01 Transitional//EN">
		<title></title>
	');$doc->close;
	ok !specified{$doc->documentElement->getAttributeNode('version')},
		"html version !specified";
	is $doc->documentElement->getAttributeNode('version')->value,
		'-//W3C//DTD HTML 4.01 Transitional//EN',
		"default value of html version";

	my $elem = $doc->createElement('br');
	ok specified{
		removeAttributeNode$elem getAttributeNode$elem 'clear'
	}, "specified after removal";
	$elem->attr('clear','left');
	ok specified{getAttributeNode$elem 'clear'},
		'specified when explicit';
	$elem->attr('clear','none');
	ok specified{getAttributeNode$elem 'clear'},
		'specified when explicit, even when eq default';
}

# -------------------------#
use tests 3; # value

is value $attr, 'about:blank', 'get value';
is $attr->value('javascript:window.close()'), 'about:blank',
	'return value of setting the value is the old value';
is $elem->getAttribute('href'), 'javascript:window.close()',
	'setting the value works';

# -------------------------#
use tests 15; # Node interface attributes

# HTML::DOM::Attr implements all the Node interface itself, and does not
# inherit from HTML::DOM::Node.

is nodeName $attr, 'href', 'nodeName';
is nodeValue $attr, 'javascript:window.close()', 'nodeValue';
cmp_ok nodeType $attr, '==', HTML::DOM::Node::ATTRIBUTE_NODE, 'nodeType';
is_deeply[parentNode$attr],[],'parentNode';

my $children = childNodes $attr;
my @children = childNodes $attr; # list context
is $children->length, 1, 'number of child nodes';
is scalar @children, 1, 'number of child nodes (list context)';
isa_ok my $text_node = $children->[0], 'HTML::DOM::Text', 'child node';
&cmp_ok(@children, '==', $text_node,
	'(childNodes $attr)[0] is the same as childNodes $attr ->[0]');
is $text_node->data, 'javascript:window.close()',
	'data contained by child node';

cmp_ok firstChild $attr, '==', $text_node, 'firstChild';
cmp_ok  lastChild $attr, '==', $text_node,  'lastChild';
is_deeply[previousSibling$attr],[],'previousSibling';
is_deeply[    nextSibling$attr],[],    'nextSibling';
is_deeply[attributes$attr],[],'attributes';
cmp_ok  ownerDocument $attr, '==', $doc,  'ownerDocument';


# -------------------------#
use tests 26; # Node interface methods

eval { insertBefore $attr };
isa_ok $@, 'HTML::DOM::Exception',
	'$@ (after insertBefore)';
cmp_ok $@, '==', 
	HTML::DOM::Exception::NO_MODIFICATION_ALLOWED_ERR,
	'insertBefore throws a "no modification allowed" error';

{ # replaceChild
	$elem->appendChild(my $new_text =
		createTextNode $doc 'http://www.perl.org/');
	cmp_ok $text_node, '==', $attr->replaceChild(
			$new_text, $text_node
		), 'replaceChild returns the replaced node';
	is scalar(()=childNodes$elem), 0,
		'replaceChild removes from the tree first';

	my $frag = createDocumentFragment $doc;

	eval { $attr->replaceChild($frag, $new_text); };
	isa_ok $@, 'HTML::DOM::Exception',
		'$@ (after replaceChild with a frag that does not have ' .
		'exactly one child node)';
	cmp_ok $@, '==',
		HTML::DOM::Exception::HIERARCHY_REQUEST_ERR,
		'replaceChild with with a frag that does not have ' .
		'exactly one child node throws a ' .
		'hierarchy error';	

	$frag->appendChild(createTextNode $doc 'lalala');
	$attr->replaceChild($frag, $new_text);
	is $attr->value, 'lalala',
		'replaceChild(frag,node) inserts the frag\'s children';

	eval {
		$attr->replaceChild(
			(createAttribute $doc 'ddk'), $attr->firstChild
		);
	};
	isa_ok $@, 'HTML::DOM::Exception',
		'$@ (after replaceChild with wrong node type)';
	cmp_ok $@, '==',
		HTML::DOM::Exception::HIERARCHY_REQUEST_ERR,
		'replaceChild with wrong node type throws a ' .
		'hierarchy error';
	
	appendChild $frag createElement $doc 'div';
	eval { $attr->replaceChild($frag, firstChild $attr); };
	isa_ok $@, 'HTML::DOM::Exception',
		'$@ (after replaceChild with a frag containing the wrong' .
		' node type)';
	cmp_ok $@, '==',
		HTML::DOM::Exception::HIERARCHY_REQUEST_ERR,
		'replaceChild with a frag containing the wrong' .
		' node type throws a ' .
		'hierarchy error';

	my $another_doc = new HTML::DOM;
	my $another_node = createTextNode $another_doc 'ddk';
	ok eval {
		$attr->replaceChild(
			$another_node,
			(childNodes $attr)[0],
		);
		1
	}, 'replaceChild with wrong doc no longer dies';
	is $another_node->ownerDocument, $doc,
		'replaceChild with wrong doc changes the owner doc';

	eval {
		$attr-> replaceChild(
			$doc->createTextNode('ddk'), $text_node
		);
	};
	isa_ok $@, 'HTML::DOM::Exception',
		'$@ (after replaceChild with a bad refChild)';
	cmp_ok $@, '==', HTML::DOM::Exception::NOT_FOUND_ERR,
		'replaceChild with a 2nd arg that\'s not a child of ' .
		'this node throws a "not found" error';
}

eval { removeChild $attr };
isa_ok $@, 'HTML::DOM::Exception',
	'$@ (after removeChild)';
cmp_ok $@, '==', 
	HTML::DOM::Exception::NO_MODIFICATION_ALLOWED_ERR,
	'removeChild throws a "no modification allowed" error';

eval { appendChild $attr };
isa_ok $@, 'HTML::DOM::Exception',
	'$@ (after appendChild)';
cmp_ok $@, '==', 
	HTML::DOM::Exception::NO_MODIFICATION_ALLOWED_ERR,
	'appendChild throws a "no modification allowed" error';

ok hasChildNodes $attr, 'hasChildNodes';

my $clone = cloneNode $attr; # shallow

cmp_ok refaddr $attr, '!=', refaddr $clone, 'cloneNode makes a new object';
cmp_ok +(childNodes $attr)[0], '!=', (childNodes $clone)[0],
	'shallow clone works ignores its deep arg';
is_deeply [parentNode $clone], [], 'clones are orphans';

$clone = cloneNode $attr 1; # deep

cmp_ok refaddr $attr, '!=', refaddr $clone,
	'deep cloneNode makes a new object';
cmp_ok +(childNodes $attr)[0], '!=', (childNodes $clone)[0],
	'deep clone works';
is_deeply [parentNode $clone], [], 'deep clones are parentless';


# -------------------------#
use tests 4; # ownerElement

{
	my $elem = $doc->createElement('a');
	my $attr = $doc->createAttribute('href');
	$elem->setAttributeNode($attr);
	is $attr->ownerElement, $elem,
		'ownerElement after setAttributeNode';

	my $nother_attr = $doc->createAttribute('href');
	$elem->setAttributeNode($nother_attr);
	is +()=$attr->ownerElement, 0,
		'ownerElement after setAttributeNode replaces it';

	$elem->removeAttributeNode($nother_attr);
	is $nother_attr->ownerElement, undef,
		'removeAttributeNode updates ownerElement';

	$elem->setAttribute('target', '_blank');
	is $elem->getAttributeNode('target')->ownerElement, $elem,
		'ownerElement of autovivified attr';

}

# -------------------------#
use tests 4; # XML namespace stuff and normal eyes

is +()=$attr->$_, 0, $_ for qw / namespaceURI prefix localName normalize /;


# -------------------------#
use tests 1; # hasAttributes

ok !$attr->hasAttributes, 'hasAttrbitues';

# -------------------------#
use tests 2; # booleanness

{
	my $attr = $doc->createAttribute('foo');
	ok !"$attr",
	    'make sure our booleanness test is actually doing something';
	ok $attr, 'boooleannness';
}

# -------------------------#
use tests 2; # isSupported

ok $attr->isSupported('hTML', '1.0'), 'isSupported';
ok!$attr->isSupported('onfun') ,'isn’tSupported';

# -------------------------#
use tests 2; # relationship to the child text node (bug fixed in 0.017)
{
	is refaddr $attr->firstChild->parentNode, refaddr $attr,
	  "an attr's text node's parent is the attr after replaceChild";
	$attr = $doc->createAttribute('foo');
	is refaddr $attr->firstChild->parentNode, refaddr $attr,
		"a new attr's text node's parent is the attr";
}
	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)