1#!/usr/bin/perl -w 2 3use strict; 4use Carp; 5 6use File::Spec; 7use lib File::Spec->catdir(File::Spec->curdir,"t"); 8use tools; 9 10$|=1; 11my $DEBUG=0; 12 13use XML::Twig; 14 15my $TMAX=158; 16print "1..$TMAX\n"; 17 18{ 19#bug with long CDATA 20 21# get an accented char in iso-8859-1 22my $char_file=File::Spec->catfile('t', "latin1_accented_char.iso-8859-1"); 23open( CHARFH, "<$char_file") or die "cannot open $char_file: $!"; 24my $latin1_char=<CHARFH>; 25chomp $latin1_char; 26close CHARFH; 27 28my %cdata=( "01- 1023 chars" => 'x' x 1022 . 'a', 29 "02- 1024 chars" => 'x' x 1023 . 'a', 30 "03- 1025 chars" => 'x' x 1024 . 'a', 31 "04- 1026 chars" => 'x' x 1025 . 'a', 32 "05- 2049 chars" => 'x' x 2048 . 'a', 33 "06- 1023 chars spaces" => 'x' x 1020 . ' a', 34 "07- 1024 chars spaces" => 'x' x 1021 . ' a', 35 "08- 1025 chars spaces" => 'x' x 1022 . ' a', 36 "09- 1026 chars spaces" => 'x' x 1023 . ' a', 37 "10- 2049 chars spaces" => 'x' x 2048 . ' a', 38 "11- 1023 accented chars" => $latin1_char x 1022 . 'a', 39 "12- 1024 accented chars" => $latin1_char x 1023 . 'a', 40 "13- 1025 accented chars" => $latin1_char x 1024 . 'a', 41 "14- 1026 accented chars" => $latin1_char x 1025 . 'a', 42 "15- 2049 accented chars" => $latin1_char x 2048 . 'a', 43 "16- 1023 accented chars spaces" => $latin1_char x 1020 . ' a', 44 "17- 1024 accented chars spaces" => $latin1_char x 1021 . ' a', 45 "18- 1025 accented chars spaces" => $latin1_char x 1022 . ' a', 46 "19- 1026 accented chars spaces" => $latin1_char x 1023 . ' a', 47 "20- 2049 accented chars spaces" => $latin1_char x 2048 . ' a', 48 "21- 511 accented chars" => $latin1_char x 511 . 'a', 49 "22- 512 accented chars" => $latin1_char x 512 . 'a', 50 "23- 513 accented chars" => $latin1_char x 513 . 'a', 51 #"00- lotsa chars" => 'x' x 2000000 . 'a', # do not try this at home 52 # but if you do with a higher number, let me know! 53 ); 54 55if( ($] == 5.008) || ($] < 5.006) || ($XML::Parser::VERSION <= 2.27) ) 56 { skip( scalar keys %cdata, "KNOWN BUG in 5.8.0 and 5.005 or with XML::Parser 2.27 with keep_encoding and long (>1024 char) CDATA, " 57 . "see RT #14008 at http://rt.cpan.org/Ticket/Display.html?id=14008" 58 ); 59 } 60elsif( perl_io_layer_used()) 61 { skip( scalar keys %cdata, "cannot test parseurl when UTF8 perIO layer used " 62 . "(due to PERL_UNICODE being set or -C command line option being used)\n" 63 ); 64 } 65else 66 { 67 foreach my $test (sort keys %cdata) 68 { my $cdata=$cdata{$test}; 69 my $doc= qq{<?xml version="1.0" encoding="iso-8859-1" ?><doc><![CDATA[$cdata]]></doc>}; 70 my $twig= XML::Twig->new( keep_encoding => 1)->parse($doc); 71 my $res = $twig->root->first_child->cdata; 72 is( $res, $cdata, "long CDATA with keep_encoding $test"); 73 } 74 } 75} 76 77 78# subs_text on text with new lines 79{ my $doc= "<doc> foo1 \n foo2 </doc>"; 80 my $t= XML::Twig->new->parse( $doc); 81 (my $expected= $doc)=~ s{foo}{bar}g; 82 $t->subs_text( qr{foo}, "bar"); 83 is( $t->sprint, $expected, "subs_text on string with \n"); 84 $expected=~ s{ }{ }g; 85 $t->subs_text( qr{ }, q{&ent( " ")} ); 86 if( 0 && $] =~ m{^5.006}) 87 { skip( 1, "known bug in perl 5.6.*: subs_text with an entity matches line returns\n" 88 . " this bug is under investigation\n"); 89 } 90 else 91 { is( $t->sprint, $expected, "subs_text on string with \n"); } 92} 93 94# testing ID processing 95{ # setting existing id to a different value 96 my $t= XML::Twig->new->parse( '<doc id="i1"/>'); 97 $t->root->set_id( "i2"); 98 is( id_list( $t), "i2", "changing an existing id"); 99 $t->root->del_id(); 100 is( id_list( $t), "", "deleting an id"); 101 $t->root->del_id(); 102 is( id_list( $t), "", "deleting again an id"); 103 $t->root->set_id( "0"); 104 is( id_list( $t), "0", "changing an existing id to 0"); 105 $t->root->del_id(); 106 is( id_list( $t), "", "deleting again an id"); 107 108 109} 110 111{ # setting id through the att 112 my $t= XML::Twig->new->parse( '<doc id="i1"/>'); 113 $t->root->set_att( id => "i2"); 114 is( fid( $t, "i2"), "i2", "changing an existing id using set_att"); 115 $t->root->set_att( id => "0"); 116 is( fid( $t, "0"), "0", "using set_att with a id of 0"); 117 $t->root->set_atts( { id => "i3" }); 118 is( fid( $t, "i3"), "i3", "using set_atts"); 119 $t->root->set_atts( { id => "0" }); 120 is( fid( $t, "0"), "0", "using set_atts with an if of 0"); 121} 122 123{ # setting id through a new element 124 my $t= XML::Twig->new->parse( '<doc id="i1"/>'); 125 my $n= $t->root->insert_new_elt( elt => { id => "i2" }); 126 is( id_list( $t), "i1-i2", "setting id through a new element"); 127 $n= $t->root->insert_new_elt( elt => { id => "0" }); 128 is( id_list( $t), "0-i1-i2", "setting id through a new element"); 129} 130 131{ # setting ids through a parse 132 my $t= XML::Twig->new->parse( '<doc id="i1"/>'); 133 my $elt= XML::Twig::Elt->parse( '<elt id="i2"><selt id="i3"/><selt id="0"/></elt>'); 134 $elt->paste( $t->root); 135 is( id_list( $t), "0-i1-i2-i3", "setting id through a parse"); 136} 137 138{ # test ]]> in text 139 my $doc=q{<doc att="]]>">]]></doc>}; 140 is( XML::Twig->new->parse( $doc)->sprint, $doc, "]]> in char data"); 141} 142 143sub fid { my $elt= $_[0]->elt_id( $_[1]) or return "unknown"; 144 return $elt->att( $_[0]->{twig_id}); 145 } 146 147# testing ignore messing up with whitespace handling 148{ my $doc=qq{<doc>\n <elt2 ignore="1">ba</elt2>\n <elt>foo</elt>\n <elt2>bar</elt2>\n</doc>}; 149 my $res; 150 my $t= XML::Twig->new( twig_roots => { elt => sub { $_->ignore; }, 151 elt2 => sub { $res.= $_->text; }, 152 }, 153 start_tag_handlers => { elt2 => sub { $_[0]->ignore if( $_->att( 'ignore')); }, 154 }, 155 ); 156 $t->parse( $doc); 157 is( $res => 'bar', 'checking that ignore and whitespace handling work well together'); 158} 159 160# test on handlers with ns 161{ my $doc=q{<doc xmlns:ns="uri"> 162 <ns:elt ns:att="val" att2="ns_att" >elt with ns att</ns:elt> 163 <ns:elt att="val" att2="non_ns_att">elt with no ns att</ns:elt> 164 </doc> 165 }; 166 my( $res1, $res2); 167 my $t= XML::Twig->new( map_xmlns => { uri => 'n' }, 168 twig_handlers => { 'n:elt[@n:att="val"]' => sub { $res1 .= $_->text; }, 169 'n:elt[@att="val"]' => sub { $res2 .= $_->text; }, 170 }, 171 ) 172 ->parse( $doc); 173 is( $res1 => 'elt with ns att', 'twig handler on n:elt[@n:att="val"]'); 174 is( $res2 => 'elt with no ns att', 'twig handler on n:elt[@att="val"]'); 175} 176 177# same with start_tag handlers 178{ my $doc=q{<doc xmlns:ns="uri"> 179 <ns:elt ns:att="val" att2="ns_att" >elt with ns att</ns:elt> 180 <ns:elt att="val" att2="non_ns_att">elt with no ns att</ns:elt> 181 </doc> 182 }; 183 my( $res1, $res2); 184 my $t= XML::Twig->new( map_xmlns => { uri => 'n' }, 185 start_tag_handlers => { 'n:elt[@n:att="val"]' => sub { $res1 .= $_->att( 'att2'); }, 186 'n:elt[@att="val"]' => sub { $res2 .= $_->att( 'att2'); }, 187 }, 188 ) 189 ->parse( $doc); 190 is( $res1 => 'ns_att', 'start_tag handler on n:elt[@n:att="val"]'); 191 is( $res2 => 'non_ns_att', 'start_tag handler on n:elt[@att="val"]'); 192} 193 194# same with start_tag handlers and twig_roots 195{ my $doc=q{<doc xmlns:ns="uri"> 196 <ns:elt ns:att="val" att2="ns_att" >elt with ns att</ns:elt> 197 <ns:elt att="val" att2="non_ns_att">elt with no ns att</ns:elt> 198 </doc> 199 }; 200 my( $res1, $res2); 201 my $t= XML::Twig->new( map_xmlns => { uri => 'n' }, 202 twig_roots => { foo => 1 }, 203 start_tag_handlers => { 'n:elt[@n:att="val"]' => sub { my( $t, $gi, %atts)= @_; 204 $res1 .= $atts{att2}; 205 }, 206 'n:elt[@att="val"]' => sub { my( $t, $gi, %atts)= @_; 207 $res2 .= $atts{att2}; 208 }, 209 }, 210 ) 211 ->parse( $doc); 212 is( $res1 => 'ns_att', 'start_tag handler on n:elt[@n:att="val"]'); 213 is( $res2 => 'non_ns_att', 'start_tag handler on n:elt[@att="val"]'); 214} 215 216 217# tests for additional coverage 218{ my $doc=q{<doc><elt>foo</elt><elt2>bar</elt2></doc>}; 219 my $res=''; 220 my $t= XML::Twig->new; 221 $t->setTwigHandlers( { elt => sub { $res.= $_->text}, }); 222 $t->setTwigHandlers(); 223 $t->parse( $doc); 224 is( $res => '', 'setTwigHandlers with no argument'); 225} 226 227 228{ my $doc=q{<doc><elt>foo</elt><elt2>bar</elt2></doc>}; 229 my $res; 230 my $t= XML::Twig->new; 231 $t->setTwigHandlers( { elt => sub { $res.= $_->text}, }); 232 $t->parse( $doc); 233 is( $res => 'foo', 'setTwigHandlers by itself'); 234} 235 236{ my $doc=q{<doc><elt>foo</elt><elt2>bar</elt2></doc>}; 237 my $res=''; 238 my $t= XML::Twig->new; 239 $t->setTwigHandlers( { '/doc/elt' => sub { $res.= $_->text}, }); 240 $t->setTwigHandlers( { '/doc/elt' => undef, }); 241 $t->parse( $doc); 242 is( $res => '', 'setTwigHandlers with an undef path'); 243} 244 245{ my $doc=q{<doc><elt>foo</elt><elt2>bar</elt2></doc>}; 246 my $res=''; 247 my $t= XML::Twig->new; 248 $t->setTwigHandlers( { 'doc/elt' => sub { $res.= $_->text}, }); 249 $t->setTwigHandlers( { 'doc/elt' => undef, }); 250 $t->parse( $doc); 251 is( $res => '', 'setTwigHandlers with an undef subpath'); 252} 253 254{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>}; 255 my $res=''; 256 my $t= XML::Twig->new; 257 $t->setTwigHandlers( { 'elt[@att="baz"]' => sub { $res.= $_->text}, }); 258 $t->setTwigHandlers( { 'elt[@att="bak"]' => sub { $res.= $_->text}, }); 259 $t->setTwigHandlers( { 'elt[@att="baz"]' => undef, }); 260 $t->setTwigHandlers( { 'elt[@att="bal"]' => undef, }); 261 $t->parse( $doc); 262 is( $res => '', 'setTwigHandlers with an undef att cond'); 263} 264 265{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>}; 266 my $res=''; 267 my $t= XML::Twig->new; 268 $t->setTwigHandlers( { 'elt[@att=~/baz/]' => sub { $res.= $_->text}, }); 269 $t->setTwigHandlers( { 'elt[@att=~/bar/]' => sub { $res.= $_->text}, }); 270 $t->setTwigHandlers( { 'elt[@att=~/baz/]' => undef, }); 271 $t->setTwigHandlers( { 'elt[@att=~/bas/]' => undef, }); 272 $t->parse( $doc); 273 is( $res => '', 'setTwigHandlers with undef regexp on att conds'); 274} 275 276{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>}; 277 my $res=''; 278 my $t= XML::Twig->new; 279 $t->setTwigHandlers( { 'elt[string()="foo"]' => sub { $res.= $_->text}, }); 280 $t->setTwigHandlers( { 'elt[string()="fool"]' => sub { $res.= $_->text}, }); 281 $t->setTwigHandlers( { 'elt[string()="foo"]' => undef} ); 282 $t->setTwigHandlers( { 'elt[string()="food"]' => undef} ); 283 $t->parse( $doc); 284 is( $res => '', 'setTwigHandlers with undef string conds'); 285} 286 287{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>}; 288 my $res=''; 289 my $t= XML::Twig->new; 290 $t->setTwigHandlers( { 'elt[string()=~/foo/]' => sub { $res.= $_->text}, }); 291 $t->setTwigHandlers( { 'elt[string()=~/fool/]' => sub { $res.= $_->text}, }); 292 $t->setTwigHandlers( { 'elt[string()=~/foo/]' => undef}); 293 $t->setTwigHandlers( { 'elt[string()=~/food/]' => undef}); 294 $t->parse( $doc); 295 is( $res => '', 'setTwigHandlers with undef string regexp conds'); 296} 297 298{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>}; 299 my $res=''; 300 my $t= XML::Twig->new; 301 $t->setTwigHandlers( { '*[@att="baz"]' => sub { $res.= $_->text}, }); 302 $t->setTwigHandlers( { '*[@att="bak"]' => sub { $res.= $_->text}, }); 303 $t->setTwigHandlers( { '*[@att="baz"]' => undef, }); 304 $t->setTwigHandlers( { '*[@att="bal"]' => undef, }); 305 $t->parse( $doc); 306 is( $res => '', 'setTwigHandlers with an undef start att cond'); 307} 308 309{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>}; 310 my $res=''; 311 my $t= XML::Twig->new; 312 $t->setTwigHandlers( { '*[@att=~/baz/]' => sub { $res.= $_->text}, }); 313 $t->setTwigHandlers( { '*[@att=~/bak/]' => sub { $res.= $_->text}, }); 314 $t->setTwigHandlers( { '*[@att=~/baz/]' => undef, }); 315 $t->setTwigHandlers( { '*[@att=~/bal/]' => undef, }); 316 $t->parse( $doc); 317 is( $res => '', 'setTwigHandlers with an undef start att regexp cond'); 318} 319 320{ my $doc=q{<doc><elt att="baz">foo</elt><elt>bar</elt></doc>}; 321 my $res=''; 322 my $t= XML::Twig->new; 323 $t->setStartTagHandlers( { 'elt[@att="baz"]' => sub { $res.= 'not this one'}, }); 324 $t->setStartTagHandlers( { 'elt[@att="bal"]' => sub { $res.= $_->att( 'att') || 'none'}, }); 325 $t->setStartTagHandlers( { 'elt[@att="baz"]' => sub { $res.= $_->att( 'att') || 'none'}, }); 326 $t->parse( $doc); 327 is( $res => 'baz', 'setStartTagHandlers'); 328} 329 330{ my $doc=q{<doc><title>title</title><sect><elt>foo</elt><elt>bar</elt></sect></doc>}; 331 my $res=''; 332 my $t= XML::Twig->new( twig_handlers => { 'level(2)' => sub { $res .= $_->text;} }) 333 ->parse( $doc); 334 is( $res => 'foobar', 'level cond'); 335} 336 337{ my $doc=q{<doc><title>title</title><sect><elt>foo</elt><elt>bar</elt></sect></doc>}; 338 my $res=''; 339 my $t= XML::Twig->new( twig_roots => { 'level(2)' => sub { $res .= $_->text;} }) 340 ->parse( $doc); 341 is( $res => 'foobar', 'level cond'); 342} 343 344 345{ my $doc=q{<doc><?t1 d1?><elt/><?t2 d2?></doc>}; 346 my $res=''; 347 XML::Twig->new( pi => 'process', twig_handlers => { '?' => sub { $res.=$_->data } })->parse( $doc); 348 is( $res => 'd1d2', '? (any pi) handler'); 349} 350 351{ my $doc=q{<doc><elt>foo <!--commment--> bar</elt></doc>}; 352 my $t= XML::Twig->new->parse( $doc); 353 is( $t->sprint, $doc, 'embedded comments, output asis'); 354 $t->root->first_child( 'elt')->first_child->set_pcdata( 'toto'); 355 is( $t->sprint, '<doc><elt>toto</elt></doc>', 'embedded comment removed'); 356} 357 358 359{ my $doc=q{<?xml version="1.0" ?> 360 <!DOCTYPE doc [ <!ELEMENT doc (#PCDATA)> 361 <!ENTITY ent "foo"> 362 ] 363 > 364 <doc> a &ent; is here</doc> 365 }; 366 my $t= XML::Twig->new->parse( $doc); 367 $t->entity_list->add_new_ent( ent2 => 'bar'); 368 my $res= $t->sprint(); 369 is_like( $res, qq{<?xml version="1.0" ?><!DOCTYPE doc[<!ELEMENT doc (#PCDATA)><!ENTITY ent "foo">]>} 370 .qq{<doc> a foo is here</doc>}, 'new ent, no update dtd'); 371 372 373 $res=$t->sprint( updateDTD => 1); 374 is_like( $res, qq{<?xml version="1.0" ?><!DOCTYPE doc[<!ELEMENT doc (#PCDATA)><!ENTITY ent "foo">} 375 . qq{<!ENTITY ent2 "bar">]><doc> a foo is here</doc>}, 376 'new ent update dtd' 377 ); 378} 379 380{ my $t=XML::Twig->new->parse( '<doc/>'); 381 $t->{entity_list}= XML::Twig::Entity_list->new; 382 $t->entity_list->add_new_ent( foo => 'bar'); 383 is_like( $t->sprint( update_DTD => 1), '<!DOCTYPE doc [<!ENTITY foo "bar">]><doc/>', "new entity with update DTD"); 384} 385 386{ my $t=XML::Twig->new( keep_encoding => 1)->parse( '<doc/>'); 387 $t->{entity_list}= XML::Twig::Entity_list->new; 388 $t->entity_list->add_new_ent( foo => 'bar'); 389 is_like( $t->sprint( update_DTD => 1), '<!DOCTYPE doc [<!ENTITY foo "bar">]><doc/>', 390 "new entity (keep_encoding)with update DTD" 391 ); 392} 393 394{ my $dtd= q{<!DOCTYPE doc [<!ELEMENT doc (elt+)> 395 <!ATTLIST doc id ID #IMPLIED> 396 <!ELEMENT elt (#PCDATA)> 397 <!ATTLIST elt att CDATA 'foo' 398 fixed CDATA #FIXED 'fixed' 399 id ID #IMPLIED 400 > 401 ]> 402 }; 403 my $doc= q{<doc id="d1"><elt id="e1" att="toto">tata</elt><elt/></doc>}; 404 my $t= XML::Twig->new->parse( $dtd . $doc); 405 is_like( $t->dtd_text, $dtd, "dtd_text"); 406} 407 408{ my $t=XML::Twig->new->parse( '<doc><elt/></doc>'); 409 is( $t->root->first_child( 'elt')->sprint, '<elt/>', "nav, first pass"); 410 is( $t->root->first_child( 'elt')->sprint, '<elt/>', "nav, second pass"); 411 is_undef( scalar $t->root->first_child( 'elt')->parent( 'toto'), "undef parent 1"); 412 is_undef( scalar $t->root->parent( 'toto'), "undef parent 2"); 413 is_undef( scalar $t->root->parent(), "undef parent 3"); 414} 415 416{ my $t= XML::Twig->new->parse( '<doc id="myid"><elt/></doc>'); 417 my $id= $t->root->id; 418 $t->root->add_id(); 419 is( $t->root->id, $id, "add_id on existing id"); 420 my $elt= $t->root->first_child( 'elt'); 421 $elt->cut; 422 $elt->set_id( 'elt1'); 423 is_undef( $t->elt_id( 'elt1'), "id added to elt outside the doc"); 424 $elt->paste( $t->root); 425 is( $t->elt_id( 'elt1')->gi => 'elt', "elt put back in the tree"); 426 427 # these tests show a bug: the id list is not updated when an element is cut 428 $elt->cut; 429 $elt->del_id; 430 $elt->del_id; # twice to go through a different path 431 $elt->paste( $t->root); 432 is( $t->elt_id( 'elt1')->gi => 'elt', "elt put back in the tree without id"); 433 $elt->del_id; 434 is( $t->elt_id( 'elt1')->gi => 'elt', "deleting an inexisting id which remains in the list"); 435 is( scalar $elt->ancestors_or_self( 'elt'), 1, "ancestors_or_self with cond"); 436 is( scalar $elt->ancestors_or_self(), 2, "ancestors_or_self without cond"); 437 my @current_ns_prefixes= $elt->current_ns_prefixes; 438 is( scalar @current_ns_prefixes, 0, "current_ns_prefixes"); 439 is_undef( $elt->next_elt( $elt), 'next_elt on an empty elt (limited to the subtree)'); 440 is_undef( $elt->next_elt( $elt, 'foo'), 'next_elt on an empty elt (subtree and elt name)'); 441 is_undef( $elt->next_elt( 'foo'), 'next_elt on an empty elt (elt name)'); 442 is_undef( $elt->prev_elt( $elt), 'prev_elt on an empty elt (limited to the subtree)'); 443 is_undef( $elt->prev_elt( $elt, 'foo'), 'prev_elt on an empty elt (subtree and elt name)'); 444 is_undef( $elt->prev_elt( 'foo'), 'prev_elt on an empty elt (elt name)'); 445 is_undef( $elt->next_n_elt( 1, 'foo'), 'next_n_elt'); 446 is_undef( $elt->next_n_elt( 0, 'foo'), 'next_n_elt'); 447 is( $elt->level(), 1, "level"); 448 is( $elt->level( 'elt'), 0, "level"); 449 is( $elt->level( 'doc'), 1, "level"); 450 is( $elt->level( 'foo'), 0, "level"); 451 ok( $elt->in_context( 'doc'), "in_context doc "); 452 ok( $elt->in_context( 'doc', 0), "in_context doc with level (0)"); 453 ok( $elt->in_context( 'doc', 1), "in_context doc with level"); 454 ok( $elt->in_context( 'doc', 2), "in_context doc with level"); 455 nok( $elt->in_context( 'foo'), "in_context foo"); 456 nok( $elt->in_context( 'foo', 0), "in_context foo with level (0)"); 457 nok( $elt->in_context( 'foo', 1), "in_context foo with level"); 458 nok( $elt->in_context( 'foo', 2), "in_context foo with level (0)"); 459 nok( $elt->in_context( 'elt'), "in_context elt"); 460 nok( $elt->in_context( 'elt', 0), "in_context elt with level (0)"); 461 nok( $elt->in_context( 'elt', 1), "in_context elt with level"); 462 nok( $elt->in_context( 'elt', 2), "in_context elt with level (0)"); 463} 464 465{ foreach my $doc ( '<doc><!-- extra data --><ERS><sub/></ERS></doc>', 466 '<doc><!-- extra data --><ERS>toto<sub/></ERS>toto</doc>', 467 '<doc>toto<!-- extra data --><ERS>toto<sub/></ERS>toto</doc>', 468 '<doc>toto<!-- extra data -->tata<ERS>toto<sub/></ERS>toto</doc>', 469 '<doc>toto<!-- extra data --><ERS>titi <!-- more ed --> tutu<sub/></ERS>toto</doc>', 470 '<doc>toto<!-- extra data --><ERS><!-- more ed --> tutu<sub/></ERS>toto</doc>', 471 '<doc><!-- extra data --><ERS><!-- more ed --><sub/></ERS>toto</doc>', 472 '<doc><!-- extra data --><ERS><!-- more ed -->foo<sub/></ERS>toto</doc>', 473 '<doc><!-- extra data --><ERS>toto<sub/></ERS>toto</doc>', 474 '<doc><!-- extra data --><ERS></ERS><elt2/></doc>', 475 '<doc><!-- extra data --><ERS></ERS></doc>', 476 '<doc><!-- extra data --><ERS></ERS>toto</doc>', 477 '<doc><elt><!-- extra data --><ERS></ERS></elt></doc>', 478 '<doc><elt>foo<!-- extra data --><ERS></ERS></elt></doc>', 479 '<doc><elt><selt/><!-- extra data --><ERS></ERS></elt></doc>', 480 '<doc><!-- extra data --><ERS><foo/></ERS></doc>', 481 '<doc><elt><!-- extra data --><ERS></ERS></elt></doc>', 482 '<doc><elt><!-- extra data --><ERS><foo/></ERS></elt></doc>', 483 '<doc><elt><!-- extra data --><ERS></ERS></elt></doc>', 484 '<ERS><!-- extra data --><elt></elt></ERS>', 485 '<!-- extra data --><ERS><elt/></ERS>', 486 '<!-- first comment --><ERS><!-- extra data --><elt></elt></ERS>', 487 # this one does not work: nothing in XML::Twig to output stuff after the fiinal end tag 488 #'<!-- first comment --><ERS><!-- extra data --><elt></elt><!-- end comment --></ERS>', 489 '<doc><ERS>foo<!-- edbet --></ERS><!-- edbet 2 --></doc>', 490 '<doc><ERS>foo<!-- edbet --></ERS></doc>', 491 '<doc><ERS>foo<!-- edbet --></ERS><elt/></doc>', 492 '<doc><ERS>foo<!-- edbet --></ERS><!-- edbet 2 --><elt/></doc>', 493 '<doc><ERS>foo<!-- edbet --></ERS><!-- edbet 2 --><elt>toto</elt></doc>', 494 '<doc><ERS>foo<!-- edbet --></ERS>foo</doc>', 495 '<doc><ERS>foo<!-- edbet --></ERS>foo<!-- edbet 2 --><elt/></doc>', 496 '<doc><ERS>foo<!-- edbet --></ERS>foo<!-- edbet 2 --></doc>', 497 '<doc><ERS>foo<!-- edbet --></ERS><!-- edbet 2 -->foo<elt/></doc>', 498 '<doc><ERS>foo<!-- edbet --></ERS><!-- edbet 2 -->foo</doc>', 499 '<doc><ERS>foo<!-- edbet --></ERS>foo<!-- edbet 2 -->foo<elt/></doc>', 500 '<doc><ERS>foo<!-- edbet --></ERS>foo<!-- edbet 2 -->foo</doc>', 501 '<doc><elt><ERS>foo<!-- edbet --></ERS><!-- edbet 2 --></elt></doc>', 502 ) 503 { my $t=XML::Twig->new->parse( $doc); 504 $t->first_elt( 'ERS')->erase; 505 (my $expected= $doc)=~ s{</?ERS/?>}{}g; 506 is( $t->sprint, $expected, "erase in $doc"); 507 } 508} 509 510{ my $t=XML::Twig->new->parse( '<doc><p>toto</p></doc>'); 511 my $pcdata= $t->first_elt( '#PCDATA'); 512 $pcdata->split_at( 2); 513 is( $t->sprint => '<doc><p>toto</p></doc>', 'split_at'); 514} 515 516{ my $doc= q{<doc>tototata<e>tu</e></doc>}; 517 my $t= XML::Twig->new->parse( $doc); 518 $t->subs_text( qr/(to)ta/, '&elt(p => $1)ti'); 519 is( $t->sprint,'<doc>to<p>to</p>tita<e>tu</e></doc>' , 'subs_text'); 520 $t->subs_text( qr/(to)ta/, '&elt(p => $1)ti'); 521 is( $t->sprint,'<doc>to<p>to</p>tita<e>tu</e></doc>' , 'subs_text (2cd try, same exp)'); 522 $t->subs_text( qr/(ta)/, '&elt(p1 => $1)ti'); 523 is( $t->sprint,'<doc>to<p>to</p>ti<p1>ta</p1>ti<e>tu</e></doc>' , 'subs_text cannot merge text with next sibling'); 524} 525 526{ my $doc= q{<doc>tota<e>tu</e></doc>}; 527 my $t= XML::Twig->new->parse( $doc); 528 $t->subs_text( qr/(to)/, '&elt(e => $1)'); 529 is( $t->sprint,'<doc><e>to</e>ta<e>tu</e></doc>' , 'subs_text (new elt)'); 530 $t->subs_text( qr/(ta)/, '&elt(e => $1)'); 531 is( $t->sprint,'<doc><e>to</e><e>ta</e><e>tu</e></doc>' , 'subs_text (new elt 2)'); 532 $t->subs_text( qr/(t.)/, '&elt(se => $1)'); 533 is( $t->sprint,'<doc><e><se>to</se></e><e><se>ta</se></e><e><se>tu</se></e></doc>' , 'subs_text (several subs)'); 534} 535 536{ my $doc= q{<doc>totatitu</doc>}; 537 my $t= XML::Twig->new->parse( $doc); 538 $t->subs_text( qr/(t[aeiou])/, '$1$1'); 539 is( $t->sprint,'<doc>tototatatititutu</doc>' , 'subs_text (duplicate string)'); 540 $t->subs_text( qr/((t[aeiou])\2)/, '$2'); 541 is( $t->sprint,'<doc>totatitu</doc>' , 'subs_text (use \2)'); 542 $t->subs_text( qr/(t[aeiou])/, '$1$1'); 543 is( $t->sprint,'<doc>tototatatititutu</doc>' , 'subs_text (duplicate string)'); 544 $t->subs_text( qr/(t[aeiou]t[aeiou])/, '&elt( p => $1)'); 545 is( $t->sprint,'<doc><p>toto</p><p>tata</p><p>titi</p><p>tutu</p></doc>' , 'subs_text (use \2)'); 546} 547 548{ my $doc= q{<doc><!-- comment --><e> toto <!-- comment 2 --></e> 549 <e2 att="val1" att2="val2"><!-- comment --><e> toto <!-- comment 2 --></e></e2> 550 <e>foo <?tg pi?> bar <!-- duh --> baz</e> 551 <e><?tg pi?> bar <!-- duh --> baz</e> 552 <e><?tg pi?> bar <!-- duh --></e> 553 </doc> 554 }; 555 my $t= XML::Twig->new->parse( $doc); 556 my $copy= $t->root->copy; 557 is( $copy->sprint, $t->root->sprint, "copy with extra data"); 558 $t->root->insert_new_elt( first_child => a => { '#ASIS' => 1 }, 'a <b>c</b> a'); 559 $copy= $t->root->copy; 560 is( $copy->sprint, $t->root->sprint, "copy with extra data, and asis"); 561} 562 563{ my $save= XML::Twig::_weakrefs(); 564 XML::Twig::_set_weakrefs( 0); 565 my $t= XML::Twig->new->parse( '<doc><e id="e1"/><e id="e2">foo <f id="oo"/></e></doc>'); 566 $t->root->first_child->cut->DESTROY; 567 $t->root->first_child->cut->DESTROY; 568 is( $t->sprint, '<doc></doc>', 'DESTROY'); 569 XML::Twig::_set_weakrefs( $save); 570} 571 572{ # test _keep_encoding even with perl > 5.8.0 573 if( $] < 5.008) 574 { skip( 2 => "testing utf8 flag mongering only needed in perl 5.8.0+"); } 575 else 576 { require Encode; import Encode; 577 my $s="a"; 578 Encode::_utf8_off( $s); 579 nok( Encode::is_utf8( $s), "utf8 flag off"); 580 XML::Twig::Elt::_utf8_ify( $s); 581 if( $] >= 5.008 and $] < 5.010) 582 { ok( Encode::is_utf8( $s), "utf8 flag back on"); } 583 else 584 { nok( Encode::is_utf8( $s), "_utf8_ify is a noop"); } 585 } 586} 587 588{ # test keep_encoding 589 is( XML::Twig::Elt::_keep_encoding(), 0, "_keep_encoding not initialized"); 590 XML::Twig->new( keep_encoding => 0); 591 is( XML::Twig::Elt::_keep_encoding(), 0, "_keep_encoding initialized (0)"); 592 XML::Twig->new( keep_encoding => 1); 593 is( XML::Twig::Elt::_keep_encoding(), 1, "_keep_encoding initialized (1)"); 594 XML::Twig->new( keep_encoding => 0); 595 is( XML::Twig::Elt::_keep_encoding(), 0, "_keep_encoding initialized (0)"); 596} 597 598 599 600