XML-Twig
view release on metacpan or search on metacpan
t/test_additional.t view on Meta::CPAN
#!/usr/bin/perl -w
# test designed to improve coverage of the module
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
my $DEBUG=0;
use XML::Twig;
my $perl= $];
my $open;
BEGIN
{ if( $] < 5.008)
{ $open= sub { return }; }
else
{ $open= eval( 'sub { open( $_[0], $_[1], $_[2]) }'); }
}
my $TMAX=663;
print "1..$TMAX\n";
{
my $t= XML::Twig->new->parse( q{
<doc>
<cdata><![CDATA[cdata 01]]></cdata>
<cdata>foo <![CDATA[cdata <02>]]> bar </cdata>
</doc>
});
# use CDATA
my $cdata= $t->first_elt( CDATA)->text;
is( $cdata, 'cdata 01', 'first_elt( CDATA)');# test 1
is( $t->first_elt( CDATA)->cdata_string, '<![CDATA[cdata 01]]>', 'cdata_string');# test 2
is( $t->root->cdata_string, '', 'cdata_string for non cdata element');# test 3
my $cdata2= $t->root->first_child( 'cdata[2]')->next_elt( CDATA)->text;
is( $cdata2, 'cdata <02>', 'first_child( cdata[2])');# test 4
}
# test warning for invalid options
my $old_warning_handler= $SIG{__WARN__};
{
my $warning="";
$SIG{__WARN__} = sub { $warning.= join '', @_ };
XML::Twig->new( dummy_opt => 1);
$SIG{__WARN__}= $old_warning_handler;
chomp $warning;
matches( $warning, qr{^invalid option DummyOpt}, "expecting 'invalid option DummyOpt...', got '$warning'");# test 5
# test no warming if more_options is used
$warning="";
$SIG{__WARN__} = sub { $warning.= join '', @_ };
XML::Twig->new( more_options => 1, dummy_opt => 1);
$SIG{__WARN__}= $old_warning_handler;
nok( $warning, "expecting no warning, got '$warning'");# test 6
$warning="";
$SIG{__WARN__} = sub { $warning.= join '', @_ };
XML::Twig::add_options( 'dummy_opt');
XML::Twig->new( dummy_opt => 1);
$SIG{__WARN__}= $old_warning_handler;
nok( $warning, "expecting no warning (2), got '$warning'");# test 7
}
{
# test do_not_chain_handlers
my $nb_calls=0;
my $t= XML::Twig->new( twig_handlers => { chain => sub { $nb_calls++; 1;},
'doc/chain' => sub { $nb_calls++; 1;},
},
)->parse( '<doc><chain>chained</chain></doc>');
is( $nb_calls, 2, "chained calls");# test 8
$nb_calls=0;
$t= XML::Twig->new( twig_handlers => { chain => sub { $nb_calls++; 1 },
'doc/chain' => sub { $nb_calls++; 1 },
},
do_not_chain_handlers => 1,
)->parse( '<doc><chain>chained</chain></doc>');
is( $nb_calls, 1, "not chained calls");# test 9
$nb_calls=0;
$t= XML::Twig->new( twig_handlers => { chain => sub { $nb_calls++; 0; },
'doc/chain' => sub { $nb_calls++; 0; },
},
)->parse( '<doc><chain>chained</chain></doc>');
is( $nb_calls, 1, "chained handlers returning 0");# test 10
}
# test ignore_elt
{ my $t= XML::Twig->new( ignore_elts => { i1 => 1, i2 => 2})
->parse( '<doc><i1><t/></i1>
<t/><y><t/></y>
<i2><t/><y><t/><i1><t/></i1><t/></y></i2>
<i2><t/><y><t/><i2><t/></i2><t/></y></i2>
<t><t/></t>
</doc>');
my @t= $t->findnodes( '//t');
my $nb_t= scalar @t;
is( $nb_t, 4, 'findnodes //t');# test 11
}
# test elt_class
{
my $t= XML::Twig->new( elt_class => 'twig_test')->parse( '<doc><elt/></doc>');
package twig_test;
use base 'XML::Twig::Elt';
sub test { return 25 }
package main;
is( $t->root->test, 25, 'elt_class');# test 12
}
# test char_handler
{
my $t= XML::Twig->new( char_handler => sub { my $s= shift; $s=~ s/\w/./g; return $s; })
->parse( '<doc><elt>foo</elt><elt att="bar">baz</elt></doc>');
my $text= $t->root->text;
is( $text, '......', 'silly char_handler');# test 13
my $att= $t->root->last_child( 'elt')->att( 'att');
is( $att, 'bar', 'last_child');# test 14
$att= $t->root->last_child( 'elt')->att( 'att'); # to use the cache
is( $att, 'bar', 'last_child');# test 15
}
# test various methods
{ my $t= XML::Twig->new->parse( '<doc><elt/><elt/></doc>');
my @new_children= $t->root->children_copy;
$t->set_id_seed( 'toto_');
$_->add_id foreach @new_children;
my $id= $new_children[0]->att( 'id');
is( $id, 'toto_1', 'copy att');# test 16
$new_children[1]->change_att_name( id => 'foo');
my $foo= $new_children[1]->att( 'foo');
is( $foo, 'toto_2', 'change_att_name');# test 17
ok( $t->root->all_children_are( 'elt'), "all_children_are( 'elt')");# test 18
nok( $t->root->all_children_are( 'none'), "all_children_are( 'none')");# test 19
my $count= $t->root->children_count( 'elt');
is( $count, 2, "children_count( 'elt')");# test 20
$count= $t->root->children_count( 'none');
is( $count, 0, "children_count( 'none')");# test 21
$count= $t->root->children_count;
is( $count, 2, "children_count");# test 22
ok( $t->root->first_child_matches( 'elt'), "first_child_matches");# test 23
$t->root->insert_new_elt( 'p');
nok( $t->root->all_children_are( 'elt'), "all_children_are( 'elt') (with p child)");# test 24
}
# test cdata append_cdata, append_extra_data, append_pcdata
{
my $t=XML::Twig->new->parse( '<doc><elt>text <![CDATA[some cdata]]> more text</elt></doc>');
my $cdata= $t->root->next_elt( CDATA)->cdata;
is( $cdata, 'some cdata', 'created CDATA element');# test 25
$t->root->next_elt( CDATA)->append_cdata( ' appended<>');
$t->root->next_elt( PCDATA)->append_pcdata( 'more ');
$t->root->first_child( 'elt')->append_extra_data( '<!-- comment -->');
is( $t->sprint, '<doc><!-- comment --><elt>text more <![CDATA[some cdata appended<>]]> more text</elt></doc>', "append_extra_data");# test 26
}
# test att_names and att_to_field
{
my $t= XML::Twig->new->parse( '<doc><elt att1="foo" att2="bar"/></doc>');
my $elt= $t->root->first_child_matches( 'elt');
ok( $elt, "first_child_matches");# test 27
my $att_names= join ':', sort $elt->att_names;
is( $att_names, 'att1:att2', "att_names");# test 28
$elt->att_to_field( 'att1');
$elt->att_to_field( att2 => "new");
my $elt_string= $elt->sprint;
is( $elt_string, '<elt><new>bar</new><att1>foo</att1></elt>', "att_to_field")# test 29
}
# test child_matches child_text child_trimmed_text children_text
{
my $t= XML::Twig->new->parse( '<doc><elt> text </elt><elt2> text text</elt2></doc>');
my $root= $t->root;
ok( $root->child_matches( 1, 'elt2'), "child_matches");# test 30
my $text= $root->child_text( 0);
is( $text, ' text ', "child_text");# test 31
$text= $root->child_trimmed_text( -1, 'elt2');
is( $text, 'text text', "child_trimmed_text", 25 );# test 32
$text= join( '-', $root->children_text( qr/elt/));
is( $text, ' text - text text', "children_text");# test 33
}
# test _ancestors _children _descendants
{ my $t= XML::Twig->new->parse( '<doc><elt1/><elt2><elt3/></elt2></doc>');
is( tags( $t->root->_children), 'elt1:elt2', "_children");# test 34
is( tags( $t->root->_descendants), 'elt1:elt2:elt3', "_descendants");# test 35
is( $t->root->last_child_matches( 'elt3') ? "matches" : "no match",# test 36
"no match", "last_child_matches (no match)");
my $elt3= $t->root->last_child_matches( 'elt2')->first_child;
is( $elt3->gi, 'elt3', "last_child_matches (match)");# test 37
is( tags( $elt3->_ancestors), 'elt2:doc', "_ancestors");# test 38
is( tags( $elt3->_ancestors(1)), 'elt3:elt2:doc', "_ancestors(1)");# test 39
is( tags( $t->root->descendants( 'elt1')), 'elt1', 'descendants with gi');# test 40
is( tags( $t->root->descendants()), 'elt1:elt2:elt3', 'descendants without gi');# test 41
is( tags( $t->root->descendants( qr/^elt/)), 'elt1:elt2:elt3', 'descendants with qr');# test 42
is( tags( $t->root->descendants( qr/^elt/)), 'elt1:elt2:elt3', 'descendants with qr (using cache)');# test 43
}
# test comment methods
{
my $t= XML::Twig->new( comments => 'process')
->parse( '<doc><elt>text <!-- foo --></elt></doc>');
my $comment= $t->first_elt( '#COMMENT');
is( $comment->comment, ' foo ', "comment");# test 44
is( $comment->comment_string, '<!-- foo -->', "comment");# test 45
}
# test element creation
{
my $t= XML::Twig->new->parse( '<doc/>');
my $root= $t->root;
my $elt= $root->insert_new_elt( first_child => 'elt');
my $elt3= $elt->insert_new_elt( after => elt3 => "elt3 text");
my $elt2= $elt3->insert_new_elt( before => elt2 => { att => "foo" }, "elt2 text");
is( $t->sprint, '<doc><elt/><elt2 att="foo">elt2 text</elt2><elt3>elt3 text</elt3></doc>',# test 46
"insert_new_elt");
$root->cut_children;
is( $t->sprint, '<doc/>', "cut_children");# test 47
$elt= $root->insert_new_elt( last_child => 'elt' => { '#ASIS' => 1 }, "<p>bar</p>");
is( $elt->is_asis ? 'asis' : 'not asis', 'asis', "is_asis (initial, yes)");# test 48
is( $t->sprint, '<doc><elt><p>bar</p></elt></doc>', "insert_new_elt (ASIS)");# test 49
$elt->set_not_asis;
is( $elt->is_asis ? 'asis' : 'not asis', 'not asis', "is_asis (unset, no)");# test 50
is( $t->sprint, '<doc><elt><p>bar</p></elt></doc>', "set_not_asis");# test 51
$elt->set_asis;
is( $elt->is_asis ? 'asis' : 'not asis', 'asis', "is_asis (set, yes)");# test 52
is( $t->sprint, '<doc><elt><p>bar</p></elt></doc>', "set_asis");# test 53
$root->cut_children;
$root->insert_new_elt( first_child => '#CDATA' => "toto");
is( $t->sprint, '<doc><![CDATA[toto]]></doc>', "create CDATA");# test 54
is($root->last_child_matches( '#CDATA') ? "match" : "no match", "match", "last_child_matches (yes)");# test 55
is($root->last_child_matches( "foo") ? "match" : "no match", "no match", "last_child_matches (no)");# test 56
my $cdata= $root->last_child_matches( '#CDATA');
ok( $cdata->is_cdata, "cdata is_cdata");# test 57
nok( $cdata->is_comment, "cdata is_comment");# test 58
nok( $cdata->is_pi, "cdata is_pi");# test 59
nok( $cdata->is_empty, "cdata is_empty");# test 60
nok( $cdata->is_ent, "cdata is_ent");# test 61
ok( $cdata->is_first_child, "cdata is_first_child");# test 62
ok( $cdata->is_last_child, "cdata is_last_child");# test 63
}
# test field last_child_text last_child_trimmed_text
{ my $t= XML::Twig->new->parse( '<doc><field1>val1</field1><field2>val2</field2></doc>');
my $root= $t->root;
$root->set_field( field2 => "new val2 ");
is( $root->last_child_text( 'field2'), "new val2 ", "set_field");# test 64
is( $root->last_child_trimmed_text( 'field2'), "new val2", "set_field (trimmed text)");# test 65
is( $root->last_child_text( 'field1'), "val1", "last_child_text");# test 66
$root->set_field( field3 => "val3");
is( $t->sprint, '<doc><field1>val1</field1><field2>new val2 </field2><field3>val3</field3></doc>',# test 67
"set_field (new field)");
}
# test next/prev navigation functions
{ my $t= XML::Twig->new->parse(
q{<doc><elt id="elt_1">elt 1</elt>
<elt id="elt_2">elt 2</elt>
<sect id="sect_1"><elt id="elt_3">elt 3</elt><elt id="elt_4">elt 4</elt></sect>
<elt id="elt_5">elt 5 </elt>
</doc>}
);
my $root= $t->root;
my $elt1= $t->getElementById( 'elt_1');
is( $elt1->sprint, '<elt id="elt_1">elt 1</elt>', "getElementById");# test 68
my $sect= $elt1->getElementById( 'sect_1');
is( $sect->sprint, '<sect id="sect_1"><elt id="elt_3">elt 3</elt><elt id="elt_4">elt 4</elt></sect>', "getElementById (sect)");# test 69
ok( $elt1->next_elt_matches( '#PCDATA[text()="elt 1"]'), "next_elt_matches (elt1 => elt)");# test 70
ok( $elt1->prev_elt_matches( 'doc'), "prev_elt_matches (elt1 => doc)");# test 71
ok( $sect->next_elt_matches( 'elt[@id="elt_3"]'), "next_elt_matches (sect => elt_3)");# test 72
ok( $sect->prev_elt_matches( '#PCDATA[text()="elt 2"]'), "prev_elt_matches (sect => elt_2)");# test 73
is( $sect->next_elt_text( 'elt[@id="elt_5"]'), 'elt 5 ', "next_elt_text");# test 74
is( $sect->next_elt_trimmed_text( 'elt[@id="elt_5"]'), 'elt 5', "next_elt_trimmed_text");# test 75
nok( $sect->next_elt( $sect, 'elt[@id="elt_5"]'), "next_elt (outside the subtree)");# test 76
nok( $sect->next_elt_text( $sect, 'elt[@id="elt_5"]'), "next_elt_text (outside the subtree)");# test 77
is( $sect->first_child_trimmed_text, "elt 3", "first_child_trimmed_text");# test 78
is( $sect->first_child_trimmed_text( 'goofy'), "", "first_child_trimmed_text (no child)");# test 79
# test comparisons $elt1 < $sect < $elt3
my $elt3= $t->elt_id( 'elt_3');
ok( $elt1->le( $sect), "\$elt1 le \$sect");# test 80
ok( $elt1->lt( $sect), "\$elt1 lt \$sect");# test 81
nok( $elt1->ge( $sect), "\$elt1 ge \$sect");# test 82
nok( $elt1->gt( $sect), "\$elt1 gt \$sect");# test 83
nok( $elt3->le( $sect), "\$elt3 le \$sect");# test 84
nok( $elt3->lt( $sect), "\$elt3 lt \$sect");# test 85
ok( $elt3->ge( $sect), "\$elt3 ge \$sect");# test 86
ok( $elt3->gt( $sect), "\$elt3 gt \$sect");# test 87
}
# test keep_attribute_order
{ eval { require Tie::IxHash; };
if( $@) { skip( 7, "Tie::IxHash not available"); }
else
{ import Tie::IxHash;
my $t= XML::Twig->new( keep_atts_order => 1)
->parse( '<doc att_z="foo" att_a="bar"/>');
is( $t->sprint, '<doc att_z="foo" att_a="bar"/>', "keep_atts_order");# test 88
t/test_additional.t view on Meta::CPAN
}
$t->parse( '<doc><elt id="id1"><elt2><elt id="id2"></elt></elt2><elt id="id3"></elt></elt></doc>');
is( shift @results, "handler 1: id1", "handler 1");# test 190
is( shift @results, "handler 2: id2", "handler 2");# test 191
is( shift @results, "handler 1: id3", "handler 1 again");# test 192
}
{
my $t= XML::Twig->new( pi =>'process')->parse( '<doc><?t1 data1?><elt/></doc>');
my $pi= $t->root->first_child( '#PI');
$pi->set_target( 't2');
$pi->set_data( 'data2');
is( $pi->sprint, '<?t2 data2?>', "pi");# test 193
my $elt= $pi->next_sibling;
$elt->set_extra_data( '<!-- comment -->');
is( $elt->sprint, "<!-- comment --><elt/>", "elt with comment");# test 194
}
{
my $t= XML::Twig->new->parse( "<doc><elt> elt 1 </elt>\n <elt> elt 2 </elt></doc>");
my $elt1= $t->root->first_child;
my $elt2= $t->root->last_child;
is( $elt2->prev_sibling_text, ' elt 1 ', "prev_sibling_text");# test 195
is( $elt2->prev_sibling_trimmed_text, 'elt 1', "prev_sibling_trimmed_text");# test 196
is( $elt1->next_sibling_trimmed_text, 'elt 2', "next_sibling_trimmed_text");# test 197
ok( $elt1->next_sibling_matches( 'elt'), "next_sibling_matches ok");# test 198
nok( $elt2->next_sibling_matches( 'elt'), "next_sibling_matches nok");# test 199
is( $elt2->prev_elt_text( 'elt'), " elt 1 ", "prev_elt_text");# test 200
is( $elt2->prev_elt_trimmed_text( 'elt'), "elt 1", "prev_elt_trimmed_text");# test 201
is( $elt2->parent_trimmed_text, "elt 1 elt 2", "parent_trimmed_text");# test 202
is( $elt1->sibling( 1)->trimmed_text, "elt 2", "sibling(1)");# test 203
is( $elt2->sibling( -1)->trimmed_text, "elt 1", "sibling(-1)");# test 204
is( $elt1->sibling_text( 1), " elt 2 ", "sibling(1)");# test 205
is( $elt2->sibling_text( -1), " elt 1 ", "sibling(-1)");# test 206
is( scalar $elt1->next_siblings, 1, "next_siblings");# test 207
is( scalar $elt1->next_siblings( 'elt2'), 0, "next_siblings (none)");# test 208
}
{
my $t= XML::Twig->new->parse( '<doc><elt1/><elt2/></doc>');
my $elt1= $t->first_elt( 'elt1');
my $elt2= $t->first_elt( 'elt2');
$elt2->move( before => $elt1);
is( $t->sprint, '<doc><elt2/><elt1/></doc>', "cut");# test 209
$elt2->cut;
is( $t->sprint, '<doc><elt1/></doc>', "cut");# test 210
$elt2->replace( $elt1);
is( $t->sprint, '<doc><elt2/></doc>', "replace");# test 211
$elt2->set_content( "toto");
$elt2->suffix( ":foo");
is( $elt2->xml_string, "toto:foo", "suffix");# test 212
$elt2->first_child( '#TEXT')->suffix( 'bar');
is( $elt2->xml_string, "toto:foobar", "suffix on pcdata elt");# test 213
$elt2->replace_with( $elt1);
is( $t->sprint, '<doc><elt1/></doc>', "replace_with");# test 214
$elt1->set_content( "tto");
my $o= XML::Twig::Elt->new( b => "oo");
$o->paste_within( $elt1, 1);
is( $t->sprint, '<doc><elt1>t<b>oo</b>to</elt1></doc>', "replace_with");# test 215
$o->new( t => {a => 1 }, 'ta')->paste_within( $t->first_elt( 'b')->first_child, 1);
is( $t->sprint, '<doc><elt1>t<b>o<t a="1">ta</t>o</b>to</elt1></doc>', "replace_with");# test 216
}
# test methods inherited from XML::Parser::Expat
{
my $t= XML::Twig->new( twig_handlers => { elt => \&test_inherited })
->parse( '<doc><sect><elt>toto</elt></sect></doc>');
sub test_inherited
{ my( $t, $elt)= @_;
is( $t->depth, 2, "depth");# test 217
ok( $t->in_element( 'sect'), "in_element");# test 218
nok( $t->in_element( 'elt'), "in_element (false)");# test 219
ok( $t->within_element( 'sect'), "within_element");# test 220
ok( $t->within_element( 'doc'), "within_element");# test 221
nok( $t->within_element( 'elt'), "within_element (false)");# test 222
is( join( '/', $t->context), "doc/sect", "context");# test 223
is( $t->current_line, 1, "current_line");# test 224
is( $t->current_byte, 20, "current_byte");# test 225
is( $t->original_string, "</elt>", "original_string");# test 226
is( $t->recognized_string, "</elt>", "recognized_string");# test 227
is( $t->current_element, "sect", "current_element");# test 228
if( $XML::Parser::VERSION>2.27)
{ is( $t->element_index, 3, "element_index"); }# test 229
else
{ is( $t->element_index, 2, "element_index"); } # alt test 229
$t->base( "foo");
is( $t->base, "foo", "base");# test 230
ok( $t->position_in_context( 1), "position_in_context");# test 231
my $xml= '<elt>toto</elt>';
my $expected= '<elt>toto</elt>';
my $broken= '<elt>toto</elt>';
my $xml_escape= $t->xml_escape( $xml);
if( $xml_escape eq $broken)
{ warn "your version of expat/XML::Parser has a broken xml_escape method\n";
ok( 1, "xml_escape"); # test# test 232
}
else
{ is( $xml_escape, $expected, "xml_escape"); } # alt test 232
$xml= '<elt>toto</elt>';
$expected= '<elt>toto</elt>';
$broken= '<elt>toto</elt>';
$xml_escape= $t->xml_escape( $xml, 'o');
if( $xml_escape eq $expected)
{ ok( 1, "xml_escape"); }# test 233
elsif( $xml_escape eq $broken)
{ ok( 1, "xml_escape"); } # alt test 233
else
{ is( $xml_escape, $expected, "xml_escape"); } # alt test 233
}
t/test_additional.t view on Meta::CPAN
is( $t->encoding, "ISO-8859-1", "encoding");# test 236
nok( $t->standalone, "standalone (no)");# test 237
is( $t->xmldecl, qq{<?xml version="1.0" encoding="ISO-8859-1" standalone="no"?>\n}, "xmldecl");# test 238
$t->set_xml_version( "1.1");
is( $t->xml_version, "1.1", "set_xml_version");# test 239
$t->set_encoding( "UTF-8");
is( $t->encoding, "UTF-8", "set_encoding");# test 240
$t->set_standalone( 1);
ok( $t->standalone||'', "set_standalone");# test 241
is( $t->xmldecl, qq{<?xml version="1.1" encoding="UTF-8" standalone="yes"?>\n}, "xmldecl");# test 242
is( join( ':', sort $t->entity_names), "ent1:ent2:ent3", "entity_names");# test 243
my $ent1= $t->entity( 'ent1');
is( $ent1->name, "ent1", "entity name");# test 244
is( $ent1->val, "toto", "entity val");# test 245
nok( $ent1->sysid, "entity sysid (none)");# test 246
nok( $ent1->pubid, "entity pubid (none)");# test 247
nok( $ent1->ndata, "entity ndata (none)");# test 248
my $ent3= $t->entity( 'ent3');
is( $ent3->name, "ent3", "entity name");# test 249
nok( $ent3->val, "entity val (none)");# test 250
is( $ent3->sysid, "ent3.png", "entity sysid");# test 251
nok( $ent3->pubid, "entity pubid (none)");# test 252
is( $ent3->ndata, "PNG", "entity ndata");# test 253
my $doctype= qq{<!DOCTYPE doc SYSTEM "dummy.dtd" [\n<!ENTITY ent1 "toto">\n<!ENTITY ent2 "<p>tata</p>">\n<!ENTITY ent3 SYSTEM "ent3.png" NDATA PNG>\n]>\n};
is( $t->doctype, $doctype, "doctype");# test 254
my $ent4= $t->entity_list->add_new_ent( ent4 => "ent 4")->ent( 'ent4');
is( $ent4->text, qq{<!ENTITY ent4 "ent 4">}, "add_new_ent");# test 255
my $ent5= $t->entity_list->add_new_ent( ent5 => "", "ent5.png", "", "PNG" )->ent( 'ent5');
is( $ent5->text, qq{<!ENTITY ent5 SYSTEM "ent5.png" NDATA PNG>}, "add_new_ent (ndata)");# test 256
is( join( ':', sort $t->entity_names), "ent1:ent2:ent3:ent4:ent5", "entity_names");# test 257
is( $t->doctype, $doctype, "doctype");# test 258
my $prolog=qq{<?xml version="1.1" encoding="UTF-8" standalone="yes"?>
<!DOCTYPE doc SYSTEM "dummy.dtd"[
<!ENTITY ent1 "toto">
<!ENTITY ent2 "<p>tata</p>">
<!ENTITY ent3 SYSTEM "ent3.png" NDATA PNG>
<!ENTITY ent4 "ent 4">
<!ENTITY ent5 SYSTEM "ent5.png" NDATA PNG>]>
};
is( $t->prolog( UpdateDTD => 1), $prolog, "prolog, updated DTD");# test 259
$t->entity_list->delete( 'ent3');
is( join( ':', sort $t->entity_names), "ent1:ent2:ent4:ent5", "entity_names");# test 260
$t->entity_list->delete( ($t->entity_list->list)[0]);
is( join( ':', sort $t->entity_names), "ent2:ent4:ent5", "entity_names");# test 261
}
{
my $t= XML::Twig->new( comments => 'process', pi =>'process')
->parse( '<doc><!--comment--><?target pi?>text<![CDATA[cdata]]></doc>');
is( $t->root->first_child( '#COMMENT')->get_type, "#COMMENT", "get_type #COMMENT");# test 262
is( $t->root->first_child( '#PI')->get_type, "#PI", "get_type #PI");# test 263
is( $t->root->first_child( '#CDATA')->get_type, "#CDATA", "get_type #CDATA");# test 264
is( $t->root->first_child( '#PCDATA')->get_type, "#PCDATA", "get_type #PCDATA");# test 265
is( $t->root->get_type, "#ELT", "get_type #ELT");# test 266
my $cdata= $t->root->first_child( '#CDATA');
$cdata->set_cdata( "new cdata");
is( $cdata->sprint, "<![CDATA[new cdata]]>", "set_cdata");# test 267
my $copy= $t->root->copy;
is( $copy->sprint, $t->root->sprint, 'copy of an element with extra data');# test 268
is( $t->sprint( pretty_print => 'indented'),# test 269
qq{<doc><!--comment--><?target pi?>text<![CDATA[new cdata]]></doc>\n},
'indented elt');
}
{
my $t= XML::Twig->new->parse( '<!DOCTYPE doc SYSTEM "dummy.dtd"><doc> text &ent; more</doc>');
my $ent= $t->first_elt( '#ENT');
is( $ent->get_type, "#ENT", "get_type");# test 270
is( $ent->ent, '&ent;', "ent");# test 271
is( $ent->ent_name, 'ent', "ent_name");# test 272
$ent->set_ent( '&new_ent;');
is( $ent->ent, '&new_ent;', "new_ent ent");# test 273
is( $ent->ent_name, 'new_ent', "new_ent ent_name");# test 274
}
{
my $t= XML::Twig->new->parse( '<doc>text xx more text xx end</doc>');
my $alt_root= $t->root->copy;
$t->root->mark( ' (xx) ', b => { att => "y" });
is( $t->sprint, '<doc>text<b att="y">xx</b>more text<b att="y">xx</b>end</doc>', 'mark');# test 275
$alt_root->first_child->mark( ' (xx) ', b => { att => "y" });
is( $alt_root->sprint, '<doc>text<b att="y">xx</b>more text<b att="y">xx</b>end</doc>', 'mark text');# test 276
}
{
my $t= XML::Twig->new->parse( '<doc att="foo"/>');
is( $t->sprint, '<doc att="foo"/>', "before save_global_state");# test 277
$t->save_global_state;
$t->set_quote( 'single');
is( $t->sprint, "<doc att='foo'/>", "after set_global_state");# test 278
$t->restore_global_state;
is( $t->sprint, '<doc att="foo"/>', "after restore_global_state");# test 279
}
{
my $t= XML::Twig->new->parse( '<doc><elt>text <b>bold text</b> more text and text </elt><elt> even more text</elt></doc>');
$t->subs_text( 'text', 'stuff');
is( $t->sprint, "<doc><elt>stuff <b>bold stuff</b> more stuff and stuff </elt><elt> even more stuff</elt></doc>", "subs_text");# test 280
$t->subs_text( qr{stuf+}, 'text');
is( $t->sprint, "<doc><elt>text <b>bold text</b> more text and text </elt><elt> even more text</elt></doc>", "subs_text");# test 281
my $elt= $t->root->first_child;
my $bold= $elt->first_child( 'b');
$bold->erase;
is( $t->sprint, "<doc><elt>text bold text more text and text </elt><elt> even more text</elt></doc>", "erase");# test 282
$elt->merge( $elt->next_sibling);
is( $elt->first_child_text, "text bold text more text and text even more text", "merge_text");# test 283
}
# more tests on subs_text
{
my $doc='<doc><p>link to http://www.xmltwig.org but do not link to http://bad.com, though link to toto and link to http://www.xml.com</p><p>now http://www.nolink.com and do not link to this and do not link to http://www.bad.com and do not link to htt...
my $expected='<doc><p>see <a href="http://www.xmltwig.org">www.xmltwig.org</a> but do not link to http://bad.com, though link to toto and see <a href="http://www.xml.com">www.xml.com</a></p><p>now http://www.nolink.com and do not link to this and do ...
my $t= XML::Twig->new->parse( $doc);
my $got= $t->subs_text( qr{(?<!do not )link to (http://(\S+[\w/]))}, 'see &elt( a =>{ href => $1 }, $2)');
is( $got->sprint, $expected, 'complex substitution with subs_text');# test 284
}
{
my $doc='<doc>text <p>and more text</p></doc>';
t/test_additional.t view on Meta::CPAN
is( $out, q{<doc><sect><p>p1</p><p>p2</p><flush/>}, "flush");# test 319
close $fh;
$out="";
$open->( $fh, ">", \$out);
$t= XML::Twig->new( twig_handlers => { flush => sub { $_[0]->flush_up_to( $_->prev_sibling, $fh) } } );
$t->{twig_autoflush}=0;
$t->parse( $doc);
is( $out, q{<doc><sect><p>p1</p><p>p2</p>}, "flush_up_to");# test 320
$t= XML::Twig->new( twig_handlers => { purge => sub { $_[0]->purge_up_to( $_->prev_sibling->prev_sibling, $fh) } } )
->parse( q{<doc><sect2/><sect><p>p1</p><p><sp>sp 1</sp></p><purge/></sect></doc>});
is( $t->sprint, q{<doc><sect><p><sp>sp 1</sp></p><purge/></sect></doc>}, "purge_up_to");# test 321
}
}
# test next_n_elt for a twig
{ my $t= XML::Twig->new->parse( q{<doc><e1><e2>e 2</e2><e3>e 3</e3></e1></doc>});
is_undef( $t->next_n_elt( 1), "next_n_elt(1)");# test 322
is( $t->next_n_elt( 3)->gi, "e2", "next_n_elt(3)");# test 323
is( $t->next_n_elt( 1, "e3")->gi, "e3", "next_n_elt(1, e3)");# test 324
nok( $t->next_n_elt( 2, "e3"), "next_n_elt(2, e3)");# test 325
is( join(':', map { $_->gi } $t->_children), 'doc', "\$t->_children");# test 326
}
# test dtd_print
{ if( $perl < 5.008)
{ skip( 2, "need perl 5.8 or above to perform these tests (you have $perl)"); }
else
{
{ my $out='';
$open->( my $fh, ">", \$out);
my $t= XML::Twig->new()->parse( q{<!DOCTYPE doc [<!ELEMENT doc (#PCDATA)*>]><doc>toto</doc>});
$t->dtd_print( $fh);
is( $out, "<!DOCTYPE doc [\n<!ELEMENT doc (#PCDATA)*>\n\n]>\n", "dtd_print");# test 327
close $fh;
}
{ my $out="";
$open->( my $fh, ">", \$out);
my $t= XML::Twig->new( twig_handlers => { stop => sub { print $fh "[X]"; $_->set_text( '[Y]'); $_[0]->flush( $fh); $_[0]->finish_print( $fh); } });
$t->{twig_autoflush}=0;
$t->parse( q{<doc>before<stop/>finish</doc>});
select STDOUT;
is( $out, q{[X]<doc>before<stop>[Y]</stop>finish</doc>}, "finish_print");# test 328
}
}
}
# test set_input_filter
{ my $t=XML::Twig->new( input_filter => \&rot13)
->parse( q{<doc att="foo">text</doc>});
is( $t->sprint, q{<qbp ngg="sbb">grkg</qbp>}, "input filter");# test 329
$t=XML::Twig->new;
$t->parse( q{<doc att="foo">text</doc>});
is( $t->sprint, q{<doc att="foo">text</doc>}, "input filter (none)");# test 330
$t->set_input_filter( \&rot13);
$t->parse( q{<qbp ngg="sbb">grkg</qbp>});
is( $t->sprint, q{<doc att="foo">text</doc>}, "set_input_filter");# test 331
$t->parse( '<doc><?target data?><elt/><!-- silly hey? --><elt/></doc>');
is( $t->sprint, '<qbp><?gnetrg qngn?><ryg/><!-- fvyyl url? --><ryg/></qbp>',# test 332
"set_input_filter on comments and cdata");
}
sub rot13 { $_[0]=~ tr/a-z/n-za-m/; $_[0]; }
# test global_state methods
{ my $doc= q{<doc att="foo"><p>p 1</p><p>p 2</p></doc>};
my $t=XML::Twig->new->parse( $doc);
is( $t->sprint, $doc, "initial state");# test 333
my $state= $t->global_state;
$t->set_pretty_print( 'indented');
$t->set_indent( 8);
nok( $t->sprint eq $doc, "changed state");# test 334
$t->set_global_state( $state);
is( $t->sprint, $doc, "re-set initial state");# test 335
$t->save_global_state;
$t->set_pretty_print( 'nice');
$t->set_quote( 'single');
nok( $t->sprint eq $doc, "changed state");# test 336
$t->restore_global_state( $state);
is( $t->sprint, $doc, "restored initial state");# test 337
}
# test encoding functions
{ if( $perl < 5.008)
{ skip( 21, "need perl 5.8 or above to perform these tests (you have $perl)"); }
else
{ require Encode; import Encode;
my $text= "\x{E9}t\x{E9}";
my $text_latin1 = encode( latin1 => $text);
my $text_utf8 = encode( utf8 => $text);
my $text_html="été";
my $text_safe= "été";
my $text_safe_hex= "été";
my $doc_latin1=qq{<?xml version="1.0" encoding="ISO-8859-1"?>\n<doc>$text_latin1</doc>};
my $doc_utf8=qq{<?xml version="1.0" encoding="UTF-8"?>\n<doc>$text_utf8</doc>};
my $doc_html=qq{<?xml version="1.0" encoding="UTF-8"?>\n<doc>$text_html</doc>};
my $doc_safe=qq{<?xml version="1.0" encoding="UTF-8"?>\n<doc>$text_safe</doc>};
my $doc_safe_hex=qq{<?xml version="1.0" encoding="UTF-8"?>\n<doc>$text_safe_hex</doc>};
my $doc_escaped= xml_escape( $doc_html);
my $t= XML::Twig->new( output_encoding => "ISO-8859-1")->parse( $doc_utf8);
$t->save_global_state;
is( $t->output_encoding, 'ISO-8859-1', "output_encoding (ISO-8859-1)");# test 338
is( $t->sprint, $doc_latin1, "output_encoding ISO-8859-1");# test 339
$t->set_output_encoding( "UTF-8");
is( $t->output_encoding, 'UTF-8', "output_encoding (UTF-8)");# test 340
is( $t->sprint, $doc_utf8, "output_encoding UTF-8");# test 341
$t->set_output_text_filter( 'safe');
is( $t->sprint, $doc_safe, 'safe');# test 342
$t->set_output_text_filter( 'safe_hex');
is( $t->sprint, $doc_safe_hex, 'safe_hex');# test 343
if( $perl == 5.008)
{ skip( 2 => "cannot use latin1_output_text_filter with perl $perl"); }
else
{
$t->set_output_text_filter( $t->latin1 );
$t->set_output_encoding( "ISO-8859-1");
t/test_additional.t view on Meta::CPAN
$t->set_output_encoding();
}
}
# test SAX1 export
{ eval "require XML::Handler::YAWriter";
if( $@)
{ skip(3, "require XML::Handler::YAWriter"); }
else
{ import XML::Handler::YAWriter;
my $xmldecl= qq{<?xml version="1.0" encoding="UTF-8"?>};
my $body= qq{<doc><p att="p1">text</p></doc>};
my $doc= $xmldecl.$body;
my $t= XML::Twig->new->parse( $doc);
$t->root->set_att( '#priv' => 'private');
$t->root->insert_new_elt( last_child => '#private');
my $writer = XML::Handler::YAWriter->new( AsString => 1);
is( normalize_xml( $t->toSAX1( $writer)), $doc, 'toSAX1');# test 359
$writer->start_document;
$t->root->toSAX1( $writer);
is( normalize_xml( $writer->end_document), $doc, 'root toSAX1');# test 360
my $doc_flush='<!DOCTYPE doc [<!ENTITY foo "bar">]><doc><p>p 1</p><add/><p/><p>text<flush/> more text &foo; </p></doc>';
my $doc_flushed=qq{<?xml version="1.0" encoding="UTF-8"?><doc><p>p 1</p><add/><g>a</g><p/><p>text<flush/> more text bar </p></doc>};
$writer = XML::Handler::YAWriter->new( AsString => 1, Pretty => { CatchEmptyElement => 1 });
$writer->start_document;
$SIG{__WARN__} = sub { };
$t= XML::Twig->new( twig_handlers =>
{ add => sub { $_[0]->flush_toSAX1( $writer);
$_->new( g => "a")->toSAX1( $writer);
},
flush => sub { $_[0]->flush_toSAX1( $writer); },
}
)
->parse( $doc_flush);
my $output= $t->flush_toSAX1( $writer) || '';
$SIG{__WARN__}= $old_warning_handler;
is( normalize_xml( $output), $doc_flushed, 'root toSAX1');# test 361
}
}
# test SAX2 export
{ eval "require XML::SAX::Writer;";
if( $@)
{ skip(5, "XML::SAX::Writer not available"); }
elsif( $XML::SAX::Writer::VERSION < 0.39)
{ skip( 5, "XML::SAX::Writer version 0.39 and above required to use SAX2 export"); }
else
{ eval "require XML::Filter::BufferText;";
if( $@)
{ skip(5, "XML::Filter::BufferText not available"); }
else
{ import XML::SAX::Writer;
import XML::Filter::BufferText;
my $output='';
my $writer = XML::SAX::Writer->new( Output => \$output);
my $xmldecl= qq{<?xml version="1.0" encoding="UTF-8"?>};
my $body= qq{<doc><!-- comment --><p att="p1">text</p><?target pi ?><ns xmlns:foo="uri2"><foo:e foo:att="bar">foo:e text</foo:e></ns><ns xmlns="uri2"><e att="tata">t</e></ns><p><![CDATA[ some cdata]]></p>[</doc>};
my $doc= $xmldecl.$body;
my $xfbtv= $XML::Filter::BufferText::VERSION;
if( $xfbtv < 1.01)
{ skip( 2, "XML::Filter::BufferText version $xfbtv has a bug in CDATA processing"); }
else
{
my $t= XML::Twig->new( comments =>'process', pi => 'process')->parse( $doc);
# add private data
$t->root->set_att( '#priv' => 'private');
$t->root->insert_new_elt( last_child => '#private');
$t->toSAX2( $writer);
is( normalize_xml( $output), $doc, 'toSAX2');# test 362
$output='';
$t->root->toSAX2( $writer);
is( normalize_xml( $output), $body, 'flush_toSAX2');# test 363
}
my $doc_flush="<doc><p>p 1</p><add/><p/><p>text<flush/> more text</p></doc>";
my $doc_flushed=qq{<doc><p>p 1</p><add/><g>a</g><p/><p>text<flush/> more text</p></doc>};
$output='';
my $t= XML::Twig->new( twig_handlers =>
{ add => sub { $_[0]->flush_toSAX2( $writer);
$_->new( g => "a")->toSAX2( $writer);
},
flush => sub { $_[0]->flush_toSAX2( $writer); },
}
)
->parse( $doc_flush);
$t->flush_toSAX2( $writer);
is( normalize_xml( $output), $doc_flushed, 'flush_toSAX2');# test 364
$doc= qq{<!DOCTYPE doc [ <!ENTITY toto "foo">]><doc>toto = &toto;</doc>};
$t= XML::Twig->new()->parse( $doc);
$output='';
$writer = XML::SAX::Writer->new( Output => \$output);
$t->toSAX2( $writer);
$output=~ s{<!DOCTYPE.*?>}{}s; # shows that in fact we have a problem with outputing the DTD
is( normalize_xml( $output), '<doc>toto = foo</doc>', 'toSAX2 with an entity');# test 365
$doc= qq{<!DOCTYPE doc SYSTEM "not_there" ><doc>toto = &toto;</doc>};
$t= XML::Twig->new()->parse( $doc);
$output='';
$writer = XML::SAX::Writer->new( Output => \$output);
$t->toSAX2( $writer);
is( normalize_xml( $output), normalize_xml( $doc), 'toSAX2 with a non expanded entity');# test 366
}
}
}
# test flushed an twig_current status (not a very good test, but the methods are not used in practice)
{ my $t= XML::Twig->new->parse( '<doc />');
nok( $t->root->_flushed, "root is not flushed");# test 367
$t->root->_set_flushed;
ok( $t->root->_flushed, "root is flushed");# test 368
$t->root->_del_flushed;
nok( $t->root->_flushed, "root is not flushed");# test 369
nok( $t->root->{twig_current}, "root is not twig current");# test 370
t/test_additional.t view on Meta::CPAN
my $doc= q{<doc><elt>1</elt><elt>2</elt><elt>3</elt>
<change/>
<elt>1</elt><elt>1</elt><elt>3</elt>
<change2/>
<elt>1</elt><elt>2</elt><elt>1</elt>
</doc>
};
my %handlers= map { build_regexp_handler( 'O', $_) } (1..3);
my $t= XML::Twig->new( twig_handlers => { %handlers,
change => sub { foreach( 1..3)
{ $_[0]->setTwigHandler( build_regexp_handler( 'N', $_)) }
},
change2 => sub { $_[0]->setTwigHandler( 'elt[string()=~ /1/]', undef);
$_[0]->setTwigHandler( build_regexp_handler( 'D', 2));
}
},
)
->parse( $doc);
is( $res, 'O1O2O3N1N1N3D2', "changing handlers on elt[string()]");# test 518
sub build_regexp_handler
{ my( $prefix, $nb)= @_;
return( qq{elt[string()=~ /$nb/]} => sub { $res.= $prefix . $nb });
}
}
# test PI and comment drops
{ my $doc= q{<?xml version="1.0"?><!-- comment 1 --><?pi data?><doc><?pi2 data2?>text<?pi3 data3?><!--comment--> more text</doc>};
(my $doc_without_pi = $doc)=~ s{<\?pi.*?\?>}{}g;
(my $doc_without_comment = $doc)=~ s{<!--.*?-->}{}g;
(my $doc_without_all = $doc)=~ s{<(\?pi|!--).*?(\?|--)>}{}g;
my $t= XML::Twig->new( pi => 'drop', comments => 'process')->parse( $doc);
is( normalize_xml( $t->sprint), $doc_without_pi, 'drop pis');# test 519
$t= XML::Twig->new( pi => 'process', comments => 'drop')->parse( $doc);
is( normalize_xml( $t->sprint), $doc_without_comment, 'drop comments');# test 520
$t= XML::Twig->new( pi => 'drop' , comments => 'drop')->parse( $doc);
is( normalize_xml( $t->sprint), $doc_without_all, 'drop comments and pis');# test 521
my $doc6=q{<doc><elt/><?pi2 data2?>text more text</doc>};
$t= XML::Twig->new( pi => 'keep')->parse( $doc6);
is( _hash( normalize_xml( $t->sprint)), _hash( $doc6), 'keep pi');# test 522
my $doc5=q{<doc><elt/><?pi2 data2?>text more text</doc>};
$t= XML::Twig->new( pi => 'process')->parse( $doc5);
is( normalize_xml( $t->sprint), $doc5, 'process pi');# test 523
my $doc4=q{<?xml version="1.0"?><!-- comment 1 --><?pi data?><doc><elt/><?pi2 data2?>text more text</doc>};
$t= XML::Twig->new->parse( $doc4);
is( _hash( normalize_xml( $t->sprint)), _hash( $doc4), 'comment before PI (2 PIs, no comments)');# test 524
my $doc3=q{<?xml version="1.0"?><!-- comment 1 --><?pi data?><doc><?pi2 data2?>text more text</doc>};
$t= XML::Twig->new->parse( $doc3);
is( _hash( normalize_xml( $t->sprint)), _hash( $doc3), 'comment before PI (2 PIs, no comments)');# test 525
my $doc1=q{<?xml version="1.0"?><!-- comment 1 --><?pi data?><doc>t<?pi2 data2?>text<!--comment--> more text</doc>};
$t= XML::Twig->new->parse( $doc1);
is( _hash( normalize_xml( $t->sprint)), _hash( $doc1), 'comment before PI (2 PIs, pcdata before pi)');# test 526
my $doc2=q{<?xml version="1.0"?><!-- comment 1 --><?pi data?><doc> <?pi2 data2?>text<!--comment--> more text</doc>};
$t= XML::Twig->new->parse( $doc2);
is( _hash( normalize_xml( $t->sprint)), _hash( $doc2), 'comment before PI (2 PIs)');# test 527
$t= XML::Twig->new->parse( $doc);
is( _hash( normalize_xml( $t->sprint)), _hash( $doc), 'comment before PI (3 PIs)');# test 528
}
# returns a string that has all the chars in the input, ordered, to allow
# comparison of texts without taking the order into consideration
sub _hash
{ return sort split //, $_[0]; }
{ my $doc=q{<doc><elt1/><elt2 att="a"/><elt7 att="b"/><elt3><elt4/></elt3><elt5 att="c"/><elt6 att="d"/><root/></doc>};
my $res='';
my $t= XML::Twig->new( twig_roots => { root => 1 },
start_tag_handlers =>
{ 'elt1' => sub { $res.= 'E1'; },
'elt2[@att="a"]' => sub { $res .= 'E2'; },
'elt7[@att=~/b/]' => sub { $res .= 'E3'; },
'/doc/elt3' => sub { $res .= 'E4'; },
'elt3/elt4' => sub { $res .= 'E5'; },
'*[@att="c"]' => sub { $res .= 'E6'; },
'*[@att=~/d/]' => sub { $res .= 'E7'; },
_default_ => sub { $res .= 'E0'; }
},
)->parse( $doc);
is( $res => 'E0E1E2E3E4E5E6E7E0', 'all types of handlers on start_tags');# test 529
}
{ my $doc= q{<doc> <![CDATA[cdata]]></doc>};
my $t= XML::Twig->new( keep_spaces => 1)->parse( $doc);
is( $t->sprint, $doc, 'spaces before cdata');# test 530
}
{ my $doc= q{<doc> <![CDATA[cdata]]> <elt/> <![CDATA[more cdata]]></doc>};
my $t= XML::Twig->new( keep_spaces => 1)->parse( $doc);
is( $t->sprint, $doc, '2 cdata sections');# test 531
}
{ my $doc= q{<doc> <![CDATA[cdata]]> <elt/> <!-- comment --> <![CDATA[more cdata]]></doc>};
my $t= XML::Twig->new( keep_spaces => 1, comments => 'process')->parse( $doc);
is( $t->sprint, $doc, 'spaces and extra data before cdata');# test 532
}
{ # fun with suffix and asis
my $t=XML::Twig->new->parse( '<doc>to</doc>');
$t->root->suffix( 'to');
is( $t->sprint, '<doc>toto</doc>', 'regular suffix');# test 533
$t=XML::Twig->new->parse( '<doc><b>to</b></doc>');
$t->root->suffix( 'to');
is( $t->sprint, '<doc><b>to</b>to</doc>', 'regular suffix needs new elt');# test 534
$t=XML::Twig->new->parse( '<doc><b>to</b></doc>');
$t->root->suffix( '<to/>', 'asis');
is( $t->sprint, '<doc><b>to</b><to/></doc>', 'asis suffix needs new elt');# test 535
$t=XML::Twig->new->parse( '<doc>to</doc>');
$t->root->suffix( '<to/>', 'asis');
is( $t->sprint, '<doc>to<to/></doc>', 'asis suffix');# test 536
$t=XML::Twig->new->parse( '<doc><to/></doc>');
$t->root->set_asis( 1);
$t->root->suffix( '<to/>', 'asis');
is( $t->sprint, '<doc><to/><to/></doc>', 'asis suffix (on asis elt)');# test 537
$t=XML::Twig->new->parse( '<doc><to/></doc>');
$t->root->set_asis( 1);
$t->root->suffix( '<to/>');
is( $t->sprint, '<doc><to/><to/></doc>', 'regular suffix (on asis elt)');# test 538
}
{ # fun with prefix and asis
my $t=XML::Twig->new->parse( '<doc>to</doc>');
$t->root->prefix( 'to');
is( $t->sprint, '<doc>toto</doc>', 'regular prefix');# test 539
$t=XML::Twig->new->parse( '<doc><b>to</b></doc>');
$t->root->prefix( '<to/>', 'asis');
is( $t->sprint, '<doc><to/><b>to</b></doc>', 'regular prefix needs new elt');# test 540
$t=XML::Twig->new->parse( '<doc><b>to</b></doc>');
$t->root->prefix( 'to');
is( $t->sprint, '<doc>to<b>to</b></doc>', 'asis prefix needs new elt');# test 541
$t=XML::Twig->new->parse( '<doc>to</doc>');
$t->root->prefix( '<to/>', 'asis');
is( $t->sprint, '<doc><to/>to</doc>', 'asis prefix');# test 542
$t=XML::Twig->new->parse( '<doc><to/></doc>');
$t->root->set_asis( 1);
$t->root->prefix( '<to/>', 'asis');
is( $t->sprint, '<doc><to/><to/></doc>', 'asis prefix (on asis elt)');# test 543
$t=XML::Twig->new->parse( '<doc><to/></doc>');
$t->root->set_asis( 1);
$t->root->prefix( '<to/>');
is( $t->sprint, '<doc><to/><to/></doc>', 'regular suffix (on asis elt)');# test 544
}
{ # wrap_in on the current
my $t= XML::Twig->new( twig_handlers => { wrapped => sub { $_->wrap_in( wrapper => { foo => 'bar'} )} })
->parse( '<doc>toto<wrapped>tata</wrapped><elt/></doc>');
is( $t->sprint, '<doc>toto<wrapper foo="bar"><wrapped>tata</wrapped></wrapper><elt/></doc>', 'wrap_in');# test 545
}
{ my $t= XML::Twig->new->parse( q{<doc><elt1/><elt2 att1="a1"/><elt3 att1="a2" att2="a3"/></doc>});
ok ( $t->first_elt( 'elt1')->has_no_atts, 'has_no_atts true');# test 546
nok( $t->first_elt( 'elt2')->has_no_atts, 'has_no_atts false');# test 547
nok( $t->first_elt( 'elt3')->has_no_atts, 'has_no_atts false');# test 548
nok ( $t->first_elt( 'elt1')->has_atts, 'has_atts false');# test 549
ok( $t->first_elt( 'elt2')->has_atts, 'has_atts true');# test 550
ok( $t->first_elt( 'elt3')->has_atts, 'has_atts true');# test 551
is( $t->first_elt( 'elt1')->att_nb, 0, 'att_nb, 0');# test 552
is( $t->first_elt( 'elt2')->att_nb, 1, 'att_nb, 1');# test 553
is( $t->first_elt( 'elt3')->att_nb, 2, 'att_nb, 2');# test 554
}
{ my $t= XML::Twig->new->parse( '<doc><p>titi</p></doc>');
$t->root->split( qr/(i)/);
is( $t->sprint, '<doc><p>t<p>i</p>t<p>i</p></p></doc>', "split with no tag");# test 555
}
{ my $t= XML::Twig->new->parse( '<doc><p>titi toto</p></doc>');
$t->root->split( 'b');
is( $t->sprint, '<doc><p>titi toto</p></doc>', "split with no regexp");# test 556
}
{ my $t= XML::Twig->new->parse( '<doc><p>titi toto</p></doc>');
$t->root->split( qr/foo/, 'ta');
is( $t->sprint, '<doc><p>titi toto</p></doc>', 'split, no match');# test 557
}
{ my $doc= '<?xml version="a.0"?><!DOCTYPE doc SYSTEM "no_dtd" []> <doc att="val"><p att="val">toto &ent; <![CDATA[ toto]]></p></doc>';
my $t= XML::Twig->new->parse( $doc);
my $alt_root= $t->root->copy;
is( $alt_root->sprint, $t->root->sprint, 'copy with entity');# test 558
}
{ my $doc= '<doc>toto</doc>';
my $t= XML::Twig->new->parse( $doc);
my $pcdata= $t->first_elt( '#TEXT');
my $start_tag= $pcdata->start_tag;
nok( $start_tag, 'start_tag for a text element');# test 559
$t->root->set_att( '#priv_att' => 1);
is( $t->sprint, $doc, 'private attributes');# test 560
my $priv_elt= $t->root->insert( '#priv_elt');
is( $t->sprint, $doc, 'private element');# test 561
$priv_elt->set_gi( 'foo');
is( $t->sprint, '<doc><foo>toto</foo></doc>', 'private element');# test 562
$priv_elt->set_gi( '#priv');
is( $t->sprint, $doc, 'private element');# test 563
$priv_elt->set_att( att => "val");
is( $t->sprint, $doc, 'private element');# test 564
$priv_elt->set_gi( 'foo');
is( $t->sprint, '<doc><foo att="val">toto</foo></doc>', 'private element');# test 565
}
{ my $doc= qq{<doc><record><!-- field 1 --><f1>val1</f1><f2>val2</f2></record></doc>};
my $out= qq{\n<doc>\n <record>\n <!-- field 1 -->\n <f1>val1</f1>\n <f2>val2</f2>\n </record>\n</doc>\n};
my $t=XML::Twig->new( pretty_print => 'record')->parse( $doc);
is( $t->sprint, $out, 'record with empty record');# test 566
$t->set_pretty_print( 'none');
}
{ my $e= XML::Twig::Elt->new( 'toto');
nok( scalar $e->_is_private, 'private elt (not)');# test 567
$e->set_tag( '#toto');
ok( scalar $e->_is_private, 'private elt (yes)');# test 568
ok( scalar XML::Twig::Elt::_is_private_name( '#toto'), '_is_private_name (yes)');# test 569
nok( scalar XML::Twig::Elt::_is_private_name( 'toto'), '_is_private_name (no)');# test 570
}
{ my $t= XML::Twig->new->parse( '<doc><![CDATA[toto]]></doc>');
my $text_elt= $t->first_elt( '#TEXT');
is( $text_elt->xml_string, '<![CDATA[toto]]>', 'xml_string for cdata');# test 571
$text_elt->set_text( '<>');
is( normalize_xml( $t->sprint), '<doc><![CDATA[<>]]></doc>', 'set_text on CDATA');# test 572
$text_elt->set_text( '<>', force_pcdata => 1);
is( normalize_xml( $t->sprint), '<doc><></doc>', 'set_text on CDATA (with force_pcdata)');# test 573
$t->root->set_content( { att => "val" }, 'toto ', 'tata');
is( $t->root->sprint, '<doc att="val">toto tata</doc>', 'set_content with attributes');# test 574
$text_elt= $t->first_elt( '#TEXT');
$text_elt->set_content( 'titi');
is( $t->root->sprint, '<doc att="val">titi</doc>', 'set_content on text elt');# test 575
}
{ my $t=XML::Twig->new->parse( '<doc><elt>text 1</elt><elt>text 2</elt><elt>text 3</elt></doc>');
my $elt1= $t->root->first_child( 'elt[1]');
my $elt2= $t->root->first_child( 'elt[2]');
my $elt3= $t->root->first_child( 'elt[3]');
my $new1= XML::Twig::Elt->new( new => "new 1");
my $new2= XML::Twig::Elt->new( new => "new 2");
my $new3= XML::Twig::Elt->new( new => "new 3");
$new1->replace( $elt1);
$new2->replace( $elt2);
$new3->replace( $elt3);
is( $t->sprint, '<doc><new>new 1</new><new>new 2</new><new>new 3</new></doc>', 'replace');# test 576
$new1->replace_with( $elt2, $elt1, $elt3);
is( $t->sprint, '<doc><elt>text 2</elt><elt>text 1</elt><elt>text 3</elt><new>new 2</new><new>new 3</new></doc>', 'replace');# test 577
}
{
if( $perl < 5.008)
{ skip( 1, "need perl 5.8 or above to perform these tests (you have $perl)"); }
else
{ my $doc= '<doc><![CDATA[toto]]>tata<!-- comment -->t<?pi data?> more</doc>';
my $out=''; $open->( my $fh, ">", \$out);
my $t= XML::Twig->new( comments => 'process', pi => 'process')->parse( $doc);
$t->flush( $fh);
is( $out, $doc, 'flush with cdata');# test 578
}
}
{ my $doc=<<END;
<doc>
<elt>text</elt><indent>this</indent>
<pre>text to
keep spaces
in like
this
</pre>
</doc>
END
my $t= XML::Twig->new( pretty_print => 'indented', keep_spaces_in => [ qw(pre) ])->parse( $doc);
(my $indented= $doc)=~ s{<indent>}{\n <indent>};
is( $t->sprint, $indented, 'indented with keep_spaces_in');# test 579
$t->set_pretty_print( 'indented');
}
{ my $doc='<doc><elt att="1">text</elt></doc>';
my $nsgmls= qq{<doc\n><elt\natt="1"\n>text</elt></doc>\n};
my $t= XML::Twig->new( pretty_print => 'nsgmls')->parse( $doc);
is( $t->sprint, $nsgmls, 'nsgmls style');# test 580
$t->set_pretty_print( 'indented');
}
{ my $t= XML::Twig->new->parse( '<doc><new_root>text</new_root></doc>');
$t->root->erase;
is( $t->root->sprint, "<new_root>text</new_root>\n", 'erase root');# test 581
}
{ my $t= XML::Twig->new->parse( '<doc><elt1 att="val"/><elt2/><elt3/></doc>');
my $elt2= $t->first_elt( 'elt2');
ok( $elt2->sibling( 0, 'elt2'), 'sibling 0 (ok)');# test 582
nok( $elt2->sibling( 0, 'elt1'), 'sibling 0 (nok)');# test 583
nok( $elt2->sibling( 1, 'elt1'), 'sibling 1 (nok)');# test 584
nok( $elt2->sibling( -1, 'elt3'), 'sibling -1 (nok)');# test 585
ok( $elt2->in( 'doc'), 'in with condition');# test 586
ok( $elt2->in( $t->root), 'in with elt');# test 587
nok( $elt2->in( 'elt1'), 'in with condition (false)');# test 588
nok( $elt2->in( $t->root->last_child), 'in with elt (false)');# test 589
is( $elt2->prev_sibling( 'elt1[@att="val"]')->gi, 'elt1', '@att="val" condition');# test 590
nok( $elt2->prev_sibling( 'elt1[@att="val2"]'), '@att="val" condition (not found)');# test 591
is( $elt2->prev_sibling( 'elt1[@att=~ /val/]')->gi, 'elt1', '@att=~ /val/ condition');# test 592
nok( $elt2->prev_sibling( 'elt1[@att=~/val2/]'), '@att=~/val2/ condition (not found)');# test 593
}
{
if( $perl < 5.008)
{ skip( 2, "need perl 5.8 or above to perform these tests (you have $perl)"); }
else
{ my $out='';
$open->( my $fh, ">", \$out);
my $doc='<doc><elt>text</elt><elt1/><elt2/><elt3>text</elt3></doc>';
$t= XML::Twig->new( twig_roots=> { elt2 => 1 },
start_tag_handlers => { elt => sub { print $fh '<e1/>'; } },
end_tag_handlers => { elt3 => sub { print $fh '<e2/>'; } },
twig_print_outside_roots => $fh,
keep_encoding => 1
t/test_additional.t view on Meta::CPAN
<elt>text</elt>
</doc>
DTD
my $t= XML::Twig->new( ErrorContext => 1)->parse( $doc);
is( $t->sprint, $doc, 'complex DTD');# test 609
is( join( ':', $t->model), 'doc:elt:elt2', 'model with no elt (all element in the dtd)');# test 610
}
# testing do_not_output_DTD option
{ my $t= XML::Twig->new( no_prolog => 1)
->parse( '<?xml version="1.0"?><!DOCTYPE doc [ <!ELEMENT doc (#PCDATA)>]><doc/>');
is( $t->sprint, '<doc/>', 'no_prolog');# test 611
}
# testing do_not_output_DTD option
{ my $t= XML::Twig->new( do_not_output_DTD => 1)
->parse( '<!DOCTYPE doc [ <!ELEMENT doc (#PCDATA)>]><doc/>');
is( $t->sprint, '<doc/>', 'do_not_output_DTD option');# test 612
$t->purge;
}
# handlers on PIs
{ my $t= XML::Twig->new( pretty_print => 'none', twig_handlers => { '?t1' => sub { return "<?t2 $_[2]?>"; } })
->parse( '<doc><!--comment--><?t1 data ?><elt>toto</elt></doc>');
is( $t->sprint, '<doc><!--comment--><?t2 data ?><elt>toto</elt></doc>', 'handler on pi t1, with comment');# test 613
}
# handlers on PIs
{ my $t= XML::Twig->new( pretty_print => 'none', twig_handlers => { '?' => sub { return "<?t2 $_[2]?>"; } })
->parse( '<doc><!--comment--><?t1 data ?><elt>toto</elt></doc>');
is( $t->sprint, '<doc><!--comment--><?t2 data ?><elt>toto</elt></doc>', 'handler on all pi, with comment');# test 614
}
# creating an output encoding
{
if( $perl < 5.008)
{ skip( 1, "need perl 5.8 or above to perform these tests (you have $perl)"); }
else
{ my $t= XML::Twig->new->parse( '<doc/>');
$t->set_output_encoding( 'ISO-8859-1');
is( $t->sprint, qq{<?xml version="1.0" encoding="ISO-8859-1"?><doc/>}, 'creating an output encoding');# test 615
}
}
# some calls that return false
{ my $root= XML::Twig->new->parse( '<doc/>')->root;
nok( $root->last_child_matches( 'toto'), 'last_child_matches (not)');# test 616
nok( $root->first_child_matches( 'toto'), 'first_child_matches(not)');# test 617
nok( $root->child_text( 1, 'toto'), 'child_text(not)');# test 618
nok( $root->child_trimmed_text( 1, 'toto'), 'child_trimmed_text(not)');# test 619
nok( $root->child_matches( 1, 'toto'), 'child_matches(not)');# test 620
nok( $root->prev_sibling_matches( 'toto'), 'prev_sibling_matches(not)');# test 621
nok( $root->prev_elt_text( 'toto'), 'prev_elt_text(not)');# test 622
nok( $root->sibling_text( 1, 'toto'), 'prev_elt_text(not)');# test 623
nok( $root->prev_elt_trimmed_text( 'toto'), 'prev_elt_trimmed_text(not)');# test 624
nok( $root->prev_elt_matches( 'toto'), 'prev_elt_matches(not)');# test 625
nok( $root->next_elt_trimmed_text( 'toto'), 'next_elt_trimmed_text(not)');# test 626
nok( $root->next_elt_matches( 'toto'), 'next_elt_matches(not)');# test 627
nok( $root->parent_text( 'toto'), 'parent_text(not)');# test 628
nok( $root->parent_trimmed_text( 'toto'), 'parent_trimmed_text(not)');# test 629
nok( $root->pcdata_xml_string, 'pcdata_xml_string of a non pcdata elt');# test 630
nok( $root->att_xml_string( 'foo'), 'att_xml_string of a non existing att');# test 631
}
{ my $doc=<<END;
<doc>
<elt xml:space="preserve">
<sub id="s1">
<sub>text 1</sub>
<sub>text 2</sub>
</sub>
</elt>
<elt>
<sub id="s2">
<sub>text 1</sub>
<sub>text 2</sub>
</sub>
</elt>
</doc>
END
my $expected_doc=q{<doc><elt xml:space="preserve">
<sub id="s1">
<sub>text 1</sub>
<sub>text 2</sub>
</sub>
</elt><elt><sub id="s2"><sub>text 1</sub><sub>text 2</sub></sub></elt></doc>};
my $expected_s1= q{<sub id="s1">
<sub>text 1</sub>
<sub>text 2</sub>
</sub>};
my $expected_s2= q{<sub id="s2"><sub>text 1</sub><sub>text 2</sub></sub>};
my $t=XML::Twig->new(pretty_print => 'none')->parse( $doc);
is( $t->sprint, $expected_doc, 'doc with xml:space="preserve"');# test 632
is( $t->get_xpath( '//*[@id="s1"]', 0)->sprint, $expected_s1, 'sub element of an xml:space="preserve" element');# test 633
is( $t->get_xpath( '//*[@id="s2"]', 0)->sprint, $expected_s2, 'regular sub element');# test 634
}
{ my $e= XML::Twig::Elt->parse( '<elt/>');
is( $e->xml_text, '', 'xml_text of an empty elt');# test 635
$e= XML::Twig::Elt->parse( '<elt>toto</elt>')->first_child;
is( $e->xml_text, 'toto', 'xml_text of a pcdata');# test 636
$e->set_content();
is( $e->xml_text, 'toto', 'empty set_content');# test 637
$e= XML::Twig::Elt->parse( '<elt><![CDATA[toto]]></elt>')->first_child;
is( $e->xml_text, '<![CDATA[toto]]>', 'xml_text of a cdata');# test 638
}
{ my $doc= q{<doc xmlns:ns1="uri1" xmlns:ns2="uri2"><ns1:elt>toto</ns1:elt>}
. q{<ns2:elt>tata</ns2:elt></doc>};
my $expected_keep= $doc;
$expected_keep=~ s{toto}{foo};
$expected_keep=~ s{tata}{bar};
my $t= XML::Twig->new( map_xmlns => { uri1 => "ns_1", uri2 => "ns_2" },
keep_original_prefix => 1,
twig_handlers => { 'ns_1:elt' => sub { $_->set_text( 'foo'); },
'ns_2:elt' => sub { $_->set_text( 'bar'); },
}
)
->parse( $doc);
is( $t->sprint, $expected_keep, "map_xmlns and keep_original_prefix");# test 639
$t= XML::Twig->new( map_xmlns => { uri1 => "ns_1", uri2 => "ns_2" },
twig_handlers => { 'ns_1:elt' => sub { $_->set_text( 'foo'); },
'ns_2:elt' => sub { $_->set_text( 'bar'); },
}
)
->parse( $doc);
(my $expected_remap= $expected_keep)=~ s{ns(?=\d)}{ns_}g;
is( $t->sprint, $expected_remap, "map_xmlns");# test 640
}
{ my $doc= q{<doc xmlns:ns1="uri1" xmlns:ns2="uri2"><ns1:elt ns2:att="titi">toto</ns1:elt>}
. q{<ns2:elt>tata</ns2:elt></doc>};
my $expected_keep= $doc;
$expected_keep=~ s{toto}{foo};
$expected_keep=~ s{tata}{bar};
my $t= XML::Twig->new( map_xmlns => { uri1 => "ns_1", uri2 => "ns_2" },
keep_original_prefix => 1,
twig_handlers => { 'ns_1:elt' => sub { $_->set_text( 'foo'); },
'ns_2:elt' => sub { $_->set_text( 'bar'); },
}
)
->parse( $doc);
is( $t->sprint, $expected_keep, "map_xmlns and keep_original_prefix");# test 641
$t= XML::Twig->new( map_xmlns => { uri1 => "ns_1", uri2 => "ns_2" },
twig_handlers => { 'ns_1:elt' => sub { $_->set_text( 'foo'); },
'ns_2:elt' => sub { $_->set_text( 'bar'); },
}
)
->parse( $doc);
(my $expected_remap= $expected_keep)=~ s{ns(?=\d)}{ns_}g;
is( $t->sprint, $expected_remap, "map_xmlns");# test 642
}
{ my $doc= q{<doc xmlns="uri1" xmlns:ns2="uri2"><elt att="tutu" ns2:att="titi">toto</elt>}
. q{<ns2:elt>tata</ns2:elt></doc>};
my $expected_keep= $doc;
$expected_keep=~ s{toto}{foo};
$expected_keep=~ s{tata}{bar};
my $t= XML::Twig->new( map_xmlns => { uri1 => "ns_1", uri2 => "ns_2" },
keep_original_prefix => 1,
twig_handlers => { 'ns_1:elt' => sub { $_->set_text( 'foo'); },
'ns_2:elt' => sub { $_->set_text( 'bar'); },
}
)
->parse( $doc);
( run in 1.333 second using v1.01-cache-2.11-cpan-39bf76dae61 )