1#!/usr/bin/perl -T 2 3use strict; use warnings; 4 5use Scalar::Util 'refaddr'; 6use lib 't'; 7use HTML::DOM; 8 9# -------------------------# 10use tests 2; # constructors 11 12my $doc = new HTML::DOM; 13isa_ok $doc, 'HTML::DOM'; 14 15my $elem = $doc->createElement('a'); 16isa_ok $elem, 'HTML::DOM::Element'; 17 18$elem->attr('href' => 'about:blank'); 19 20# -------------------------# 21use tests 4; # Node interface attributes 22 23is nodeName $elem, 'A','nodeName'; 24cmp_ok $elem->nodeType, '==', HTML::DOM::Node::ELEMENT_NODE, 'nodeType'; 25is scalar(()=$elem->nodeValue), 0, 'nodeValue'; 26isa_ok +attributes $elem, 'HTML::DOM::NamedNodeMap'; 27 28# -------------------------# 29use tests 1; # tagName 30 31is tagName $elem, 'A', 'tagName'; 32 33# -------------------------# 34use tests 1; # getAttribute 35 36is $elem->getAttribute('href'), 'about:blank', 'getAttribute'; 37 38# -------------------------# 39use tests 3; # setAttribute 40 41is scalar(()=setAttribute $elem href=>'http://www.synodinresistance.org/'), 42 0, 'setAttribute'; 43is $elem->getAttribute('href'),'http://www.synodinresistance.org/', 44 'result of setAttribute'; 45setAttribute $elem pnin => []; 46isa_ok $elem->getAttributeNode('pnin'), 'HTML::DOM::Attr', 47 'retval of getAttributeNode after ref assignment to setAttribute'; 48 49# -------------------------# 50use tests 3; # removeAttribute 51 52is scalar(()=removeAttribute $elem 'href'), 53 0, 'removeAttribute'; 54is $elem->getAttribute('href'),'', 55 'result of removeAttribute'; 56 57$elem->setAttribute('href', bless[]); 58ok eval{$elem->removeAttribute("href");1}, 59 'removeAttribute doesn\'t die when removing an object other than an attr'; 60 61$elem->attr('href' => 'about:blank'); # still need an attr with which to 62 # experiment 63 64# -------------------------# 65use tests 4; # getAttributeNode 66 67 68is scalar(()= getAttributeNode $elem 'aoeu'), 69 0,'getAttributeNode returns null'; 70isa_ok+( my $attr = getAttributeNode $elem 'href'), 71 'HTML::DOM::Attr'; 72is $attr->nodeName, 'href', 73 'name of attr returned by getAttributeNode'; 74is $attr->nodeValue, 'about:blank', 75 'value of attr returned by getAttributeNode'; 76 77# -------------------------# 78use tests 10; # setAttributeNode 79 80(my $new_attr = $doc->createAttribute('href')) 81 ->value('1.2.3.4'); 82is refaddr $elem->setAttributeNode($new_attr), refaddr $attr, 83 'setAttributeNode returns the old node'; 84is $elem->getAttribute('href'), '1.2.3.4', 'result of setAttributeNode'; 85 86(my $another_attr = $doc->createAttribute('name'))->value('link'); 87is scalar(()=$elem->setAttributeNode($another_attr)), 0, 88 'setAttributeNode can return null'; 89is $elem->getAttribute('name'), 'link', 'result of setAttributeNode (2)'; 90 91{ 92 my $other_doc = new HTML::DOM; 93 my $attr = createAttribute $other_doc 'ddk'; 94 ok eval { 95 $elem-> setAttributeNode( 96 $attr 97 ); 98 1 99 }, 'setAttributeNode with wrong doc no longer dies' ; 100 is $attr->ownerDocument, $elem->ownerDocument, 101 'setAttributeNode with wrong doc sets the ownerDocument'; 102} 103 104my $elem2 = $doc->createElement('a'); 105$elem2->setAttributeNode($attr); 106is $elem2->getAttribute('href'), 'about:blank', 107 'orphaned attribute nodes can be reused'; 108 109eval { 110 $elem2-> setAttributeNode( 111 $new_attr 112 ); 113}; 114isa_ok $@, 'HTML::DOM::Exception', 115 '$@ (after setAttributeNode with an attribute that is in use)'; 116cmp_ok $@, '==', HTML::DOM::Exception::INUSE_ATTRIBUTE_ERR, 117 'setAttributeNode with an attribute that is in use throws the ' . 118 'appropriate error'; 119 120$elem2->removeAttribute('href'); 121$elem2->setAttribute('href',bless[]); 122ok eval{ 123 my $attr = $doc->createAttribute('href'); 124 $elem2->setAttributeNode($attr); 125 1 126}, 'setAttributeNode doesn\'t die when the attr is set to some random obj'; 127 128# -------------------------# 129use tests 11; # removeAttributeNode 130 131is refaddr $elem->removeAttributeNode($new_attr), refaddr $new_attr, 132 'return value of removeAttributeNode'; 133is $elem->getAttribute('href'), '', 'result of removeAttributeNode'; 134{ 135 my $warn=0; 136 local $SIG{__WARN__} = sub{ ++$warn }; 137 138 eval { 139 $elem->removeAttributeNode($doc->createAttribute('foo')), 140 } 141 ;isa_ok $@, 'HTML::DOM::Exception', 142 '$@ (after removeAttributeNode with a non-existent attr)'; 143 cmp_ok $@, '==', HTML::DOM::Exception::NOT_FOUND_ERR, 144 'removeAttributeNode with a non-existent attr throws the ' . 145 'appropriate error'; 146 is $warn, 0, 147 'removeAttributeNode with a non-existent attr doesn\'t warn'; 148 149 # The following two sets of tests differ in that, in the first 150 # case, the attribute we attempt to remove has not been accessed as 151 # an Attr node yet, while in the latter case it has. (In the 152 # impl., we don’t bother with Attr nodes until explicitly requested 153 # by the user [the module’s user, not the script/app’s user].) 154 155 $warn = 0; 156 $elem->attr(foo=>'bar'); 157 my $attr = $elem->removeAttributeNode(getAttributeNode$elem "foo"); 158 $elem->attr(foo=>'baz'); 159 eval { 160 $elem->removeAttributeNode($attr), 161 } 162 ;isa_ok $@, 'HTML::DOM::Exception', 163 '$@ (after failed remAttributeNode w/no auto-vivved attr)'; 164 cmp_ok $@, '==', HTML::DOM::Exception::NOT_FOUND_ERR, 165 'failed remAttributeNode w/no auto-vivved attr throws the ' . 166 'appropriate error'; 167 is $warn, 0, 168 'failed remAttributeNode w/no auto-vivved attr doesn\'t warn'; 169 170 $warn = 0; 171 $elem->attr(foo=>'bar'); 172 $attr = $elem->removeAttributeNode(getAttributeNode $elem "foo"); 173 $elem->attr(foo=>'baz'); 174 my $new_attr = $elem->getAttributeNode('foo'); 175 eval { 176 $elem->removeAttributeNode($attr), 177 } 178 ;isa_ok $@, 'HTML::DOM::Exception', 179 '$@ (after failed remAttributeNode w/auto-vivved attr)'; 180 cmp_ok $@, '==', HTML::DOM::Exception::NOT_FOUND_ERR, 181 'failed remAttributeNode w/auto-vivved attr throws the ' . 182 'appropriate error'; 183 is $warn, 0, 184 'failed remAttributeNode w/auto-vivved attr doesn\'t warn'; 185} 186 187 188# -------------------------# 189use tests 8; # getElementsByTagName 190 191{ 192 $doc->write(' 193 <div><!--sontoeutntont-->oentoeutn</div> 194 <form> 195 <div id=one> 196 <div id=two> 197 <div id=three> 198 <b id=bi>aoeu></b>teotn 199 </div> 200 </div> 201 <div id=four><i id=i></i> 202 </div> 203 </div> 204 </form> 205 '); 206 $doc ->close; 207 208 my($elem) = $doc->getElementsByTagName('form'); 209 my($div_list, $node_list); 210 211 my @ids = qw[ one two three four ]; 212 213 is_deeply [map id $_, getElementsByTagName $elem 'div'], \@ids, 214 'getElementsByTagName(div) in list context'; 215 216 is_deeply [map id $_, @{ 217 $div_list = getElementsByTagName $elem 'div' 218 }], \@ids, 219 'getElementsByTagName(div) in scalar context'; 220 221 @ids = qw[ one two three bi four i ]; 222 223 is_deeply [map $_->id, getElementsByTagName $elem '*'], 224 \@ids, 'getElementsByTagName(*) in list context'; 225 226 is_deeply [map $_->id, @{ 227 $node_list = getElementsByTagName$elem '*' 228 }], 229 \@ids, 'getElementsByTagName(*) in scalar context'; 230 231 # Now let's transmogrify it and make sure everything 232 # updates properly. 233 234 my($div1,$div2) = $elem->getElementsByTagName('div'); 235 $div1->removeChild($div2)->delete; 236 237 is_deeply [map id $_, @$div_list], [qw[ one four ]], 238 'div node list is updated'; 239 240 is_deeply [map $_->id || tag $_, @$node_list], 241 [qw[ one four i ]], '* node list is updated'; 242 243 244 # Bug in 0.040 and earlier 245 is $elem->getElementsByTagName('form')->length, 0, 246 'getEBTN looks only at the descendants, not the elem itself'; 247 is +()=$elem->getElementsByTagName('form'), 0, 248 'getEBTN (list cx) looks only @ descendants, not the elem itself'; 249} 250 251# -------------------------# 252use tests 4; # hasAttribute 253 254{ 255 my $elem = $doc->createElement('a'); 256 $elem->attr('target','_blank'); 257 ok $elem->hasAttribute('tarGet'), 'hasAttribute'; 258 ok !$elem->hasAttribute('hrEf'), '!hasAttribute'; 259 ok $elem->hasAttribute('shApe'), 'hasAttribute (implied)'; 260 my $doc = new HTML::DOM; 261 $doc->write('<!doctype html public "-//W3C//DTD HTML 4.01//EN" 262 "http://www.w3.org/TR/html4/strict.dtd">'); 263 $doc->close; 264 ok $doc->documentElement->hasAttribute('version'), 265 'doc elem ->hasAttribute(version)'; 266} 267 268# -------------------------# 269use tests 25; # default attirbute values with getAttribute 270{ 271 for( 272 [qw[ br clear none ]], 273 [qw[ td colspan 1 ]], 274 [qw[ th colspan 1 ]], 275 [qw[ form enctype application/x-www-form-urlencoded ]], 276 [qw[ frame frameborder 1 ]], 277 [qw[ iframe frameborder 1 ]], 278 [qw[ form method GET ]], 279 [qw[ td rowspan 1 ]], 280 [qw[ th rowspan 1 ]], 281 [qw[ frame scrolling auto ]], 282 [qw[ iframe scrolling auto ]], 283 [qw[ area shape rect ]], 284 [qw[ a shape rect ]], 285 [qw[ col span 1 ]], 286 [qw[ colgroup span 1 ]], 287 [qw[ input type TEXT ]], 288 [qw[ button type submit ]], 289 [qw[ param valuetype DATA ]], 290 ) { 291 is $doc->createElement($$_[0])->getAttribute($$_[1]), 292 $$_[2], "default value for @$_[0,1]"; 293 } 294 295 my $doc = new HTML::DOM; 296 $doc->write(' 297 <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN"> 298 <html><head> 299 <title>404 Not Found</title> 300 </head><body> 301 <h1>Not Found</h1> 302 <p>The requested URL /aoeu was not found on this server. 303 I\'ll try to look a little more closely next time.</p> 304 </body></html> 305 '); $doc->close; 306 307 is $doc->documentElement->getAttribute('version'), 308 '-//IETF//DTD HTML 2.0//EN', 309 'implied version is taken from doctype (2)'; 310 311 $doc->write(q* 312 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" 313 "http://www.w3.org/TR/html4/strict.dtd"> 314 315 <meta http-equiv=Content-Type 316 content='text/html;charset=utf-8'> 317 <link href=styles.css rel=stylesheet type='text/css' 318 media=all> 319 320 <title>Why do you want to see this?</title> 321 322 <style>div{border: }</style> 323 324 <!--bar--> 325 <table cellspacing=0 style='width: 100%; height: 35px; 326 white-space: nowrap' class='tab textbrown'> 327 <tr><td style='width: 300px; padding-right:5px'> 328 <div> ... snip ... 329 </div> 330 ... snip ... 331 </table> 332 ... snip ... 333 *); $doc->close; 334 is $doc->documentElement->getAttribute('version'), 335 '-//W3C//DTD HTML 4.01//EN', 336 'implied version is taken from doctype (4.01)'; 337 338 $doc->write(q* 339 <title>Back button experiment</title> 340 341 <iframe style='height:0;width:0;visibility:hidden; 342 margin:0;padding:0' src='iframe.html?1' 343 id=_back_></iframe> 344 <script> 345 //snipped 346 </script> 347 <div id=content>This is page 1.</div> 348 <a href='' onclick=' 349 go_to(+page+1); 350 return false 351 '>Next</a> 352 <br><br> 353 *); $doc->close; 354 355 is $doc->documentElement->getAttribute('version'), 356 '', 357 'no implied version without doctype'; 358 is +()=$doc->documentElement->getAttributeNode('version'), 0, 359 'getAttributeNode(version) in absence of doctype'; 360 361 my $elem = $doc->createElement('br'); 362 isa_ok $elem->getAttributeNode('clear'), 'HTML::DOM::Attr', 363 'getAttributeNode on unspecified attribute'; 364 365 # These 2 tests make sure that the DTD values don’t override 366 # explicit empty attributes: 367 $elem = $doc->createElement('form'); 368 $elem->attr(enctype => ''); 369 is $elem->getAttribute('enctype'), '', 370 'getAttribute on specified empty attribute'; 371 is $elem->getAttributeNode('enctype')->value, '', 372 'getAttribteNode on specified empty attribute'; 373} 374