', "split");# test 188
$new_p->split( qr/(i)/, b => { foo => "bar" } );
is( $new_p->sprint, '
fini
', "split (with att)");# test 189
}
# test start_tag_handlers
{
my @results;
my $handler;
my $t=XML::Twig->new( start_tag_handlers =>{ elt => \&sth1});
sub sth1
{ my( $t, $elt)= @_;
push @results, "handler 1: ". $elt->id;
$handler= $t->setStartTagHandler( elt => \&sth2);
}
sub sth2
{ my( $t, $elt)= @_;
push @results, "handler 2: ". $elt->id;
$t->setStartTagHandler( elt => $handler);
}
$t->parse( '');
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( '');
my $pi= $t->root->first_child( '#PI');
$pi->set_target( 't2');
$pi->set_data( 'data2');
is( $pi->sprint, '', "pi");# test 193
my $elt= $pi->next_sibling;
$elt->set_extra_data( '');
is( $elt->sprint, "", "elt with comment");# test 194
}
{
my $t= XML::Twig->new->parse( " elt 1 \n elt 2 ");
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( '');
my $elt1= $t->first_elt( 'elt1');
my $elt2= $t->first_elt( 'elt2');
$elt2->move( before => $elt1);
is( $t->sprint, '', "cut");# test 209
$elt2->cut;
is( $t->sprint, '', "cut");# test 210
$elt2->replace( $elt1);
is( $t->sprint, '', "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, '', "replace_with");# test 214
$elt1->set_content( "tto");
my $o= XML::Twig::Elt->new( b => "oo");
$o->paste_within( $elt1, 1);
is( $t->sprint, 'tooto', "replace_with");# test 215
$o->new( t => {a => 1 }, 'ta')->paste_within( $t->first_elt( 'b')->first_child, 1);
is( $t->sprint, 'totaoto', "replace_with");# test 216
}
# test methods inherited from XML::Parser::Expat
{
my $t= XML::Twig->new( twig_handlers => { elt => \&test_inherited })
->parse( 'toto');
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, "", "original_string");# test 226
is( $t->recognized_string, "", "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= 'toto';
my $expected= '<elt>toto</elt>';
my $broken= '<elt>toto';
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= 'toto';
$expected= '<elt>toto</elt>';
$broken= '<elt>toto';
$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
}
}
{
my $t= XML::Twig->new( start_tag_handlers => { i => sub { $_[0]->ignore }, },
twig_handlers => { s => sub { $_[0]->finish }, } )
->parse( 'foototototobar');
is( $t->sprint, "foototo", "ignore + finish");# test 234
}
# test xml declaration and entity related methods
{
my $t= XML::Twig->new->parse( '
tata
">
]>
&ent1;&ent2;');
is( $t->xml_version, "1.0", "xml_version");# test 235
is( $t->encoding, "ISO-8859-1", "encoding");# test 236
nok( $t->standalone, "standalone (no)");# test 237
is( $t->xmldecl, qq{\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{\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{\ntata">\n\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{}, "add_new_ent");# test 255
my $ent5= $t->entity_list->add_new_ent( ent5 => "", "ent5.png", "", "PNG" )->ent( 'ent5');
is( $ent5->text, qq{}, "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{
tata">
]>
};
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( 'text');
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, "", "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{text\n},
'indented elt');
}
{
my $t= XML::Twig->new->parse( ' text &ent; more');
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( 'text xx more text xx end');
my $alt_root= $t->root->copy;
$t->root->mark( ' (xx) ', b => { att => "y" });
is( $t->sprint, 'textxxmore textxxend', 'mark');# test 275
$alt_root->first_child->mark( ' (xx) ', b => { att => "y" });
is( $alt_root->sprint, 'textxxmore textxxend', 'mark text');# test 276
}
{
my $t= XML::Twig->new->parse( '');
is( $t->sprint, '', "before save_global_state");# test 277
$t->save_global_state;
$t->set_quote( 'single');
is( $t->sprint, "", "after set_global_state");# test 278
$t->restore_global_state;
is( $t->sprint, '', "after restore_global_state");# test 279
}
{
my $t= XML::Twig->new->parse( 'text bold text more text and text even more text');
$t->subs_text( 'text', 'stuff');
is( $t->sprint, "stuff bold stuff more stuff and stuff even more stuff", "subs_text");# test 280
$t->subs_text( qr{stuf+}, 'text');
is( $t->sprint, "text bold text more text and text even more text", "subs_text");# test 281
my $elt= $t->root->first_child;
my $bold= $elt->first_child( 'b');
$bold->erase;
is( $t->sprint, "text bold text more text and text even more text", "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='
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
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 http://www.bad2.com and link to http://link.com also
}, "purge_up_to");# test 321
}
}
# test next_n_elt for a twig
{ my $t= XML::Twig->new->parse( q{e 2e 3});
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{]>toto});
$t->dtd_print( $fh);
is( $out, "\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{beforefinish});
select STDOUT;
is( $out, q{[X]before[Y]finish}, "finish_print");# test 328
}
}
}
# test set_input_filter
{ my $t=XML::Twig->new( input_filter => \&rot13)
->parse( q{text});
is( $t->sprint, q{grkg}, "input filter");# test 329
$t=XML::Twig->new;
$t->parse( q{text});
is( $t->sprint, q{text}, "input filter (none)");# test 330
$t->set_input_filter( \&rot13);
$t->parse( q{grkg});
is( $t->sprint, q{text}, "set_input_filter");# test 331
$t->parse( '');
is( $t->sprint, '',# 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{
p 1
p 2
};
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{\n$text_latin1};
my $doc_utf8=qq{\n$text_utf8};
my $doc_html=qq{\n$text_html};
my $doc_safe=qq{\n$text_safe};
my $doc_safe_hex=qq{\n$text_safe_hex};
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");
is( normalize_xml( $t->sprint( pretty_print => 'indented')), normalize_xml( $doc_latin1), 'latin1');# test 344
$t->set_output_filter( 'latin1' );
$t->set_output_encoding( "ISO-8859-1");
is( $t->sprint, $doc_latin1, 'latin1 (just the string)');# test 345
}
$t->set_output_text_filter( );
$t->set_output_encoding( "UTF-8");
$t->restore_global_state;
eval "require HTML::Entities";
if( $@)
{ skip( 4, "need HTML::Entities for those tests"); }
elsif( $perl == 5.008)
{ skip( 4, "HTML::Entities don't seem to work well with perl 5.8.0 (the e acute becomes é instead of é)"); }
else
{
import HTML::Entities;
$t->save_global_state;
$t->set_output_encoding( "UTF-8");
my $original_output_text_filter= $t->output_text_filter;
$t->set_output_text_filter( "html");
my $html_output_text_filter= $t->output_text_filter;
is( $t->sprint, $doc_html, "output_text_filter html");# test 346
$t->set_output_text_filter( $original_output_text_filter);
is( $t->sprint, $doc_utf8, "no output_text_filter ");# test 347
my $original_output_filter= $t->output_filter;
$t->set_output_filter( "html");
is( $t->sprint, $doc_escaped, "output_filter html");# test 348
$t->restore_global_state;
$t->set_output_encoding( "UTF-8");
is( $t->sprint, $doc_utf8, "no output_text_filter ");# test 349
}
$t->restore_global_state;
$t->set_output_encoding();
eval "require Text::Iconv";
if( $@)
{ skip( 3, "need Text::Iconv for those tests"); }
else
{ my $encoding= 'ISO-8859-1';
if( eval( '$t->iconv_convert( "$encoding");'))
{ $t->set_output_filter( $t->iconv_convert( $encoding) );
$t->set_encoding( $encoding);
is( $t->encoding, $encoding, "set_encoding");# test 350
is( $t->sprint, $doc_latin1, "output_filter ISO-8859-1 (using Text::Iconv)");# test 351
$t->restore_global_state;
$t->set_output_encoding( "UTF-8");
is( $t->sprint, $doc_utf8, "no output_filter ");# test 352
}
else
{ if( $@=~ m{^Unsupported encoding: $encoding})
{ skip( 3, "your version of iconv does not support $encoding"); }
else
{ skip( 3, "odd error creating filter with iconv: $@"); }
}
}
$t->restore_global_state;
$t->set_output_encoding();
eval( 'require Unicode::Map8 && require Unicode::String;');
if( $@)
{ skip( 3, "need Unicode::Map8 and Unicode::String for those tests" ); }
else
{ $t->set_output_filter( $t->unicode_convert( 'latin1') );
$t->set_encoding( "ISO-8859-1");
is( $t->encoding, "ISO-8859-1", "set_encoding");# test 353
is( $t->sprint, $doc_latin1, "output_filter latin-1 (using Unicode::*)");# test 354
$t->restore_global_state;
$t->set_output_encoding( "UTF-8");
is( $t->sprint, $doc_utf8, "no output_filter ");# test 355
$t->restore_global_state;
$t->set_output_encoding();
}
$t->set_output_filter( $t->regexp2latin1 );
$t->set_encoding( "ISO-8859-1");
is( $t->encoding, "ISO-8859-1", "set_encoding");# test 356
is( $t->sprint, $doc_latin1, "output_filter latin-1 (using regexp2latin1)");# test 357
$t->restore_global_state;
$t->set_output_encoding( "UTF-8");
is( $t->sprint, $doc_utf8, "no output_filter ");# test 358
$t->restore_global_state;
$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{};
my $body= qq{
text
};
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=']>
p 1
text more text &foo;
';
my $doc_flushed=qq{
p 1
a
text more text bar
};
$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{};
my $body= qq{
text
foo:e textt[};
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="
p 1
text more text
";
my $doc_flushed=qq{
p 1
a
text more text
};
$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{]>toto = &toto;};
$t= XML::Twig->new()->parse( $doc);
$output='';
$writer = XML::SAX::Writer->new( Output => \$output);
$t->toSAX2( $writer);
$output=~ s{}{}s; # shows that in fact we have a problem with outputing the DTD
is( normalize_xml( $output), 'toto = foo', 'toSAX2 with an entity');# test 365
$doc= qq{toto = &toto;};
$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( '');
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->root->set_twig_current;
ok( $t->root->{twig_current}, "root is twig current");# test 371
$t->root->del_twig_current;
nok( $t->root->{twig_current}, "root is not twig current");# test 372
ok( $t->root->closed, "root is closed");# test 373
}
# test ignore
{ my $t= XML::Twig->new( start_tag_handlers => { ignore => sub { $_[0]->ignore },
ignore_parent => sub { $_->parent->ignore },
},
)
->parse( '
yes 1
no 1
yes 2
no 2
');
is( $t->sprint, '
yes 1
yes 2
', "ignore");# test 374
}
# test subs_text with replacement
{ my $doc= 'text rep
text rep
text rep';
(my $rep1= $doc)=~ s/rep/newr/g;
(my $rep2= $doc)=~ s{rep}{new}g;
(my $rep3= $rep2)=~ s{ }{ }g;
my $t= XML::Twig->new->parse( $doc);
$t->root->subs_text( qr/(r)ep/, 'new$1');
is( $t->sprint, $rep1, "subs_text");# test 375
$t->root->subs_text( qr/(new)r/, '&elt( b => $1)');
is( $t->sprint, $rep2, "subs_text (with elt)");# test 376
$t->root->subs_text( qr/ /, '&ent( " ")');
is( $t->sprint, $rep3, "subs_text (with ent)");# test 377
}
# test handlers that are not activated in 5.8
package test_handlers;
sub new { bless { } }
sub recognized_string { return 'recognized_string'; }
sub original_string { return 'original_string'; }
package main;
{ if( $perl < 5.008)
{ skip( 4, "need perl 5.8 or above to perform these tests (you have $perl)"); }
else
{
my $out='';
$open->( my $fh, ">", \$out);
my $stdout= select $fh;
XML::Twig::_twig_print_original_default( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'original_string', 'twig_print_original_default');# test 378
$out='';
$open->( $fh, ">", \$out);
select $fh;
XML::Twig::_twig_print( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'recognized_string', 'twig_print');# test 379
$out='';
$open->( $fh, ">", \$out);
select $fh;
XML::Twig::_twig_print_end_original( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'original_string', 'twig_print_end_original');# test 380
$out='';
$open->( $fh, ">", \$out);
select $fh;
XML::Twig::_twig_print( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'recognized_string', 'twig_print');# test 381
}
XML::Twig::_twig_print_entity; # does nothing!
}
{
my %ents= ( foo => '"toto"', pile => 'SYSTEM "file.bar" NDATA bar');
my %ent_text = hash_ent_text( %ents);
my $ent_text = string_ent_text( %ents);
my $doc= "";
my $t= XML::Twig->new->parse( $doc);
is( normalize_xml( $t->entity_list->text), $ent_text, 'entity_list');# test 382
my @entities= $t->entity_list->list;
is( scalar @entities, scalar keys %ents, 'entity_list');# test 383
if( $perl < 5.008)
{ skip( (scalar( keys %ents) + 1), "need perl 5.8 or above to perform these tests (you have $perl)"); }
else
{
foreach my $ent (@entities)
{ my $out='';
$open->( my $fh, ">", \$out);
my $stdout= select $fh;
$ent->print;
close $fh;
select $stdout;
is( normalize_xml( $out), $ent_text{$ent->name}, "print $ent->{name}"); # 2 tests 384 - 385
}
my $out='';
$open->( my $fh, ">", \$out);
my $stdout= select $fh;
$t->entity_list->print;
close $fh;
select $stdout;
is( normalize_xml( $out), $ent_text, 'print entity_list');# test 386
}
delete $ents{pile};
%ent_text = hash_ent_text( %ents);
$ent_text = string_ent_text( %ents);
$t->entity_list->delete( 'pile');
@entities= $t->entity_list->list;
is( scalar @entities, scalar keys %ents, '1 entity deleted');# test 387
is( $t->entity_list->text, $ent_text, 'entity_list (one entity deleted)');# test 388
}
{
if( $perl < 5.008)
{ skip( 3, "need perl 5.8 or above to perform these tests (you have $perl)"); }
else
{ my $out1=''; $open->( my $fh1, ">", \$out1);
my $out2=''; $open->( my $fh2, ">", \$out2);
my $out3=''; $open->( my $fh3, ">", \$out3);
my $stdout= select $fh3;
my $t= XML::Twig->new( twig_handlers => { e => sub { $_->print( $fh2);
print $fh1 "X";
$_[0]->finish_print( $fh1);
},
},
)
->parse( 'texte
text
more text
foo
');
print 'should be in $out3';
select $stdout;
is( $out1, 'Xmore text
foo
', 'finish_print');# test 389
is( $out2, 'e
text
', 'print to fh');# test 390
is( $out3, 'should be in $out3', 'restoring initial fh');# test 391
}
}
# test prefix mappings
package test_sax_prefix_mapping;
sub new { return bless { out => 'start ' }; }
sub start_element { my( $h, $element)= @_; $h->{out}.= "- start $element->{Name} "; }
sub end_element { my( $h, $element)= @_; $h->{out}.= "- end $element->{Name} "; }
sub start_prefix_mapping { my( $h, $map)= @_; $h->{out}.= "- map $map->{Prefix} to $map->{NamespaceURI} "; }
sub end_prefix_mapping { my( $h, $map)= @_; $h->{out}.= "- end map $map->{Prefix} "; }
sub end_document { my( $h, $document)= @_; return $h->{out}; }
package main;
{ my $h= test_sax_prefix_mapping->new;
my $t= XML::Twig->new->parse( q{
text
text
});
my $out= $t->toSAX2( $h);
is( $out, 'start - map to uri1 - start doc - map p1 to uri2 - start p - start p1:e - end p1:e - end p - end map p1 - map p1 to uri3 - start p - start p1:e - end p1:e - end p - end map p1 - end doc - end map ', 'prefix mapping');# test 392
}
# test parsing with keep_encoding (to check no spurious warnings are produced)
{ my $warnings='';
$SIG{__WARN__}= sub { $warnings .= shift; };
my $doc= '
text
more text > é
';
my $t= XML::Twig->new( keep_encoding => 1)->parse( $doc);
$SIG{__WARN__}= $old_warning_handler;
is( $warnings, '', 'keep_encoding with elements with no attributes');# test 393
is( $t->sprint, $doc, 'twig output');# test 394
}
# test end_tag_handlers with ignore
{
my $out='';
my $t= XML::Twig->new( twig_roots => { p => 1 },
start_tag_handlers => { x => sub { $out .= "s" } },
twig_handlers => { n => sub { $out .="n";},
x => sub { $out .="e"; }
},
)
->parse( '
text text more text
');
is( $out, 'snese', 'end_tag_handlers without ignore');# test 395
$out='';
$t= XML::Twig->new( twig_roots => { p => 1 },
start_tag_handlers => { x => sub { $out .= "s"; $_->ignore } },
end_tag_handlers => { x => sub { $out .="e"; }, },
twig_handlers => { n => sub { $out .="n"; }, },
)
->parse( '
text text more text
');
is( $out, 'sese', 'end_tag_handlers with ignore');# test 396
eval ' XML::Twig->new( start_tag_handlers => { x => sub { $out .= "s"; $_->ignore } },
end_tag_handlers => { x => sub { $out .="e"; }, },
twig_handlers => { n => sub { $out .="n"; }, },
);
';
matches( $@, '^you should not use EndTagHandlers without', "error using end_tag_handlers");# test 397
$out='';
$t= XML::Twig->new( force_end_tag_handlers_usage => 1,
start_tag_handlers => { x => sub { $out .= "s"; $_->ignore } },
end_tag_handlers => { x => sub { $out .="e"; }, },
twig_handlers => { n => sub { $out .="n"; }, },
)
->parse( '
text text more text
');
is( $out, 'sesen', 'end_tag_handlers with ignore and force_end_tag_handlers_usage');# test 398
}
{ my @doc=( "",
"",
"",
"",
);
my( @r1, @r2, @r3, @r4);
my $t1= XML::Twig->new( ignore_elts => { lignore => 1 },
twig_handlers => { root => sub { push @r1, $_->tag; },
l1 => sub { push @r1, $_->tag; },
}
);
my $t2= XML::Twig->new( twig_handlers => { root => sub { push @r2, $_->tag; },
lignore => sub { $_->parent( 'l1')->ignore; },
},
);
my $t3= XML::Twig->new(
twig_handlers => { root => sub { push @r3, $_->tag; },
lignore => sub { $_->parent( 'l1')->ignore; },
},
end_tag_handlers => { l1 => sub { push @r3, $_[1]; }, },
force_end_tag_handlers_usage => 1
);
my $t4= XML::Twig->new( twig_roots => { l1 => sub { push @r4, 'l1 from roots handler'; },
lignore => sub { $_->parent( 'l1')->ignore; },
},
end_tag_handlers => { 'root/l1' => sub { push @r4, 'l1 from end_tag_handler'; }, },
);
my $i=0;
foreach my $doc (@doc)
{ @r1=(); @r2=(); @r3=(); @r4=();
$i++;
$t1->parse( $doc);
is( join( ':', @r1), "l1:root", "ignore_elt with twig_handlers $i (checking that stack is properly resized)");
$t2->parse( $doc);
is( join( ':', @r2), "root", "ignore_elt on ancestor with twig_handlers $i (checking that stack is properly resized)");
$t3->parse( $doc);
is( join( ':', @r3), "l1:root", "ignore_elt on ancestor with twig_handlers and end_tag_handlers $i (checking that stack is properly resized)");
$t4->parse( $doc);
is( join( ':', @r4), "l1 from end_tag_handler", "ignore_elt on ancestor with twig_roots and end_tag_handlers $i (checking that stack is properly resized)");
}
}
{
my $warning="";
$SIG{__WARN__} = sub { $warning .= join '', @_ };
my $t= XML::Twig->new( dummy_opt2 => 1);
$SIG{__WARN__}= $old_warning_handler;
matches( $warning, '^invalid option', "warning for extra option");# test 399
}
# test various handlers
{ my %got;
my $doc= 'foobarfoono';
my @handler_exp= ( 'e', 'doc/e', '/doc/e', 'a[@a1]', 'a[@a2]', 'a[@a1="v11"]',
'a[@a1="v21"]', '*[@a1]', '*[@a1="v11"]', '*[@a1="v21"]', '*[@a1=~/^v21$/]',
't[string()="foobar"]', 't[string()=~ /^foo/]', 't[string()=~ /bar$/]',
'_default_',
);
my %handlers;
foreach my $exp (@handler_exp)
{ my $code= "\$got{\$_->id}||=[]; push \@{\$got{\$_->id}}, '$exp'; 1";
my $sub= eval "sub { $code }";
die "oops, error in test, code is '$code'" if( $@);
$handlers{$exp}= $sub;
}
my $t= XML::Twig->new( twig_handlers => \%handlers)->parse( $doc);
my %expected= ( e1 => [ '/doc/e', 'doc/e', 'e' ],
no1 => [ '_default_'],
a1 => [ '*[@a1]', '*[@a1="v11"]', 'a[@a1]', 'a[@a2]', 'a[@a1="v11"]' ],
a2 => [ '*[@a1]', '*[@a1="v21"]', 'a[@a1]', 'a[@a2]', 'a[@a1="v21"]', '*[@a1=~/^v21$/]' ],
b1 => [ '*[@a1]', '*[@a1="v11"]' ],
b2 => [ '*[@a1="v21"]', '*[@a1]', '*[@a1=~/^v21$/]'],
t1 => [ 't[string()="foobar"]', 't[string()=~ /^foo/]', 't[string()=~ /bar$/]' ],
t2 => [ 't[string()=~ /^foo/]' ],
t3 => [ '_default_'],
doc1 => [ '_default_'],
);
foreach my $elt (sort keys %expected)
{ my $expected= join( ' - ', sort @{$expected{$elt}});
my $got= $got{$elt} ? join( ' - ', sort @{$got{$elt}}) : '';
is( $got, $expected, "handlers on $elt"); # 10 tests 400 - 409
}
my %handlers2;
my %got2;
foreach my $exp (@handler_exp)
{ my $code= "\$got2{\$_->id}||=[]; push \@{\$got2{\$_->id}}, '$exp:2'; 1";
my $sub= eval "sub { $code }";
die "oops, error in test, code is '$code'" if( $@);
$t->setTwigHandler( $exp, $sub);
}
$t->parse( $doc);
foreach my $elt (sort keys %expected)
{ my $expected= join( ' - ', map { "$_:2" } sort @{$expected{$elt}});
my $got= $got2{$elt} ? join( ' - ', sort @{$got2{$elt}}) : '';
is( $got, $expected, "handlers on $elt (2)"); # 10 tests 410 - 419
}
}
{ my $t= XML::Twig->new->parse( '');
$t->change_gi( elt1 => 'elt2');
$t->change_gi( elt3 => 'elt4');
is( $t->sprint, '', 'change_gi');# test 420
}
# these do not pass (yet?)
{ my $doc= '
text
<ignored>
more text
';
my $t= XML::Twig->new( start_tag_handlers => { i => sub { $_->ignore( 'string') }})
->parse( $doc);
is( $t->sprint, '
};
is( XML::Twig->new( use_tidy => 1 )->safe_parse_html( $html)->sprint, $expected, 'safe_parse_html');
my $html_file= "t/test_3_30.html";
spit( $html_file, $html);
is( XML::Twig->new( use_tidy => 1 )->safe_parsefile_html( $html_file)->sprint, $expected, 'safe_parsefile_html');
if( _use( 'LWP'))
{ is( XML::Twig->new( use_tidy => 1 )->safe_parseurl_html( "file:$html_file")->sprint, $expected, 'safe_parseurl_html'); }
else
{ skip( 1, "LWP not available, cannot test safe_parseurl_html"); }
unlink $html_file;
}
else
{ skip( 3, "HTML::Tidy not available, cannot test safe_parse.*_html methods with the use_tidy option"); }
}
{ # testing parse_html with use_tidy
if( XML::Twig::_use( 'HTML::Tidy') && XML::Twig::_use( 'LWP::Simple') && XML::Twig::_use( 'LWP::UserAgent'))
{ my $html= q{Tt t2
t3};
my $tidy= HTML::Tidy->new( { output_xhtml => 1, # duh!
tidy_mark => 0, # do not add the "generated by tidy" comment
numeric_entities => 1,
char_encoding => 'utf8',
bare => 1,
clean => 1,
doctype => 'transitional',
fix_backslash => 1,
merge_divs => 0,
merge_spans => 0,
sort_attributes => 'alpha',
indent => 0,
wrap => 0,
break_before_br => 0 } );
$tidy->ignore( type =>1, type => 2);
my $expected= $tidy->clean( $html);
$expected=~ s{>new( use_tidy => 1)->parse_html( $html)->sprint, $expected, 'parse_html string using HTML::Tidy');
my $html_file= File::Spec->catfile( "t", "test_new_features_3_22.html");
spit( $html_file => $html);
if( -f $html_file)
{ is_like( XML::Twig->new( use_tidy => 1)->parsefile_html( $html_file)->sprint, $expected, 'parsefile_html using HTML::Tidy');
open( HTML, "<$html_file") or die "cannot open HTML file '$html_file': $!";
is_like( XML::Twig->new( use_tidy => 1)->parse_html( \*HTML)->sprint, $expected, 'parse_html fh using HTML::Tidy');
}
else
{ skip( 2, "could not write HTML file in t directory, check permissions"); }
}
else
{ skip( 3 => 'need HTML::Tidy and LWP to test parse_html with the use_tidy option'); }
}
{ if( XML::Twig::_use( 'HTML::TreeBuilder'))
{ my $html_with_Amp= XML::Twig->new->parse_html( '
&Amp;')->sprint;
if( $HTML::TreeBuilder::VERSION <= 3.23)
{ is( $html_with_Amp, '&', '&Amp; used in html (fixed HTB < 4.00)'); }
else
{ is( $html_with_Amp, '&Amp;', '&Amp; used in html (NOT fixed HTB > r.00)'); }
is( XML::Twig->new->parse_html( '')->sprint,
'',
'extra XML declaration in html'
);
my $doc=q{
fooah
};
(my $expected= $doc)=~s{}{}g;
is_like( XML::Twig->parse($doc)->sprint, $expected, 'CDATA and comments in html');
}
else
{ skip( 3, 'need HTML::TreeBuilder for additional HTML tests'); }
}
{ my $t= XML::Twig->parse( '');
$t->{twig_root}= undef;
is( $t->first_elt, undef, 'first_elt on empty tree');
is( $t->last_elt, undef, 'last_elt on empty tree');
}
{ if( XML::Twig::_use( 'XML::XPathEngine') && XML::Twig::_use( 'XML::Twig::XPath'))
{ my $t= XML::Twig::XPath->new->parse( '');
eval { $t->get_xpath( '//d[.//p]'); };
matches( $@, qr{the expression is a valid XPath statement, and you are using XML::Twig::XPath}, 'non XML::Twig xpath with get_xpath');
}
else
{ skip( 1); }
}
{ my $r= XML::Twig->parse( '')->root;
is( $r->is_empty, 0, 'non empty element');
$r->cut_children( 'e');
is( $r->is_empty, 0, 'non empty element after cut_children');
$r->cut_children( 'e1');
is( $r->is_empty, 1, 'empty element after cut_children');
}
{ my $r= XML::Twig->parse( '')->root;
is( $r->is_empty, 0, 'non empty element');
$r->cut_descendants( 'e');
is( $r->is_empty, 0, 'non empty element after cut_descendants');
$r->cut_descendants( 'e1');
is( $r->is_empty, 1, 'empty element after cut_descendants');
}
{ if( XML::Twig::_use( 'LWP::Simple'))
{ eval { XML::Twig->parse( 'file://not_there'); };
matches( $@, 'no element found', 'making xparse fail');
}
else
{ skip( 1); }
}
{ is( XML::Twig::Elt::_short_text( 'a', 0), 'a', 'shorten with no length');
}
{ is( XML::Twig->parse( comments => 'process', pi => 'process', pretty_print => 'indented',
""
)->sprint,
"\n \n \n \n \n \n \n \n \n\n",
'indenting pi and comments'
);
}
{ XML::Twig::_set_debug_handler(3);
XML::Twig->new( twig_handlers => { 'foo[@a="bar"]' => sub { $_->att( 'a')++; } });
my $expected=<<'EXPECTED';
parsing path 'foo[@a="bar"]'
predicate is: '@a="bar"'
predicate becomes: '$elt->{'a'} eq "bar"'
perlfunc:
no warnings;
my( $stack)= @_;
my @current_elts= (scalar @$stack);
my @new_current_elts;
my $elt;
warn q{checking path 'foo[@a="bar"]'
};
foreach my $current_elt (@current_elts)
{ next if( !$current_elt);
$current_elt--;
$elt= $stack->[$current_elt];
if( ($elt->{'##tag'} eq "foo") && $elt->{'a'} eq "bar") { push @new_current_elts, $current_elt;}
}
unless( @new_current_elts) { warn qq%fail at cond '($elt->{'##tag'} eq "foo") && $elt->{'a'} eq "bar"'%;
return 0; }
@current_elts= @new_current_elts;
@new_current_elts=();
warn "handler for 'foo[@a="bar"]' triggered\n";
return q{foo[@a="bar"]};
last tag: 'foo', test_on_text: '0'
score: anchored: 0 predicates: 3 steps: 1 type: 3
EXPECTED
my $got= XML::Twig::_return_debug_handler();
$got=~ s{\\}{}g;
$expected=~ s{\\}{}g;
is( $got, $expected, 'handler content');
XML::Twig::_set_debug_handler( 0);
}
{ my $t=XML::Twig->parse( elt_class => 'XML::Twig::Elt', '');
is( ref($t->root), 'XML::Twig::Elt', 'alternate class... as the default one!');
}
{ my( $triggered_bare, $triggered_foo);
my $t= XML::Twig->new( twig_handlers => { 'e1[@#a]' => sub { $triggered_bare.=$_->id; },
'e1[@#a="foo"]' => sub { $triggered_foo .=$_->id; },
e2 => sub { $_->parent->set_att( '#a', 1); },
e4 => sub { $_->parent->set_att( '#a', 'foo'); },
}
)
->parse( '');
is( $triggered_bare, 'e1.1e1.2', 'handler condition on bare private attribute');
is( $triggered_foo , 'e1.1', 'handler condition on valued private attribute');
}
{ my $t= XML::Twig->parse( '');
$t->root->remove_class( 'foo');
is( $t->root->class, '', 'empty class after remove_class');
my $e= $t->first_elt( 'e');
$e->remove_class( 'foo');
is( $e->class, 'bar baz', 'remove_class on non-existent class');
$e->remove_class( 'baz');
is( $e->class, 'bar', 'remove_class');
$e->remove_class( 'foo');
is( $e->class, 'bar', 'remove_class on non-existent class (again)');
$e->remove_class( 'bar');
is( $e->class, '', 'remove_class until no class is left');
}
{ if( XML::Twig::_use( 'Text::Wrap'))
{ my $out= "t/test_wrapped.xml";
my $out_fh;
open( $out_fh, ">$out") or die "cannot create temp file $out: $!";
$Text::Wrap::columns=40;
$Text::Wrap::columns=40;
XML::Twig->parse( pretty_print => 'wrapped', '' . "foobarbaz " x 10 . '')
->print( $out_fh);
close $out_fh;
is( slurp( $out),qq{\n foobarbaz foobarbaz foobarbaz\n foobarbaz foobarbaz foobarbaz\n foobarbaz foobarbaz foobarbaz\n foobarbaz \n},
'wrapped print'
);
unlink $out;
}
else
{ skip( 1); }
}
sub all_text
{ return join ':' => map { $_->text } @_; }
1;
XML-Twig-3.50/t/xmlxpath_06attrib_val.t 0000755 0001750 0001750 00000001021 12346001774 020126 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 5);
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new->parse( \*DATA);
ok( $t);
my @nodes;
@nodes = $t->findnodes( '//BBB[@id = "b1"]');
ok(@nodes, 1);
@nodes = $t->findnodes( '//BBB[@name = "bbb"]');
ok(@nodes, 1);
@nodes = $t->findnodes( '//BBB[normalize-space(@name) = "bbb"]');
ok(@nodes, 2);
exit 0;
__DATA__
XML-Twig-3.50/t/test_variables.t 0000755 0001750 0001750 00000002635 12346001774 016727 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
print "1..6\n";
#warn "\n\n### warnings are normal here ###\n\n";
my $t= XML::Twig->new->parse( \*DATA);
# intercept warnings
$SIG{__WARN__} = sub { print STDERR @_ if( $_[0]=~ /^test/); };
my $s= $t->simplify( var_attr => 'var', variables => { 'v2' => 'elt2'});
if( $s->{elt2} eq 'elt using elt1') { print "ok 1\n" }
else { print "not ok 1\n"; warn "test 1: /$s->{elt2}/ instead of 'elt using elt1'\n"; }
if( $s->{elt3} eq 'elt using elt1') { print "ok 2\n" }
else { print "not ok 2\n"; warn "test 2: /$s->{elt3}/ instead of 'elt using elt1'\n"; }
if( $s->{elt4} eq 'elt using elt2') { print "ok 3\n"; warn "\n"; }
else { print "not ok 3\n"; warn "test 3: /$s->{elt4}/ instead of 'elt using elt2'\n"; }
if( $s->{elt5}->{att1} eq 'att with elt1') { print "ok 4\n" }
else { print "not ok 4\n"; warn "test 4: /$s->{elt5}->{att1}/ instead of 'att with elt1'\n"; }
$s= $t->simplify( variables => { 'v2' => 'elt2'});
if( $s->{elt2} eq 'elt using $v1') { print "ok 5\n" }
else { print "not ok 5\n"; warn "test 5: /$s->{elt2}/ instead of 'elt using \$v1'\n"; }
if( $s->{elt4} eq 'elt using elt2') { print "ok 6\n" }
else { print "not ok 6\n"; warn "test 6: /$s->{elt4}/ instead of 'elt using elt2'\n"; }
exit 0;
__DATA__
elt1elt using $v1elt using ${v1}elt using $v2
XML-Twig-3.50/t/xmlxpath_14axisancestor.t 0000755 0001750 0001750 00000001054 12346001774 020507 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 5);
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new->parse( \*DATA);
ok( $t);
my @nodes;
@nodes = $t->findnodes( '/AAA/BBB/DDD/CCC/EEE/ancestor::*');
ok(@nodes, 4);
ok($nodes[1]->getName, "BBB"); # test document order
@nodes = $t->findnodes( '//FFF/ancestor::*');
ok(@nodes, 5);
exit 0;
__DATA__
XML-Twig-3.50/t/xmlxpath_25scope.t 0000755 0001750 0001750 00000000643 12346001775 017123 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 4);
use XML::Twig::XPath;
ok(1);
eval
{
# Removing the 'my' makes this work?!?
my $t= XML::Twig::XPath->new->parse( '');
ok( $t);
$t->findnodes( '/test');
ok(1);
die "This should be caught\n";
};
if ($@)
{
ok(1);
}
else {
ok(0);
}
exit 0;
XML-Twig-3.50/t/test_3_38.t 0000755 0001750 0001750 00000006664 12346001774 015441 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
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 $TMAX=21;
print "1..$TMAX\n";
my $d= '';
{ my $r= XML::Twig->parse( $d)->root;
my $result = $r->att('a');
is( $r->sprint, $d, 'att');
}
{ my $r= XML::Twig->parse( $d)->root;
my $result = foo($r->att('a'));
is( $r->sprint, $d, 'att in sub(1)');
}
{ my $r= XML::Twig->parse( $d)->root;
my $result = sub { return @_ }->($r->att('a'));
is( $r->sprint, $d, 'att in anonymous sub');
}
{ my $r= XML::Twig->parse( $d)->root;
my $a= $r->att( 'a');
is( $r->sprint, $d, 'att in scalar context');
}
{ my $r= XML::Twig->parse( $d)->root;
my( $a1, $a2)= ($r->att( 'a1'), $r->att( 'a2'));
is( $r->sprint, $d, 'att in list context');
}
{ my $r= XML::Twig->parse( $d)->root;
$r->att( 'a');
is( $r->sprint, $d, 'att in void context');
}
{ my $r= XML::Twig->parse( $d)->root;
my $result = $r->att('a');
is( $r->sprint, $d, 'att');
}
{ my $r= XML::Twig->parse( $d)->root;
my $result = foo($r->class);
is( $r->sprint, $d, 'class in sub(1)');
}
{ my $r= XML::Twig->parse( $d)->root;
my $result = sub { return @_ }->($r->class);
is( $r->sprint, $d, 'att in anonymous sub');
}
{ my $r= XML::Twig->parse( $d)->root;
my $a= $r->class;
is( $r->sprint, $d, 'class in scalar context');
}
{ my $r= XML::Twig->parse( $d)->root;
my( $a1, $a2)= ($r->class, $r->class);
is( $r->sprint, $d, 'class in list context');
}
{ my $r= XML::Twig->parse( $d)->root;
$r->class;
is( $r->sprint, $d, 'class in void context');
}
{ my $t= XML::Twig->new->parse( '');
$t->root->latt( 'a')= 1;
is( $t->sprint, '', 'latt');
}
{ my $r= XML::Twig->parse( $d)->root;
my $att= $r->att( 'foo');
is( $att, undef, 'unexisting att');
}
# my $value = $root->att('any_attribute');
# $result = length($value);
sub foo { return @_; }
{
my $r;
my $doc='<_e id="e1"><_e id="e2"><_foo a="2" id="foo"/>';
my $t= XML::Twig->new( twig_handlers => { _e => sub { $r.= $_->id } })
->parse( $doc);
is( $r, 'e1e2', 'handler, condition on tag starting with an underscore');
is( $t->first_elt( '_foo')->id, 'foo', 'navigation, element name starts with underscore');
is( $t->first_elt( '*[@_a="2"]')->id, 'bar', 'navigation, attribute name starts with underscore');
}
{ if( _use( 'LWP') && _use( 'HTML::TreeBuilder') )
{ my $html=q{
Title
foo bar
};
my $expected= qq{
Title
foo bar
};
my $html_file= "t/test_3_38.html";
spit( $html_file, $html);
is( scrub_xhtml( XML::Twig->new( )->parseurl_html( "file:$html_file")->sprint), $expected, 'parseurl_html');
unlink $html_file;
}
else
{ skip( 1, "LWP and/or HTML::TreeBuilder not available, cannot test safe_parseurl_html"); }
}
{ my $doc=" foo bar baz";
is( XML::Twig->parse( $doc)->simplify( normalize_space => 2)->{e}, 'foo bar baz', 'simplify with normalize_space => 2');
}
{ my $doc="foo bar foofoo foobar totofoo";
my $t= XML::Twig->parse( $doc);
is( $t->subs_text( qr/(f)o(o)/, '&elt(b => $1) $2')->sprint, 'f o bar f of o f obar totof o', 'complex subs_text');
}
{ my $t= XML::Twig->parse( 'e1e2');
is( join( '-', $t->findvalues( '//e')), 'e1-e2', 'findvalues');
}
1;
XML-Twig-3.50/t/test_expand_external_entities.xml 0000644 0001750 0001750 00000000155 12346001775 022372 0 ustar mrodrigu mrodrigu
');
my $elt= $t->root;
eval { $elt->sort_children( sub { }, type => 'wrong'); };
matches( $@, "wrong sort type 'wrong', should be either 'alpha' or 'numeric'", "sort type");
}
{
foreach my $wrong_path ( 'wrong path', 'wrong##path', '1', '1tag', '///tag', 'tag/')
{ eval {XML::Twig->new( twig_handlers => { $wrong_path => sub {}});};
matches( $@, "unrecognized expression in handler: '$wrong_path'", "wrong handler ($wrong_path)");
}
eval {XML::Twig->new( input_filter => 'dummy')};
matches( $@, "invalid input filter:", "input filter");
eval {XML::Twig->new( input_filter => {})};
matches( $@, "invalid input filter:", "input filter");
}
{ foreach my $bad_tag ( 'toto', '<1toto', 'new( twig_handlers => { sax => sub { $_[0]->toSAX1 } });
eval {$t->parse( '')};
matches( $@, "cannot use toSAX1 while parsing", "toSAX1 during parsing");
}
{ my $t= XML::Twig->new( twig_handlers => { sax => sub { $_[0]->toSAX2 } });
eval {$t->parse( '')};
matches( $@, "cannot use toSAX2 while parsing", "toSAX2 during parsing");
}
{ my $t= XML::Twig->new->parse( '');
foreach my $bad_cond ( 'foo bar', 'foo:bar:baz', '.', '..', '...', '**', 'con[@to:ta:ti]')
{ eval { $t->root->first_child( qq{$bad_cond})};
matches( $@, "wrong navigation condition '\Q$bad_cond\E'", "bad navigation condition '$bad_cond'");
}
}
{ my $t= XML::Twig->new->parse( '');
eval { XML::Twig->parse( twig_handlers => { q{foo[@a="$sd"]} => sub { } }, ""); };
matches( $@, "^wrong handler condition", 'perl syntax in attribute value');
}
{ my $t= XML::Twig->new->parse( '');
eval { $t->root->set_field( '*[2]'); };
matches( $@, "can't create a field name from", 'set_field');
}
{ my $t= XML::Twig->new( twig_handlers => { erase => sub { $_->parent->erase } });
eval { $t->parse( '
toto
'); };
matches( $@, "trying to erase an element before it has been completely parsed", 'erase current element');
}
{ my $t= XML::Twig->new->parse( '');
my $e= $t->first_elt( 'erase')->cut;
eval { $e->erase };
matches( $@, "can only erase an element with no parent if it has a single child", 'erase cut element');
$e->paste( $t->root);
eval { $e->paste( first_child => $t->root); };
matches( $@, "cannot paste an element that belongs to a tree", 'paste uncut element');
$e->cut;
eval { $e->paste( $t->root => 'first_child' ); };
matches( $@, "wrong argument order in paste, should be", 'paste uncut element');
eval { $e->paste( first_child => {} ); };
matches( $@, "wrong target type in paste: 'HASH', should be XML::Twig::Elt", 'paste with wrong ref');
eval { $e->paste( 'first_child' ); };
matches( $@, "missing target in paste", 'paste with no target');
eval { $e->paste( 'first_child', 1 ); };
matches( $@, 'wrong target type in paste \(not a reference\)', 'paste with no ref');
eval { $e->paste( 'first_child', bless( {}, 'foo') ); };
matches( $@, "wrong target type in paste: 'foo'", 'paste with wrong object type');
eval { $e->paste( wrong => $t->root ); };
matches( $@, "tried to paste in wrong position 'wrong'", 'paste in wrong position');
eval { $e->paste( before => $t->root); };
matches( $@, "cannot paste before root", 'paste before root');
eval { $e->paste( after => $t->root); };
matches( $@, "cannot paste after root", 'paste after root');
eval { $e->paste_before( $t->root); };
matches( $@, "cannot paste before root", 'paste before root');
eval { $e->paste_after( $t->root); };
matches( $@, "cannot paste after root", 'paste after root');
}
{ my $t= XML::Twig->new->parse( '
text1
text2
');
my $p1= $t->root->first_child( 'p');
my $p2= $t->root->first_child( 'p[2]');
eval { $p1->merge_text( 'toto'); } ;
matches( $@, "invalid merge: can only merge 2 elements", 'merge elt and string');
eval { $p1->merge_text( $p2); } ;
matches( $@, "invalid merge: can only merge 2 text elements", 'merge non text elts');
$p1->first_child->merge_text( $p2->first_child);
is( $t->sprint, '
text1text2
', 'merge_text');
my $p3= XML::Twig::Elt->new( '#CDATA' => 'foo');
eval { $p1->first_child->merge_text( $p3); };
matches( $@, "invalid merge: can only merge 2 text elements", 'merge cdata and pcdata elts');
}
{ my $t= XML::Twig->new;
$t->save_global_state;
eval { $t->set_pretty_print( 'foo'); };
matches( $@, "invalid pretty print style 'foo'", 'invalid pretty_print style');
eval { $t->set_pretty_print( 987); };
matches( $@, "invalid pretty print style 987", 'invalid pretty_print style');
eval { $t->set_empty_tag_style( 'foo'); };
matches( $@, "invalid empty tag style 'foo'", 'invalid empty_tag style');
eval { $t->set_empty_tag_style( '987'); };
matches( $@, "invalid empty tag style 987", 'invalid empty_tag style');
eval { $t->set_quote( 'foo'); };
matches( $@, "invalid quote 'foo'", 'invalid quote style');
eval { $t->set_output_filter( 'foo'); };
matches( $@, "invalid output filter 'foo'", 'invalid output filter style');
eval { $t->set_output_text_filter( 'foo'); };
matches( $@, "invalid output text filter 'foo'", 'invalid output text filter style');
}
{ my $t= XML::Twig->new->parse( '');
my @methods= qw( depth in_element within_element context current_line current_column current_byte
recognized_string original_string xpcroak xpcarp xml_escape base current_element
element_index position_in_context
);
my $method;
foreach $method ( @methods)
{ eval "\$t->$method";
matches( $@, "calling $method after parsing is finished", $method);
}
$SIG{__WARN__}= $init_warn;
}
{ my $t= XML::Twig->new->parse( '');
my $elt= $t->root->first_child( 'elt')->cut;
foreach my $pos ( qw( before after))
{ eval { $elt->paste( $pos => $t->root); };
matches( $@, "cannot paste $pos root", "paste( $pos => root)");
}
}
{ my $t= XML::Twig->new->parse( 'f1f2');
eval { $t->root->simplify( group_tags => { a => 'f1' }); };
matches( $@, "error in grouped tag a", "grouped tag error f1");
eval { $t->root->simplify( group_tags => { a => 'f2' }); };
matches( $@, "error in grouped tag a", "grouped tag error f2");
eval { $t->root->simplify( group_tags => { a => 'f3' }); };
matches( $@, "error in grouped tag a", "grouped tag error f3");
}
{ eval { XML::Twig::Elt->parse( 'foo')->subs_text( "foo", '&elt( 0/0)'); };
matches( $@, "(invalid replacement expression |Illegal division by zero)", "invalid replacement expression in subs_text");
}
{ eval { my $t=XML::Twig->new( twig_handlers => { e => sub { $_[0]->parse( "") } });
$t->parse( "");
};
matches( $@, "cannot reuse a twig that is already parsing", "error re-using a twig during parsing");
}
{ ok( XML::Twig->new( twig_handlers => { 'elt[string()="foo"]' => sub {}} ), 'twig_handlers with string condition' );
eval { XML::Twig->new( twig_roots => { 'elt[string()="foo"]' => sub {}} ) };
matches( $@, "string.. condition not supported on twig_roots option", 'twig_roots with string condition' );
ok( XML::Twig->new( twig_handlers => { 'elt[string()=~ /foo/]' => sub {}} ), 'twig_handlers with regexp' );
eval { XML::Twig->new( twig_roots => { 'elt[string()=~ /foo/]' => sub {}} ) };
matches( $@, "string.. condition not supported on twig_roots option", 'twig_roots with regexp condition' );
#ok( XML::Twig->new( twig_handlers => { 'elt[string()!="foo"]' => sub {}} ), 'twig_handlers with !string condition' );
#eval { XML::Twig->new( twig_roots => { 'elt[string()!="foo"]' => sub {}} ) };
#matches( $@, "string.. condition not supported on twig_roots option", 'twig_roots with !string condition' );
#ok( XML::Twig->new( twig_handlers => { 'elt[string()!~ /foo/]' => sub {}} ), 'twig_handlers with !regexp' );
#eval { XML::Twig->new( twig_roots => { 'elt[string()!~ /foo/]' => sub {}} ) };
#matches( $@, "regexp condition not supported on twig_roots option", 'twig_roots with !regexp condition' );
}
{ XML::Twig::_disallow_use( "XML::Parser");
nok( XML::Twig::_use( "XML::Parser"), '_use XML::Parser (disallowed)');
XML::Twig::_allow_use( "XML::Parser");
ok( XML::Twig::_use( "XML::Parser"), '_use XML::Parser (allowed)');
ok( XML::Twig::_use( "XML::Parser"), '_use XML::Parser (allowed, 2cd try)');
nok( XML::Twig::_use( "XML::Parser::foo::nonexistent"), '_use XML::Parser::foo::nonexistent');
}
{ XML::Twig::_disallow_use( "Tie::IxHash");
eval { XML::Twig->new( keep_atts_order => 1); };
matches( $@, "Tie::IxHash not available, option keep_atts_order not allowed", 'no Tie::IxHash' );
}
{ eval { XML::Twig::_first_n { $_ } 0, 1, 2, 3; };
matches( $@, "illegal position number 0", 'null argument to _first_n' );
}
{ if( ( $] <= 5.008) || ($^O eq 'VMS') )
{ skip(1, 'test perl -CSDAL'); }
elsif( ! can_check_for_pipes() )
{ skip( 1, 'your perl cannot check for pipes'); }
else
{
my $infile= File::Spec->catfile('t','test_new_features_3_22.xml');
my $script= File::Spec->catfile('t','test_error_with_unicode_layer');
my $error=File::Spec->catfile('t','error.log');
my $perl = used_perl();
my $cmd= qq{$perl $q-CSDAL$q $script $infile 2>$error};
system $cmd;
matches( slurp( $error), "cannot parse the output of a pipe", 'parse a pipe with perlIO layer set to UTF8 (RT #17500)');
}
}
{ my $e1= XML::Twig::Elt->new( 'foo');
my $e2= XML::Twig::Elt->new( 'foo');
eval { $e1->paste_before( $e2); };
matches( $@, "cannot paste before an orphan element", 'paste before an orphan element' );
eval { $e1->paste_after( $e2); };
matches( $@, "cannot paste after an orphan element", 'paste after an orphan element' );
}
{ my $r= XML::Twig->parse( '')->root;
eval { $r->find_nodes( '//foo/1following::') };
matches( $@, "error in xpath expression", 'error in xpath expression //foo/following::');
}
# tests for https://rt.cpan.org/Public/Bug/Display.html?id=97461 (wrong error message due to filehandle seen as a file)
{ eval { XML::Twig->new->parse( do { open( my $fh, '<', $0); $fh}); };
not_matches( $@, "you seem to have used the parse method on a filename", "parse on a filehandle containing invalid XML");
open FOO, "<$0";
eval { XML::Twig->new->parse( \*FOO); };
not_matches( $@, "you seem to have used the parse method on a filename", "parse on a GLOBAL filehandle containing invalid XML");
}
exit 0;
sub can_check_for_pipes
{ my $perl = used_perl();
open( FH, qq{$perl -e$q print 1$q |}) or die "error opening pipe: $!";
return -p FH;
}
XML-Twig-3.50/t/latin1_accented_char.iso-8859-1 0000644 0001750 0001750 00000000002 12346001775 021013 0 ustar mrodrigu mrodrigu é
XML-Twig-3.50/t/xmlxpath_18axispreceding.t 0000755 0001750 0001750 00000001276 12346001775 020644 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 4);
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new->parse( \*DATA);
ok( $t);
my @nodes;
@nodes = $t->findnodes( '/AAA/XXX/preceding::*');
ok(@nodes, 4);
@nodes = $t->findnodes( '//GGG/preceding::*');
ok(@nodes, 8);
exit 0;
__DATA__
XML-Twig-3.50/t/test_3_30.t 0000755 0001750 0001750 00000034072 12346001774 015423 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
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 $TMAX=87;
print "1..$TMAX\n";
if( _use( 'Tie::IxHash'))
{ # test the new indent format example from http://tinyurl.com/2kwscq
my $doc=q{
};
my $formatted= XML::Twig->parse( keep_atts_order => 1, pretty_print => cvs => $doc)->sprint;
is( $formatted, $doc, 'cvs pretty_print');
}
else
{ skip( 1, "Tie::IxHash not available, cannot test the cvs pretty_print option"); }
if( $XML::Parser::VERSION > 2.27)
{ my $test_dir= "ent_test";
mkdir( $test_dir, 0777) or die "cannot create $test_dir: $!" unless( -d $test_dir);
my $xml_file_base = "test.xml";
my $xml_file= File::Spec->catfile( $test_dir => $xml_file_base);
my $ent_file_base = "ent.xml";
my $ent_file= File::Spec->catfile( $test_dir => $ent_file_base);
my $doc= qq{ ]>&ent;};
my $ent= qq{};
spit( $xml_file, $doc);
spit( $ent_file, $ent);
my $expected= '';
is( XML::Twig->parse( pretty_print => 'none', $xml_file)->root->sprint, $expected, 'entity resolving when file is in a subdir');
unlink $xml_file or die "cannot remove $xml_file: $!";
unlink $ent_file or die "cannot remove $ent_file: $!";
rmdir $test_dir or die "cannot remove $test_dir: $!";
}
else
{ skip( 1 => "known bug with old XML::Parser versions: base uri not taken into account,\n"
. "see RT #25113 at http://rt.cpan.org/Public/Bug/Display.html?id=25113"
);
}
{ my $doc= "";
my $doc_file= "doc.xml";
spit( $doc_file, $doc);
my $t= XML::Twig->new;
foreach (1..3)
{ $t->parse( $doc);
is( $t->sprint, $doc, "re-using a twig with parse (run $_)");
$t->parse( $doc);
is( $t->sprint, $doc, "re-using a twig with parse (run $_)");
$t->parsefile( $doc_file);
is( $t->sprint, $doc, "re-using a twig with parsefile (run $_)");
$t->parsefile( $doc_file);
is( $t->sprint, $doc, "re-using a twig with parsefile (run $_)");
}
unlink $doc_file;
}
{ my $invalid_doc= "";
my $invalid_doc_file= "invalid_doc.xml";
spit( $invalid_doc_file, $invalid_doc);
my $expected="e";
my( $result);
my $expected_sprint="";
my $t= XML::Twig->new( twig_handlers => { e => sub { $result.= $_->tag; shift->finish_now } });
foreach (1..3)
{ $result='';
$t->parse( $invalid_doc);
is( $result, $expected, "finish_now with parse (run $_)");
is( $t->sprint, $expected_sprint, "finish_now with parse (sprint, run $_)");
$result='';
$t->parsefile( $invalid_doc_file);
is( $result, $expected, "finish_now with parsefile (run $_)");
is( $t->sprint, $expected_sprint, "finish_now with parse (sprint, run $_)");
}
unlink $invalid_doc_file;
}
{ my $doc1=qq{\n\n]>\n t1 &e1; &e2;};
my $doc2=qq{\n\n]>\n t1 &e1; &e3;};
(my $edoc1 = $doc1)=~ s{&e(\d);}{[e$1]}g;
(my $edoc2 = $doc2)=~ s{&e(\d);}{[e$1]}g;
my $t= XML::Twig->new( keep_spaces => 1);
is( $t->parse( $doc1)->sprint, $edoc1, "XML::Twig reuse (run 1: doc1)");
is( $t->parse( $doc2)->sprint, $edoc2, "XML::Twig reuse (run 2: doc2)");
is( $t->parse( $doc1)->sprint, $edoc1, "XML::Twig reuse (run 3: doc1)");
is( $t->parse( $doc1)->sprint, $edoc1, "XML::Twig reuse (run 4: doc1)");
is( $t->parse( $doc2)->sprint, $edoc2, "XML::Twig reuse (run 5: doc2)");
is( $t->parse( $doc2)->sprint, $edoc2, "XML::Twig reuse (run 6: doc2)");
}
# some additional coverage
{ # entity sprint
my $tata= "tata content";
spit( "tata.txt", $tata);
my %ent_desc=( foo => q{"toto"}, bar => q{SYSTEM "tata.txt"}, baz => q{SYSTEM "tutu.txt" NDATA gif});
my %decl= map { $_ => "" } keys %ent_desc;
my $decl_string= join( '', values %decl);
my $doc= qq{};
my $t= XML::Twig->parse( $doc);
foreach my $ent (sort keys %decl)
{ is( $t->entity( $ent)->sprint, $decl{$ent}, "sprint entity $ent ($decl{$ent})"); }
}
{ # purge on an element
{ my $t= XML::Twig->parse( twig_handlers => { e2 => sub { $_->purge } }, q{});
is( $t->root->first_child->tag, 'e3', "purge on the current element");
}
{ my $t= XML::Twig->parse( twig_handlers => { e2 => sub { $_->prev_sibling->purge } }, q{});
is( $t->root->first_child->tag, 'e2', "purge on an element");
}
{ my $t= XML::Twig->parse( twig_handlers => { e2 => sub { $_->prev_sibling->purge( $_) } }, q{});
is( $t->root->first_child->tag, 'e3', "purge on an element up to the current element");
}
{ my $t= XML::Twig->parse( twig_handlers => { e3 => sub { $_->prev_sibling( 'e1')->purge( $_->prev_sibling) } }, q{});
is( $t->root->first_child->tag, 'e3', "purge on an element up to an other element");
}
{ my $t= XML::Twig->parse( twig_handlers => { e2 => sub { $_[0]->purge_up_to( $_->prev_sibling) } }, q{});
is( $t->root->first_child->tag, 'e2', "purge_up_to");
}
}
{ my $t= XML::Twig->parse( ']>');
is( $t->doctype_name, 'foo', 'doctype_name (with value)');
is( $t->system_id, 'foo.dtd', 'system_id (with value)');
is( $t->public_id, '-//xmltwig//DTD xmltwig test 1.0//EN', 'public_id (with value)');
is( $t->internal_subset, '', 'internal subset (with value)');
}
{ my $t= XML::Twig->parse( '');
is( $t->doctype_name, '', 'doctype_name (no value)');
is( $t->system_id, '', 'system_id (no value)');
is( $t->public_id, '', 'public_id (no value)');
is( $t->internal_subset, '', 'internal subset (no value)');
}
{ my $t= XML::Twig->parse( '');
is( $t->doctype_name, 'foo', 'doctype_name (with value)');
is( $t->system_id, 'foo.dtd', 'system_id (with value)');
is( $t->public_id, '', 'public_id (no value)');
is( $t->internal_subset, '', 'internal subset (no value)');
}
{ my $t= XML::Twig->parse( ']>');
is( $t->doctype_name, 'foo', 'doctype_name (with value)');
is( $t->system_id, '', 'system_id (no value)');
is( $t->public_id, '', 'public_id (no value)');
is( $t->internal_subset, '', 'internal subset (with value)');
}
{ my $prolog= ']>';
my $doc= '';
my $t= XML::Twig->parse( $prolog . $doc);
(my $expected_prolog= $prolog)=~ s{foo}{d};
$t->set_doctype( 'd');
is_like( $t->doctype, $expected_prolog, 'set_doctype');
is_like( $t->sprint, $expected_prolog . $doc);
}
{ # test external entity declaration with SYSTEM _and_ PUBLIC
# create external entities
my @ext_files= qw( tata1 tata2);
foreach my $file (@ext_files) { spit( $file => "content of $file"); }
my $doc= q{%bar1;%bar2;]>};
is_like( XML::Twig->parse( $doc)->sprint, $doc, 'external entity declaration with SYSTEM _and_ PUBLIC, regular parse/sprint');
my $out_file= "tmp_test_ext_ent.xml";
open( OUT, ">$out_file") or die "cannot create temp result file '$out_file': $!";
XML::Twig->parse( twig_roots => { elt => sub { $_->print( \*OUT) } }, twig_print_outside_roots => \*OUT, $doc);
close OUT;
is_like( slurp( $out_file), $doc, 'external entity declaration with SYSTEM _and_ PUBLIC, with twig_roots');
unlink $out_file;
open( OUT, ">$out_file") or die "cannot create temp result file '$out_file': $!";
XML::Twig->parse( twig_roots => { elt => sub { $_->print( \*OUT) } }, twig_print_outside_roots => \*OUT, keep_encoding => 1, $doc);
close OUT;
is_like( slurp( $out_file), $doc, 'external entity declaration with SYSTEM _and_ PUBLIC, with twig_roots and keep_encoding');
unlink @ext_files, $out_file;
}
{ my $doc= q{selt 1selt 2};
my $t= XML::Twig->parse( pretty_print => 'indented', $doc);
my $elt_indented = "\n selt 1\n selt 2";
my $elt_not_indented = "selt 1selt 2";
is( $t->first_elt( 'elt')->xml_string, $elt_indented, 'xml_string, indented');
is( $t->first_elt( 'elt')->xml_string( { pretty_print => 'none'} ), $elt_not_indented, 'xml_string, NOT indented');
is( $t->first_elt( 'elt')->xml_string, $elt_indented, 'xml_string, indented again');
}
{ my $doc=q{ ]>&zzent;};
eval { XML::Twig->new->parse( $doc); };
matches( $@, qr{zznot_there}, "missing SYSTEM entity: file info in the error message ($@)");
matches( $@, qr{zzent}, "missing SYSTEM entity: entity info in the error message ($@)");
}
{ if( _use( 'HTML::TreeBuilder', 3.13))
{ XML::Twig->set_pretty_print( 'none');
my $html=q{
Title
foo bar
};
my $expected= q{
Title
foo bar
};
is( XML::Twig->new->safe_parse_html( $html)->sprint, $expected, 'safe_parse_html');
my $html_file= "t/test_3_30.html";
spit( $html_file, $html);
is( XML::Twig->new->safe_parsefile_html( $html_file)->sprint, $expected, 'safe_parsefile_html');
if( _use( 'LWP'))
{ is( XML::Twig->new->safe_parseurl_html( "file:$html_file")->sprint, $expected, 'safe_parseurl_html'); }
else
{ skip( 1, "LWP not available, cannot test safe_parseurl_html"); }
unlink $html_file;
}
else
{ skip( 3, "HTML::TreeBuilder not available, cannot test safe_parse.*_html methods"); }
}
{ my $dump= XML::Twig->parse( q{text})->_dump;
my $sp=qr{[\s|-]*};
matches( $dump, qr{^document $sp doc $sp id="1" $sp elt $sp PCDATA: $sp 'text'\s*}x, "twig _dump");
}
{ my $dump= XML::Twig->parse( q{]>&foo;})->entity( 'foo')->_dump;
is( $dump, q{name => 'foo' - val => 'bar'}, "entity dump");
}
{ if( $XML::Parser::VERSION > 2.27)
{ my $t= XML::Twig->parse( q{ ]>&afoo;});
my $non_param_ent= $t->entity( 'afoo');
nok( $non_param_ent->param, 'param on a non-param entity');
my $param_ent= $t->entity( 'bfoo');
ok( $param_ent->param, 'param on a parameter entity');
}
else
{ skip( 2, "cannot use the param method with XML::Parser 2.27"); }
}
{ my $entity_file = "test_3_30.t.ent";
my $missing_file = "not_there";
spit( $entity_file => "entity text");
my $doc= qq{]>&foo;};
ok( eval { XML::Twig->parse( $doc)}, 'doc with missing external SYSTEM ents');
eval { XML::Twig->parse( expand_external_ents => 1, $doc)};
matches( $@, qr{cannot load SYSTEM entity 'bar' from 'not_there': }, 'missing SYSTEM entity');
ok( eval { XML::Twig->parse( $doc)}, 'doc with missing external SYSTEM ents');
my $t= XML::Twig->parse( expand_external_ents => -1, $doc);
my $missing_entities= $t->{twig_missing_system_entities};
is( scalar( values %$missing_entities), 1, 'number of missing system entities');
is( (values %$missing_entities)[0]->{name}, 'bar', 'name of missing system entity');
is( (values %$missing_entities)[0]->{sysid}, $missing_file, 'sysid of missing system entity');
eval { XML::Twig->parse( $doc)};
ok( eval { XML::Twig->parse( $doc)}, 'doc with missing external SYSTEM NDATA ents');
unlink( $entity_file);
}
{ my $entity_file = "test_3_30.t.gif";
my $missing_file = "not_there.gif";
spit( $entity_file => "entity text");
my $doc= qq{ ]>
};
my $t= XML::Twig->parse( $doc);
my $missing_entities= $t->{twig_missing_system_entities};
is( scalar( values %$missing_entities), 1, 'number of missing system entities');
is( $missing_entities->{barn}->name, 'barn', 'name of missing system entity');
is( $missing_entities->{barn}->sysid, $missing_file, 'sysid of missing system entity');
unlink( $entity_file);
}
{ my $doc= q{foo bar baz foobarxyztototatatutu};
my $t= XML::Twig->parse( twig_handlers => { b => sub { $_->erase } }, $doc);
is( scalar( $t->descendants( '#TEXT')), 3, 'text descendants, no melding');
$t->normalize;
is( scalar( $t->descendants( '#TEXT')), 3, 'text descendants, normalized');
}
{ my $doc=q{ee1e1-2};
XML::Twig::Elt->init_global_state(); # depending on which modules are available, the state could have been modified
my $tmp= "tmp";
open( TMP, ">$tmp") or die "cannot create temp file";
XML::Twig->parse( twig_roots => { e1 => sub { $_->flush( \*TMP) } }, twig_print_outside_roots => \*TMP, $doc);
close TMP;
my $res= slurp( $tmp);
is( $res, $doc, "bug in flush with twig_print_outside_roots");
unlink $tmp;
}
{ # test bug where #default appeared in attributes (RT #27617)
my $doc= '';
my $t= XML::Twig->new( map_xmlns => { 'foo' => 'ns2' },)->parse( $doc);
ok( grep { $_ eq 'att' } keys %{$t->root->first_child->atts}, 'no #default in attribute names');
}
exit;
1;
XML-Twig-3.50/t/test_3_39.t 0000755 0001750 0001750 00000005503 12346001775 015432 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
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 $TMAX=12;
print "1..$TMAX\n";
{
my $doc='foo bar fooo baz';
my $t= XML::Twig->parse( $doc);
$t->root->split( '(fo+)', e => { att => '$1' } );
is( $t->sprint, 'foo bar fooo baz', 'split, with $1 on attribute value');
$t= XML::Twig->parse( $doc);
$t->root->split( '(fo+)', e => { '$1' => 'v$1' } );
is( $t->sprint, 'foo bar fooo baz', 'split, with $1 on attribute name and value');
$t= XML::Twig->parse( $doc);
$t->root->split( '(fo+)', '$1' );
is( $t->sprint, 'foo bar fooo baz', 'split, with $1 on tag name');
$t= XML::Twig->parse( $doc);
$t->root->split( '(foo+)', '$1', '' );
is( $t->sprint, 'foo bar fooo baz', 'split, with $1 on tag name');
$t= XML::Twig->parse( $doc);
$t->root->split( '(fo+)(.*?)(a[rz])', x => { class => 'f' }, '', a => { class => 'x' });
is( $t->sprint, 'foo barfooo baz', 'split, checking that it works with non capturing grouping');
$t= XML::Twig->parse( $doc);
$t->root->split( '(fo+)(.*?)(a[rz])', x => { class => '$1' }, '', a => { class => '$3' });
is( $t->sprint, 'foo barfooo baz', 'split, with $1 and $3 on att value');
}
{ my $t= XML::Twig->parse( 'e1e2');
is( join( '-', $t->findvalues( '//e')), 'e1-e2', 'findvalues');
}
{ my $html='
boo
';
my $well_formed = qq{$html};
my $short_doctype = qq{$html};
my $t= XML::Twig->new->parse( $well_formed);
is_like( $t->sprint, $well_formed, 'valid xhtml');
if( _use( 'HTML::TreeBuilder'))
{ my $th= XML::Twig->new->parse_html( $well_formed);
is_like( $t->sprint, $well_formed, 'valid xhtml (parsed as html)');
my $t3= XML::Twig->new->parse_html( $short_doctype);
is_like( $t3->sprint, $html, 'xhtml without SYSTEM in DOCTYPE (parsed as html, no DOCTYPE output)');
my $t4= XML::Twig->new( output_html_doctype => 1)->parse_html( $short_doctype);
is_like( $t4->sprint, $well_formed, 'xhtml without SYSTEM in DOCTYPE (parsed as html, with proper DOCTYPE output)');
}
else
{ skip( 3); }
my $t2= XML::Twig->new->safe_parse( $short_doctype);
nok( $t2, 'xhtml without SYSTEM in DOCTYPE');
}
XML-Twig-3.50/t/test_keep_atts_order.t 0000755 0001750 0001750 00000004564 12346001775 020135 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
{
if( eval 'require Tie::IxHash')
{ import Tie::IxHash;
print "1..7\n";
}
else
{ warn( "Tie::IxHash not available, option keep_atts_order not allowed\n");
print "1..1\nok 1\n";
exit 0;
}
my $nb_elt=10;
my $doc= gen_doc( $nb_elt);
my $result= XML::Twig->new( pretty_print => 'indented')->parse( $doc)->sprint;
isnt( $result, $doc, "keep_atts_order => 0 (first try)");
$result= XML::Twig->new( keep_atts_order => 1, pretty_print => 'indented')->parse( $doc)->sprint;
is( $result, $doc, "keep_atts_order => 1 (first try)");
$result= XML::Twig->new( pretty_print => 'indented')->parse( $doc)->sprint;
isnt( $result, $doc, "keep_atts_order => 0 (second try)");
$result= XML::Twig->new( keep_atts_order => 1, pretty_print => 'indented')->parse( $doc)->sprint;
is( $result, $doc, "keep_atts_order => 1 (second try)");
$result= XML::Twig->new( keep_atts_order => 1, keep_encoding => 1, pretty_print => 'indented')
->parse( $doc)->sprint;
is( $result, $doc, "keep_atts_order => 1, keep_encoding => 1 (first time)");
$result= XML::Twig->new( keep_encoding => 1, pretty_print => 'indented');
$result= XML::Twig->new( keep_atts_order => 1, keep_encoding => 1, pretty_print => 'indented')
->parse( $doc)->sprint;
is( $result, $doc, "keep_atts_order => 1, keep_encoding => 1 (second time)");
$result= XML::Twig->new( keep_encoding => 1, pretty_print => 'indented')
->parse( $doc)->sprint;
isnt( $result, $doc, " keep_encoding => 1 (second time)");
};
exit 0;
sub gen_doc
{ my( $nb_elt)= @_;
my $doc= "\n";
foreach (1..$nb_elt)
{ $doc .= " $_ + 1 } (0..4) ;
while( my( $att, $value)= each %atts)
{ $doc .= qq{ $att="$value"}; }
$doc .= "/>\n";
}
$doc .= "\n";
return $doc;
}
sub randomize
{ my @list= @_;
my $n= @list;
foreach (1..10)
{ my $i= int rand( $n);
my $j= int rand( $n);
($list[$i], $list[$j])=($list[$j], $list[$i])
}
return @list;
}
XML-Twig-3.50/t/xmlxpath_test_twig_roots.t 0000755 0001750 0001750 00000017600 12346001774 021102 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
#use diagnostics;
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
my $DEBUG=0;
print "1..12\n";
$|=1;
$/= "\n\n";
my $t= XML::Twig::XPath->new( twig_roots => { },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 1);
$t= XML::Twig::XPath->new( twig_roots => { elt2 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 2);
$t= XML::Twig::XPath->new( twig_roots => { elt3 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 3);
$t= XML::Twig::XPath->new( twig_roots => { },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 4);
$t= XML::Twig::XPath->new( twig_roots => { elt2 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 5);
$t= XML::Twig::XPath->new( twig_roots => { elt3 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 6);
$t= XML::Twig::XPath->new( twig_roots => { },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 7);
$t= XML::Twig::XPath->new( twig_roots => { elt2 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 8);
$t= XML::Twig::XPath->new( twig_roots => { elt3 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 9);
$t= XML::Twig::XPath->new( twig_roots => { elt => sub { print RESULT "elt handler called on ", $_->gi, "\n"; }, },
start_tag_handlers => { doc => sub { print RESULT "start tag handler called on ", $_->gi, "\n"; }, },
end_tag_handlers => { doc => sub { print RESULT "end tag handler called on $_[1]\n"; }, },
);
test_twig( $t, 10);
# test with doc root as root
$t= XML::Twig::XPath->new( twig_roots => { doc => sub { $_->print( \*RESULT); } });
test_twig( $t, 11);
# test with elt as root
$t= XML::Twig::XPath->new( twig_roots => { elt => sub { $_->print( \*RESULT); } });
test_twig( $t, 12);
exit 0;
sub test_twig
{ my( $t, $test_nb)= @_;
my $doc= read_doc();
my $expected_result= read_expected_result();
my $result_file= "test_twig_roots.res1";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t->parse( $doc);
check_result( $result_file, $test_nb, $expected_result);
close RESULT;
}
sub check_result
{ my( $result_file, $test_no, $expected_result)= @_;
# now check result
my $result= read_result( $result_file);
if( $result eq $expected_result)
{ print "ok $test_no\n"; }
else
{ print "nok $test_no\n";
print STDERR "\ntest $test_no:\n",
"expected: \n$expected_result\n",
"real: \n$result\n";
}
}
{ my $last_doc;
my $buffered_result;
sub read_doc
{ local $/="\n\n";
my $doc= ;
# if the data starts with #doc then it's a doc, otherwise use the previous one
if( $doc=~ /^\s*#\s*doc/)
{ $doc= clean_data( $doc);
$last_doc= $doc;
$buffered_result='';
return $doc;
}
else
{ $buffered_result= clean_data( $doc);
return $last_doc;
}
}
sub read_expected_result
{ if( $buffered_result)
{ return $buffered_result; }
else
{ local $/="\n\n";
my $expected_result= ;
$expected_result= clean_data( $expected_result);
return $expected_result;
}
}
}
sub clean_data
{ my $data= shift;
$data=~ s{^\s*#.*\n}{}m; # get rid of comments
$data=~ s{\s*$}{}s; # remove trailing spaces (and \n)
$data=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
return $data;
}
sub read_result
{ my $file= shift;
local $/="\n";
open( RESULT, "<$file") or die "cannot read $file: $!";
my @result= grep {m/\S/} ;
my $result= join( '', @result);
$result=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
close RESULT;
unlink $file;
return $result;
}
__DATA__
# doc 1
text subelt textanother elt textan other type of element text of subelt
# expected_res 1
text subelt textanother elt textan other type of element text of subelt
# expected_res 2
text subelt textanother elt text text of subelt
# expected_res 3
text subelt textanother elt textan other type of element
# doc 2
text subelt textanother elt textan other type of element text of subelt
# expected_res 4
text subelt textanother elt textan other type of element text of subelt
# expected_res 5
text subelt textanother elt text text of subelt
# expected_res 6
text subelt textanother elt textan other type of element
# doc 3
text subelt textanother elt textan other type of element text of subelt
# expected_res 7
text subelt textanother elt textan other type of element text of subelt
# expected_res 8
text subelt textanother elt text text of subelt
# expected_res 9
text subelt textanother elt textan other type of element
# doc 4
# expected_res 10
start tag handler called on doc
elt handler called on elt
end tag handler called on doc
# expected_res 11
# expected_res 12
XML-Twig-3.50/t/test1.t 0000755 0001750 0001750 00000027151 12346001774 014760 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,'t');
use tools;
# This just tests a complete twig, no callbacks
$|=1;
use XML::Twig;
my $doc='
]>
S1 I1S1 I2S1 TitleS1 P1S2 P2Note P1S1 para 3S2 introS2 TitleS2 P1S2 P2S2 P3Annex TitleAnnex P1Annex P2';
my $TMAX=97; # don't forget to update!
print "1..$TMAX\n";
# test twig creation
my $t= new XML::Twig();
ok( $t, 'twig creation');
# test parse
$t->parse( $doc, ErrorContext=>2);
ok( $t, 'parse');
# test the root
my $root= $t->root;
etest( $t->root, 'doc', 'doc1', 'root');
# print in a file
open( TMP, '>tmp');
select TMP;
$t->print();
$root->print();
select STDOUT;
$t->print( \*TMP);
$root->print( \*TMP);
ok( 'ok', "print");
# test the element root and twig functions on the root
ok( $root->twig, 'root->twig');
etest( $root->root,
'doc', 'doc1', 'root->root');
# navigation
my $section1=
etest( $root->first_child,
'section', 'section1', 'first_child');
my $annex=
etest( $root->first_child( 'annex'),
'annex', 'annex1', 'first_child( annex)');
etest( $root->last_child,
'annex', 'annex1', 'last_child');
my $section2=
etest( $root->last_child( 'section'),
'section', 'section2', 'last_child( section)');
etest( $section2->prev_sibling,
'section', 'section1', 'prev_sibling');
etest( $section1->next_sibling,
'section', 'section2', 'next_sibling');
my $note=
etest( $root->next_elt( 'note'),
'note', 'note1', 'next_elt( note)');
etest( $note->root,
'doc', 'doc1', 'root');
ok( $note->twig, 'twig');
etest( $note->twig->root,
'doc', 'doc1', 'twig->root');
# playing with next_elt and prev_elt
my $para2=
etest( $note->prev_sibling,
'para', 'para2', 'prev_sibling');
etest( $note->prev_elt( 'para'),
'para', 'para2', 'prev_elt( para)');
my $para3=
etest( $note->next_sibling,
'para', 'para3', 'next_sibling');
my $paranote1=
etest( $note->next_elt( 'para'),
'para', 'paranote1', 'next_elt( para)');
etest( $paranote1->next_elt( 'para'),
'para', 'para3', 'next_elt( para)');
# difference between next_sibling and next_sibling( gi)
etest( $para2->next_sibling,
'note', 'note1', 'next_sibling');
etest( $para2->next_sibling( 'para'),
'para', 'para3', 'next_sibling( para)');
# testing in/parent/in_context
ok( $paranote1->in( $note), 'in');
ok( $paranote1->in( $section1), 'in');
ok( !$paranote1->in( $section2), 'not in');
ok( $paranote1->in_context( 'note'), 'in_context');
ok( $paranote1->in_context( 'section'), 'in_context');
ok( !$paranote1->in_context( 'intro'), 'not in_context');
etest( $paranote1->parent,
'note', 'note1', 'parent');
# testing list methods (ancestors/children)
stest( (join ":", map { $_->id} $paranote1->ancestors),
'note1:section1:doc1', 'ancestors');
stest( (join ":", map { $_->id} $paranote1->ancestors('section')),
'section1', 'ancestors( section)');
stest( (join ":", map { $_->id} $section1->children),
'intro1:title1:para1:para2:note1:para3', 'children');
stest( (join ":", map { $_->id} $section1->children( 'para')),
'para1:para2:para3', 'children( para)');
stest( $paranote1->level, 3, 'level');
# testing attributes
my $title1=
etest( $root->next_elt( 'title'),
'title', 'title1', 'next_elt( title)');
stest( $title1->id, 'title1', 'id');
stest( $title1->att('id'), 'title1', 'att( id)');
stest( $title1->att('no'), '1', 'att( no)');
$title1->set_att('no', 'Auto');
stest( $title1->att('no'), 'Auto', 'set att( no)');
$title1->set_att('no', '1');
$title1->set_att('newatt', 'newval');
stest( $title1->att('newatt'), 'newval', 'set att( newval)');
$title1->del_att('newatt');
stest( stringifyh( %{$title1->atts}), 'id:title1:no:1', 'del_att');
$title1->set_att('id', 'newid');
stest( $title1->id, 'newid', 'set_att(id)');
stest( $title1->att( 'id'), 'newid', 'set_att(id)');
$title1->set_id( 'title1');
stest( $title1->id, 'title1', 'set_id');
stest( $title1->att( 'id'), 'title1', 'set_id');
stest( stringifyh( %{$title1->atts}), 'id:title1:no:1', 'atts');
$title1->del_atts;
stest( $title1->att( 'id'), '', 'del_atts');
$title1->set_atts( { 'no' => '1', 'id' => 'newtitleid'});
stest( stringifyh( %{$title1->atts}), 'id:newtitleid:no:1', 'set_atts');
stest( $title1->id, 'newtitleid', 'id');
stest( $title1->att('id'), 'newtitleid', 'att( id)');
$title1->set_id( 'title1');
# now let's cut and paste
$title1->cut;
stest( (join ":", map { $_->id} $section1->children),
'intro1:para1:para2:note1:para3', 'cut (1)');
my $intro1= $section1->first_child( 'intro');
$intro1->cut;
stest( (join ":", map { $_->id} $section1->children),
'para1:para2:note1:para3', 'cut (2)');
$intro1->paste( $section1);
stest( (join ":", map { $_->id} $section1->children),
'intro1:para1:para2:note1:para3', 'paste');
$title1->paste( 'first_child', $section2, );
stest( (join ":", map { $_->id} $section2->children),
'title1:intro2:title2:para4:para5:para6', 'paste( first_child)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'paste');
$title1->paste( $section2);
stest( (join ":", map { $_->id} $section2->children),
'title1:intro2:title2:para4:para5:para6', 'paste');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (3)');
$title1->paste( 'last_child', $section2);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6:title1', 'paste( last_child)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut(4)');
my $intro2=
etest( $section2->first_child( 'intro'),
'intro', 'intro2', 'first_sibling( intro)');
$title1->paste( 'after', $intro2);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title1:title2:para4:para5:para6', 'paste( after)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (5)');
$title1->paste( 'before', $intro2);
stest( (join ":", map { $_->id} $section2->children),
'title1:intro2:title2:para4:para5:para6', 'paste( before)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (6)');
my $para4= etest( $t->elt_id( 'para4'), 'para', 'para4', 'elt_id');
$title1->paste( 'after', $para4);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:title1:para5:para6', 'paste( after)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (7)');
$title1->paste( 'before', $para4);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:title1:para4:para5:para6', 'paste( before)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (8)');
# now let's mess up the document
# let's erase that pesky intro
$intro2->erase;
stest( (join ":", map { $_->id} $section2->children),
'paraintro3:title2:para4:para5:para6', 'erase');
$para4->delete;
stest( (join ":", map { $_->id} $section2->children),
'paraintro3:title2:para5:para6', 'delete');
$t->change_gi( 'paraintro', 'para');
stest( (join ":", map { $_->gi} $section2->children),
'para:title:para:para', 'change_gi');
$para3= etest( $t->elt_id( 'para3'), 'para', 'para3', 'elt_id');
$para3->cut;
stest( $section1->text, 'S1 I1S1 I2S1 P1S2 P2Note P1', 'text');
stest( $section1->sprint,
'S1 I1S1 I2S1 P1S2 P2Note P1',
'sprint');
# let's have a look at those entities
# first their names
stest( join( ':', $t->entity_names), 'e1:e2:e3', 'entity_list');
# let's look at their content
my $e1= $t->entity( 'e1');
stest( $e1->text, '', 'e1 text');
my $e2= $t->entity( 'e2');
stest( $e2->text, '', 'e2 text');
my $e3= $t->entity( 'e3');
stest( $e3->text, '', 'e3 text');
# additionnal erase test
$section1= $root->first_child;
stest( (join ":", map { $_->id} $section1->children),
'intro1:para1:para2:note1', 'erase (2)');
$intro1= $section1->first_child( 'intro');
$intro1->erase;
stest( (join ":", map { $_->id} $section1->children),
'paraintro1:paraintro2:para1:para2:note1', 'erase (3)');
# new elt test
my $new_elt= new XML::Twig::Elt;
stest( ref $new_elt, 'XML::Twig::Elt', "new");
my $new_elt1= new XML::Twig::Elt( 'subclass');
stest( ref $new_elt, 'XML::Twig::Elt', "new subclass");
my $new_elt2= new XML::Twig::Elt;
stest( ref $new_elt2, 'XML::Twig::Elt', "create no gi");
my $new_elt3= new XML::Twig::Elt( 'elt3');
$new_elt3->set_id( 'elt3');
etest( $new_elt3, 'elt3', 'elt3', "create with gi");
my $new_elt4= new XML::Twig::Elt( 'elt4', 'text of elt4');
ttest( $new_elt4, 'text of elt4', "create with gi and text");
my $new_elt5= new XML::Twig::Elt( 'elt5', 'text of elt5 ', $new_elt4);
ttest( $new_elt5, 'text of elt5 text of elt4', "create with gi and content");
my $new_elt6= new XML::Twig::Elt( PCDATA, 'text of elt6');
ttest( $new_elt6, 'text of elt6', "create PCDATA");
# test CDATA
my $st1='bold]]>';
my $t1= new XML::Twig;
$t1->parse( $st1);
sttest( $t1->root, $st1, "CDATA Section");
my $st2='text bold]]> more text';
my $t2= new XML::Twig;
$t2->parse( $st2);
sttest( $t2->root, $st2, "CDATA Section");
my $st3='bold]]> text';
my $t3= new XML::Twig;
$t3->parse( $st3);
sttest( $t3->root, $st3, "CDATA Section");
my $st4='textbold]]>more text';
my $t4= new XML::Twig;
$t4->parse( $st4);
sttest( $t4->root, $st4, "CDATA Section");
my $st5='text more text';
my $t5= new XML::Twig;
$t5->parse( $st5);
sttest( $t5->root, $st5, "CDATA Section with ]]<");
# test prefix
my $st6='textmore text';
my $t6= new XML::Twig;
$t6->parse( $st6);
$doc= $t6->root;
$doc->prefix( 'p1:');
sttest( $t6->root,'p1:textmore text',
"prefix doc");
my $el1= $doc->first_child( 'el1');
$el1->prefix( 'p2:');
sttest( $t6->root,'p1:p2:textmore text',
"prefix el1");
my $el2= $doc->first_child( 'el2');
my $pcdata= $el2->first_child( PCDATA);
$pcdata->prefix( 'p3:');
sttest( $t6->root,'p1:p2:textp3:more text',
"prefix pcdata");
exit 0;
__END__
XML-Twig-3.50/t/test_new_features_3_22.xml 0000644 0001750 0001750 00000000014 12346001775 020513 0 ustar mrodrigu mrodrigu
XML-Twig-3.50/t/xmlxpath_tools.pm 0000644 0001750 0001750 00000000571 12346001775 017151 0 ustar mrodrigu mrodrigu use strict;
use Config;
BEGIN
{ if( eval( 'require XML::Twig::XPath'))
{ import XML::Twig::XPath; }
elsif( $@ =~ m{^cannot use XML::Twig::XPath})
{ print "1..1\nok 1\n"; $@=~s{ at.*}{}s; warn "$@\n";
exit;
}
else
{ die $@; }
}
1;
__END__
=head1 SYNOPSYS
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
XML-Twig-3.50/t/zz_dump_config.t 0000755 0001750 0001750 00000006712 12346001775 016736 0 ustar mrodrigu mrodrigu #!/usr/bin/perl
my $ok; # global, true if the last call to version found the module, false otherwise
use Config;
warn "\n\nConfiguration:\n\n";
# required
warn "perl: $]\n";
warn "OS: $Config{'osname'} - $Config{'myarchname'}\n";
print "\n";
warn "required\n";
warn version( XML::Parser, '');
# We obviously have expat on VMS, but a symbol/logical might
# not be set to xmlwf, and when this is the case a
# '%DCL-W-IVVERB, unrecognized command verb - check validity and spelling
# \XMLWF\'
# will be returned.
my $skip_xmlwf_test = 0;
if ($^O eq 'VMS') {
if(`write sys\$output "''xmlwf'"` !~ m/[a-z]+/i) {
$skip_xmlwf_test = 1;
warn format_warn( 'expat', "Skipping expat (version) test as don't have a symbol for 'xmlwf'.");
}
}
if (! $skip_xmlwf_test)
{ # try getting this info
my $xmlwf_v= `xmlwf -v`;
if( $xmlwf_v=~ m{xmlwf using expat_(.*)$}m)
{ warn format_warn( 'expat', $1, '(required)'); }
else
{ warn format_warn( 'expat', ''); }
}
print "\n";
# must-have
warn "Strongly Recommended\n";
warn version( Scalar::Util, 'for improved memory management');
if( $ok)
{ unless( defined( &Scalar::Util::weaken))
{ warn format_warn( '', 'NOT USED, weaken not available in this version');
warn version( WeakRef);
}
}
else
{ warn version( WeakRef, 'for improved memory management'); }
# encoding
warn version( Encode, 'for encoding conversions');
unless( $ok) { warn version( Text::Iconv, 'for encoding conversions'); }
unless( $ok) { warn version( Unicode::Map8, 'for encoding conversions'); }
print "\n";
# optional
warn "Modules providing additional features\n";
warn version( XML::XPathEngine, 'to use XML::Twig::XPath');
warn version( XML::XPath, 'to use XML::Twig::XPath if Tree::XPathEngine not available');
warn version( LWP, 'for the parseurl method');
warn version( HTML::TreeBuilder, 'to use parse_html and parsefile_html');
warn version( HTML::Entities::Numbered, 'to allow parsing of HTML containing named entities');
warn version( HTML::Tidy, 'to use parse_html and parsefile_html with the use_tidy option');
warn version( HTML::Entities, 'for the html_encode filter');
warn version( Tie::IxHash, 'for the keep_atts_order option');
warn version( Text::Wrap, 'to use the "wrapped" option for pretty_print');
print "\n";
# used in tests
warn "Modules used only by the auto tests\n";
warn version( Test, '');
warn version( Test::Pod, '');
warn version( XML::Simple, '');
warn version( XML::Handler::YAWriter, '');
warn version( XML::SAX::Writer, '');
warn version( XML::Filter::BufferText, '');
warn version( IO::Scalar, '');
warn version( IO::CaptureOutput, '');
my $zz_dump_config= File::Spec->catfile( t => "zz_dump_config.t");
warn "\n\nPlease add this information to bug reports (you can run $zz_dump_config to get it)\n\n";
warn "if you are upgrading the module from a previous version, make sure you read the\n",
"Changes file for bug fixes, new features and the occasional COMPATIBILITY WARNING\n\n";
print "1..1\nok 1\n";
exit 0;
sub version
{ my $module= shift;
my $info= shift || '';
$info &&= "($info)";
my $version;
if( eval "require $module")
{ $ok=1;
import $module;
$version= ${"$module\::VERSION"};
$version=~ s{\s*$}{};
}
else
{ $ok=0;
$version= '';
}
return format_warn( $module, $version, $info);
}
sub format_warn
{ return sprintf( " %-25s: %16s %s\n", @_); }
XML-Twig-3.50/t/test_bugs_3_21.t 0000755 0001750 0001750 00000010466 12346001775 016445 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
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 $TMAX=25;
print "1..$TMAX\n";
{ # testing creation of elements in the proper class
package foo; use base 'XML::Twig::Elt'; package main;
my $t= XML::Twig->new( elt_class => "foo")->parse( '');
my $elt= $t->first_elt( 'elt');
$elt->set_text( 'bar');
is( $elt->first_child->text, 'bar', "content of element created with set_text");
is( ref( $elt->first_child), 'foo', "class of element created with set_text");
$elt->set_content( 'baz');
is( $elt->first_child->text, 'baz', "content of element created with set_content");
is( ref( $elt->first_child), 'foo', "class of element created with set_content");
$elt->insert( 'toto');
is( $elt->first_child->tag, 'toto', "tag of element created with set_content");
is( ref( $elt->first_child), 'foo', "class of element created with insert");
$elt->insert_new_elt( first_child => 'tata');
is( $elt->first_child->tag, 'tata', "tag of element created with insert_new_elt");
is( ref( $elt->first_child), 'foo', "class of element created with insert");
$elt->wrap_in( 'tutu');
is( $t->root->first_child->tag, 'tutu', "tag of element created with wrap_in");
is( ref( $t->root->first_child), 'foo', "class of element created with wrap_in");
$elt->prefix( 'titi');
is( $elt->first_child->text, 'titi', "content of element created with prefix");
is( ref( $elt->first_child), 'foo', "class of element created with prefix");
$elt->suffix( 'foobar');
is( $elt->last_child->text, 'foobar', "content of element created with suffix");
is( ref( $elt->last_child), 'foo', "class of element created with suffix");
$elt->last_child->split_at( 3);
is( $elt->last_child->text, 'bar', "content of element created with split_at");
is( ref( $elt->last_child), 'foo', "class of element created with split_at");
is( ref( $elt->copy), 'foo', "class of element created with copy");
$t= XML::Twig->new( elt_class => "foo")->parse( 'toto');
$t->root->subs_text( qr{(to)} => '&elt( p => $1)');
is( $t->sprint, '
to
to
', "subs_text result");
my $result= join( '-', map { join( ":", ref($_), $_->tag) } $t->root->descendants);
is( $result, "foo:p-foo:#PCDATA-foo:p-foo:#PCDATA", "subs_text classes and tags");
}
{ # wrap children with > in attribute
my $doc=q{};
my $result =XML::Twig->new->parse( $doc)->root->wrap_children( '+', "w")->strip_att( 'id')->sprint;
my $expected = q{};
is( $result => $expected, "wrap_children with > in attributes");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '+', "w")->strip_att( 'id')->sprint;
$expected = q{};
is( $result => $expected, "wrap_children with > in attributes, > in condition");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '+', "w")->strip_att( 'id')->sprint;
$expected = q{};
is( $result => $expected, "wrap_children with > in attributes un-escaped > in condition");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '+', "w")->strip_att( 'id')->sprint;
$expected = q{};
is( $result => $expected, "wrap_children with > in attributes, 2 atts in condition");
$result =XML::Twig->new->parse( $doc)->root->wrap_children( '+', "w")->strip_att( 'id')->sprint;
$expected = q{};
is( $result => $expected, "wrap_children with > in attributes, 2 atts in condition (no child matches)");
}
{ # test improvements to wrap_children
my $doc= q{okNOK};
my $expected= q{okNOK};
my $t= XML::Twig->new->parse( $doc);
$t->root->wrap_children( '+', w => { a => "&" });
$t->root->strip_att( 'id');
is( $t->sprint, $expected, "wrap_children with &");
}
XML-Twig-3.50/t/test_drop_comments.t 0000755 0001750 0001750 00000001741 12346001774 017625 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
print "1..3\n";
my $xml = <value
XML_TEST
{
my $twig1 = XML::Twig->new(comments => 'keep', keep_spaces => 1);
$twig1->parse($xml);
ok ($twig1->sprint() =~ //s, 'keep comments');
#print $twig1->sprint, "\n", '-'x80, "\n"; # keeps comments ok
$twig1->dispose;
}
{
my $twig2 = XML::Twig->new(comments => 'drop', keep_spaces => 1);
$twig2->parse($xml);
ok ($twig2->sprint() !~ //s, 'drop comments');
#print $twig2->sprint, "\n", '-'x80, "\n"; # drops comments ok
$twig2->dispose;
}
{
my $twig3 = XML::Twig->new(comments => 'keep', keep_spaces => 1);
$twig3->parse($xml);
ok ($twig3->sprint() =~ //s, 'keep comments');
#print $twig3->sprint, "\n", '-'x80, "\n"; # drops comments!!
$twig3->dispose;
}
exit 0;
XML-Twig-3.50/t/xmlxpath_test_with_handlers.t 0000755 0001750 0001750 00000003547 12346001774 021542 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 7);
use XML::Twig::XPath;
$|=1;
my $doc=
'elt 1elt 2elt 3232323in_elt6-1in_elt7-1in_elt7-2
<:elt id=":elt">yep, that is a valid name
'
;
my $t= XML::Twig::XPath->new( twig_handlers =>
{ elt5 => sub { my @res1= $_->findnodes( './elt3/elt4[@att_int="3"] | elt3');
ok( ids( @res1), "elt3-1 - elt4-2 - elt3-2 - elt4-4"); # 1
ok( $_->field( 'elt7[@id="elt7-2"]'), "in_elt7-2"); # 2
ok( $_->findvalue( 'elt7[@id="elt7-2"]'), "in_elt7-2"); # 3
ok( $_->findvalue( 'elt7[preceding-sibling::*[1][self::elt6]]'), "in_elt7-1"); # 4
ok( $_->findvalue( 'elt7[preceding-sibling::elt6]'), "in_elt7-1in_elt7-2"); # 5
ok( $_->findvalue( "elt7"), "in_elt7-1in_elt7-2"); # 6
},
},
);
$t->parse( $doc);
ok( ids( $t->findnodes( '//elt3/elt4[@att_int="3"] | //elt3') ), "elt3-1 - elt4-2 - elt3-2 - elt4-4"); # 7
exit 0;
sub ids
{ return join( " - ", map { $_->id } @_); }
XML-Twig-3.50/t/test2_2.xml 0000644 0001750 0001750 00000001736 12346001774 015535 0 ustar mrodrigu mrodrigu
]>
S1 I1S1 I2S1 TitleS1 P1S2 P2Note P1S1 para 3S2 introS2 TitleS2 P1S2 P2S2 P3Annex TitleAnnex P1Annex P2
XML-Twig-3.50/t/test_3_26.t 0000755 0001750 0001750 00000013012 12346001775 015420 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
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 $DECL=qq{\n};
$DECL='';
my $TMAX=18;
print "1..$TMAX\n";
{ # testing set_inner_xml
my $doc= 'with content
toto
';
my $t= XML::Twig->nparse( $doc);
my $inner= '
foo
duh';
$t->first_elt( 'elt')->set_inner_xml( $inner);
(my $expected= $doc)=~ s{}{$inner};
is( $t->sprint, $expected, "set_inner_xml");
$t->first_elt( 'elt2')->set_inner_xml( $inner);
$expected=~ s{.*}{$inner};
is( $t->sprint, $expected, "set_inner_xml (of an elt with content)");
}
{ # testing set_inner_html
if( !XML::Twig::_use( 'HTML::TreeBuilder', 3.13))
{ skip( 4 => "need HTML::TreeBuilder 3.13+ to use set_inner_html method");
}
elsif( !XML::Twig::_use( 'LWP'))
{ skip( 4 => "need LWP to use set_inner_html method");
}
else
{
my $doc= 'a titlepar 1
par 2 after the break';
my $t= XML::Twig->nparse( $doc);
my $inner= '
', 'merged p with extra data');
}
{ my $t= XML::Twig->parse( '
foo
bazbar
');
my $r= $t->root;
is( $r->children_count, 2, '2 p, one with mixed content');
$t->root->first_child->merge( $t->root->last_child);
is( $r->children_count, 1, 'merged p, one with mixed content');
is( $t->sprint, '
foobazbar
', 'merged p with extra children in the second element');
}
{ my $t= XML::Twig->parse( '');
my $r= $t->root;
$r->insert_new_elt( first_child => '#PCDATA') foreach 0..1;
is( $r->children_count, 2, '2 empty texts');
$r->first_child->merge( $r->last_child);
is( $r->children_count, 1, 'merged empty texts, number of children');
is( $t->sprint, '', 'merged empty texts');
}
{ my $t= XML::Twig->parse( 'a foo afoobar');
my $c=$t->root->copy->subs_text( qr/(foo)/, '&elt( e => "$1")');
is( $c->sprint, 'a foo afoobar', 'subs_text');
$c=$t->root->copy->subs_text( qr/(foo)/, 'X &elt( e => "$1") X');
is( $c->sprint, 'a X foo X aX foo Xbar', 'subs_text');
$c=$t->root->copy->subs_text( qr/(foo)/, 'X &elt( e => "Y $1 Y") X');
is( $c->sprint, 'a X Y foo Y X aX Y foo Y Xbar', 'subs_text');
$c->subs_text( qr/(foo)/, 'X &elt( e => "Y $1 Y") X');
is( $c->sprint, 'a X Y X Y foo Y X Y X aX Y X Y foo Y X Y Xbar', 'subs_text (re-using previous substitution)');
}
{ my $e= XML::Twig::Elt->new( 'e');
is( $e->att_nb, 0, 'att_nb on element with no attributes');
ok( $e->has_no_atts, 'has_no_atts on element with no attributes');
my $e2= XML::Twig::Elt->new( e => { a => 1 })->del_att( 'a');;
is( $e->att_nb, 0, 'att_nb on element with no more attributes');
ok( $e->has_no_atts, 'has_no_atts on element with no more attributes');
is( $e->split_at( 1), '', 'split_at on a non text element');
}
SKIP: {
skip 'XML::XPath not available', 1 unless XML::Twig::_use( 'XML::XPath');
XML::Twig::_disallow_use( 'XML::XPathEngine');
XML::Twig::_use( 'XML::Twig::XPath');
my $t= XML::Twig::XPath->parse( 'e1e2e3');
is( $t->findvalue( '//e[@a>=3]|//e[@a<=1]'), 'e1e3', 'xpath search with XML::XPath');
}
SKIP: { # various tests on _fix_xml
skip 'HTML::TreeBuilder not available', 2 unless XML::Twig::_use( 'HTML::TreeBuilder');
my $html= '
&Amp;
';
my $t= HTML::TreeBuilder->new_from_content( $html);
local $@='not well-formed (invalid token)';
local $HTML::TreeBuilder::VERSION=3.23;
XML::Twig::_fix_xml( $t, \$html);
unlike( $html, qr{Amp}, '&Amp with old versions of HTML::TreeBuilder');
like( $html, qr{
parse( 'pre1e1pre2a 1');
is( $t->findvalue( '/d/*[local-name()="e"]'), 'pre1e1pre2', 'local-name()');
}
{ my $doc= qq{\n\n};
(my $expected= $doc)=~ s{("default">)\n}{$1}; # this space should be discarded
my $t= XML::Twig->parse( $doc);
is( $t->sprint, $expected, 'xml:space effect on whitespace discarding');
}
{ my $d= "";
my $got=0;
my $t= XML::Twig->new( start_tag_handlers => { e => sub { $got=1; } } );
$t->parse( $d);
is( $got, 1, 'setStartTagHandlers');
$t->setStartTagHandlers( { e => sub { $got=2; } });
$t->parse( $d);
is( $got, 2, 'setStartTagHandlers changed');
}
{ my $d= "";
my $got=0;
my $st;
my $t= XML::Twig->new( start_tag_handlers => { se => sub { $got=1; } },
ignore_elts => { e => \$st },
);
$t->parse( $d);
is( $got, 0, 'check that ignore_elts skips element');
is( $st, '', 'check that ignore_elts stores the ignored content');
$st='';
$t->setIgnoreEltsHandler( e => 'discard');
is( $got, 0, 'check that ignore_elts still skips element');
is( $st, '', 'check that ignore_elts now discards the ignored content');
}
{ my $content= '
';
is( XML::Twig::Elt->new( $content)->sprint, $content, 'XML::Twig::Elt->new with litteral content');
}
{ my $doc= '';
my $doc_no_pi= '';
my $t= XML::Twig->parse( $doc);
is( $t->sprint, $doc, 'pi is keep by default');
my $tk= XML::Twig->parse( pi => 'keep', $doc);
is( $tk->sprint, $doc, 'pi is keep');
my $td= XML::Twig->parse( pi => 'drop', $doc);
is( $td->sprint, $doc_no_pi, 'pi is keep');
my $tp= XML::Twig->parse( pi => 'process', $doc);
is( $tp->sprint, $doc, 'pi is process');
foreach my $pi ($t->descendants( '#PI')) { $pi->delete; }
is( $t->sprint, $doc, 'pi cannot be cut when pi => keep (by default)');
foreach my $pi ($tk->descendants( '#PI')) { $pi->delete; }
is( $tk->sprint, $doc, 'pi cannot be cut when pi => keep');
foreach my $pi ($tp->descendants( '#PI')) { $pi->delete; }
is( $tp->sprint, $doc_no_pi, 'pi can be cut when pi => process');
}
{ my $doc= '';
my $doc_no_comment= '';
my $t= XML::Twig->parse( $doc);
is( $t->sprint, $doc, 'comments is keep by default');
my $tk= XML::Twig->parse( comments => 'keep', $doc);
is( $tk->sprint, $doc, 'comments is keep');
my $td= XML::Twig->parse( comments => 'drop', $doc);
is( $td->sprint, $doc_no_comment, 'comments is keep');
my $tp= XML::Twig->parse( comments => 'process', $doc);
is( $tp->sprint, $doc, 'comments is process');
foreach my $comment ($t->descendants( '#COMMENT')) { $comment->delete; }
is( $t->sprint, $doc, 'comment cannot be cut when comment => keep (by default)');
foreach my $comment ($tk->descendants( '#COMMENT')) { $comment->delete; }
is( $tk->sprint, $doc, 'comment cannot be cut when comment => keep');
foreach my $comment ($tp->descendants( '#COMMENT')) { $comment->delete; }
is( $tp->sprint, $doc_no_comment, 'comment can be cut when comment => process');
}
{ my $d='t1t2
p
';
my $t= XML::Twig->parse( $d);
my $p= $t->elt_id( 't');
is( $p->level, 3, 'level');
is( $p->level( 's'), 2, 'level with cond');
is( $p->level( 's[@l]'), 2, 'level with cond on attr');
is( $p->level( 's[@l="2"]'), 1, 'level with more cond on attr');
is( $p->level( 's[@g]'), 0, 'level with unsatisfied more cond on attr');
}
{ my $d='e1e2e3e4e5f1f1f2';
my $r;
my $t;
$t= XML::Twig->parse( twig_handlers => { 'e#i' => sub { $r.= $_->text}}, $d);
is( $r, 'e1', '# in twig handlers (1 letter id)');
is( $t->findvalue( '//e#i'), 'e1', 'findvalue with # (1 letter id)');
$r='';
$t= XML::Twig->parse( twig_handlers => { 'e#iii' => sub { $r.= $_->text}}, $d);
is( $r, 'e5', '# in twig handlers (3 letter id)');
is( $t->findvalue( '//e#iii'), 'e5', 'findvalue with # (3 letter id)');
$r='';
$t= XML::Twig->parse( twig_handlers => { 'e#i2' => sub { $r.= $_->text}}, $d);
is( $r, 'e2', '# in twig handlers (letter + digits)');
is( $t->findvalue( '//e#i2'), 'e2', 'findvalue with # (letter + digits)');
$r='';
$t= XML::Twig->parse( twig_handlers => { '*#ff' => sub { $r.= $_->text}}, $d);
is( $r, 'f1', '*# in twig handlers');
is( $t->findvalue( '//*#ff'), 'f1', 'findvalue with *#');
}
XML-Twig-3.50/t/test_expand_external_entities.dtd 0000644 0001750 0001750 00000000153 12346001774 022342 0 ustar mrodrigu mrodrigu
ent2 text">
XML-Twig-3.50/t/test2_2.exp 0000644 0001750 0001750 00000002321 12346001774 015520 0 ustar mrodrigu mrodrigu
]>
S1 I1S1 I2S1 TitleS1 P1S2 P2Note P1S1 para 3S2 introS2 TitleS2 P1S2 P2S2 P3Annex TitleAnnex P1Annex P2
XML-Twig-3.50/t/xmlxpath_test1.t 0000755 0001750 0001750 00000032147 12346001775 016707 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
my $DEBUG=0;
print "1..114\n";
# This just tests a complete twig, no callbacks
$|=1;
my $doc='
]>
S1 I1S1 I2S1 TitleS1 P1S2 P2Note P1S1 para 3S2 introS2 TitleS2 P1S2 P2S2 P3Annex TitleAnnex P1Annex P2';
my $i=0;
my $failed=0;
# test twig creation
my $t= XML::Twig::XPath->new;
ok( $t, 'twig creation');
# test parse
$t->parse( $doc, ErrorContext=>2);
ok( $t, 'parse');
ok( ($t->node_cmp( $t->root) == -1), 'cmp twig to root');
ok( ($t->node_cmp( $t) == 0), 'cmp twig to root');
# test the root
my $root= $t->root;
etest( $t->root, 'doc', 'doc1', 'root');
# print in a file
open( TMP, '>tmp');
select TMP;
$t->print();
$root->print();
select STDOUT;
$t->print( \*TMP);
$root->print( \*TMP);
ok( 'ok', "print");
# test the element root and twig functions on the root
ok( $root->twig, 'root->twig');
etest( $root->root,
'doc', 'doc1', 'root->root');
# navigation
my $section1=
etest( $root->first_child,
'section', 'section1', 'first_child');
my $annex=
etest( $root->first_child( 'annex'),
'annex', 'annex1', 'first_child( annex)');
etest( $root->last_child,
'annex', 'annex1', 'last_child');
my $section2=
etest( $root->last_child( 'section'), # 10
'section', 'section2', 'last_child( section)');
etest( $section2->prev_sibling,
'section', 'section1', 'prev_sibling');
etest( $section1->next_sibling,
'section', 'section2', 'next_sibling');
my $note=
etest( $root->next_elt( 'note'),
'note', 'note1', 'next_elt( note)');
etest( $note->root,
'doc', 'doc1', 'root');
ok( $note->twig, 'twig');
etest( $note->twig->root,
'doc', 'doc1', 'twig->root');
# playing with next_elt and prev_elt
my $para2=
etest( $note->prev_sibling,
'para', 'para2', 'prev_sibling');
etest( $note->prev_elt( 'para'),
'para', 'para2', 'prev_elt( para)');
my $para3=
etest( $note->next_sibling,
'para', 'para3', 'next_sibling');
my $paranote1=
etest( $note->next_elt( 'para'), # 20
'para', 'paranote1', 'next_elt( para)');
etest( $paranote1->next_elt( 'para'),
'para', 'para3', 'next_elt( para)');
# difference between next_sibling and next_sibling( gi)
etest( $para2->next_sibling,
'note', 'note1', 'next_sibling');
etest( $para2->next_sibling( 'para'),
'para', 'para3', 'next_sibling( para)');
# testing in/parent/in_context
ok( $paranote1->in( $note), 'in');
ok( $paranote1->in( $section1), 'in');
ok( !$paranote1->in( $section2), 'not in');
ok( $paranote1->in_context( 'note'), 'in_context');
ok( $paranote1->in_context( 'section'), 'in_context');
ok( !$paranote1->in_context( 'intro'), 'not in_context');
etest( $paranote1->parent, # 30
'note', 'note1', 'parent');
# testing list methods (ancestors/children)
stest( (join ":", map { $_->id} $paranote1->ancestors),
'note1:section1:doc1', 'ancestors');
stest( (join ":", map { $_->id} $paranote1->ancestors('section')),
'section1', 'ancestors( section)');
stest( (join ":", map { $_->id} $section1->children),
'intro1:title1:para1:para2:note1:para3', 'children');
stest( (join ":", map { $_->id} $section1->children( 'para')),
'para1:para2:para3', 'children( para)');
stest( $paranote1->level, 3, 'level');
# testing attributes
my $title1=
etest( $root->next_elt( 'title'),
'title', 'title1', 'next_elt( title)');
stest( $title1->id, 'title1', 'id');
stest( $title1->att('id'), 'title1', 'att( id)');
stest( $title1->att('no'), '1', 'att( no)');
$title1->set_att('no', 'Auto');
stest( $title1->att('no'), 'Auto', 'set att( no)');
$title1->set_att('no', '1');
$title1->set_att('newatt', 'newval');
stest( $title1->att('newatt'), 'newval', 'set att( newval)');
$title1->del_att('newatt');
stest( stringifyh( %{$title1->atts}), 'id:title1:no:1', 'del_att');
$title1->set_att('id', 'newid');
stest( $title1->id, 'newid', 'set_att(id)');
stest( $title1->att( 'id'), 'newid', 'set_att(id)');
$title1->set_id( 'title1');
stest( $title1->id, 'title1', 'set_id');
stest( $title1->att( 'id'), 'title1', 'set_id');
stest( stringifyh( %{$title1->atts}), 'id:title1:no:1', 'atts');
$title1->del_atts;
stest( $title1->att( 'id'), '', 'del_atts');
$title1->set_atts( { 'no' => '1', 'id' => 'newtitleid'});
stest( stringifyh( %{$title1->atts}), 'id:newtitleid:no:1', 'set_atts');
stest( $title1->id, 'newtitleid', 'id');
stest( $title1->att('id'), 'newtitleid', 'att( id)');
$title1->set_id( 'title1');
# now cut and paste
$title1->cut;
stest( (join ":", map { $_->id} $section1->children),
'intro1:para1:para2:note1:para3', 'cut (1)');
my $intro1= $section1->first_child( 'intro');
$intro1->cut;
stest( (join ":", map { $_->id} $section1->children),
'para1:para2:note1:para3', 'cut (2)');
$intro1->paste( $section1);
stest( (join ":", map { $_->id} $section1->children),
'intro1:para1:para2:note1:para3', 'paste');
$title1->paste( 'first_child', $section2, );
stest( (join ":", map { $_->id} $section2->children),
'title1:intro2:title2:para4:para5:para6', 'paste( first_child)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'paste');
$title1->paste( $section2);
stest( (join ":", map { $_->id} $section2->children),
'title1:intro2:title2:para4:para5:para6', 'paste');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (3)');
$title1->paste( 'last_child', $section2);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6:title1', 'paste( last_child)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut(4)');
my $intro2=
etest( $section2->first_child( 'intro'),
'intro', 'intro2', 'first_sibling( intro)');
$title1->paste( 'after', $intro2);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title1:title2:para4:para5:para6', 'paste( after)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (5)');
$title1->paste( 'before', $intro2);
stest( (join ":", map { $_->id} $section2->children),
'title1:intro2:title2:para4:para5:para6', 'paste( before)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (6)');
my $para4= etest( $t->elt_id( 'para4'), 'para', 'para4', 'elt_id');
$title1->paste( 'after', $para4);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:title1:para5:para6', 'paste( after)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (7)');
$title1->paste( 'before', $para4);
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:title1:para4:para5:para6', 'paste( before)');
$title1->cut;
stest( (join ":", map { $_->id} $section2->children),
'intro2:title2:para4:para5:para6', 'cut (8)');
# now we mess up the document
# erase that pesky intro
$intro2->erase;
stest( (join ":", map { $_->id} $section2->children),
'paraintro3:title2:para4:para5:para6', 'erase');
$para4->delete;
stest( (join ":", map { $_->id} $section2->children),
'paraintro3:title2:para5:para6', 'delete');
$t->change_gi( 'paraintro', 'para');
stest( (join ":", map { $_->gi} $section2->children),
'para:title:para:para', 'change_gi');
$para3= etest( $t->elt_id( 'para3'), 'para', 'para3', 'elt_id');
$para3->cut;
stest( $section1->text, 'S1 I1S1 I2S1 P1S2 P2Note P1', 'text');
stest( $section1->sprint,
'S1 I1S1 I2S1 P1S2 P2Note P1',
'sprint');
# have a look at those entities
# first their names
stest( join( ':', $t->entity_names), 'e1:e2:e3', 'entity_list');
# look at their content
my $e1= $t->entity( 'e1');
stest( $e1->text, '', 'e1 text');
my $e2= $t->entity( 'e2');
stest( $e2->text, '', 'e2 text');
my $e3= $t->entity( 'e3');
stest( $e3->text, '', 'e3 text');
# additionnal erase test
$section1= $root->first_child;
stest( (join ":", map { $_->id} $section1->children),
'intro1:para1:para2:note1', 'erase (2)');
$intro1= $section1->first_child( 'intro');
$intro1->erase;
stest( (join ":", map { $_->id} $section1->children),
'paraintro1:paraintro2:para1:para2:note1', 'erase (3)');
# new elt test
my $new_elt= new XML::Twig::XPath::Elt;
stest( ref $new_elt, 'XML::Twig::XPath::Elt', "new");
my $new_elt1= new XML::Twig::XPath::Elt( 'subclass');
stest( ref $new_elt, 'XML::Twig::XPath::Elt', "new subclass");
my $new_elt2= new XML::Twig::XPath::Elt;
stest( ref $new_elt2, 'XML::Twig::XPath::Elt', "create no gi");
my $new_elt3= new XML::Twig::XPath::Elt( 'elt3');
$new_elt3->set_id( 'elt3');
etest( $new_elt3, 'elt3', 'elt3', "create with gi");
my $new_elt4= new XML::Twig::XPath::Elt( 'elt4', 'text of elt4');
ttest( $new_elt4, 'text of elt4', "create with gi and text");
my $new_elt5= new XML::Twig::XPath::Elt( 'elt5', 'text of elt5 ', $new_elt4);
ttest( $new_elt5, 'text of elt5 text of elt4', "create with gi and content");
my $new_elt6= new XML::Twig::XPath::Elt( PCDATA, 'text of elt6');
ttest( $new_elt6, 'text of elt6', "create PCDATA");
# test CDATA
my $st1='bold]]>';
my $t1= new XML::Twig::XPath;
$t1->parse( $st1);
sttest( $t1->root, $st1, "CDATA Section");
my $st2='text bold]]> more text';
my $t2= new XML::Twig::XPath;
$t2->parse( $st2);
sttest( $t2->root, $st2, "CDATA Section");
my $st3='bold]]> text';
my $t3= new XML::Twig::XPath;
$t3->parse( $st3);
sttest( $t3->root, $st3, "CDATA Section");
my $st4='textbold]]>more text';
my $t4= new XML::Twig::XPath;
$t4->parse( $st4);
sttest( $t4->root, $st4, "CDATA Section");
my $st5='text more text';
my $t5= new XML::Twig::XPath;
$t5->parse( $st5);
sttest( $t5->root, $st5, "CDATA Section with ]]<");
# test prefix
my $st6='textmore text';
my $t6= new XML::Twig::XPath;
$t6->parse( $st6);
$doc= $t6->root;
$doc->prefix( 'p1:');
sttest( $t6->root,'p1:textmore text',
"prefix doc");
my $el1= $doc->first_child( 'el1');
$el1->prefix( 'p2:');
sttest( $t6->root,'p1:p2:textmore text',
"prefix el1");
my $el2= $doc->first_child( 'el2');
my $pcdata= $el2->first_child( PCDATA);
$pcdata->prefix( 'p3:');
sttest( $t6->root,'p1:p2:textp3:more text',
"prefix pcdata");
is( $t6->node_cmp( 1), -1, "compare twig with scalar");
ok( UNIVERSAL::isa( $t->root->getParentNode, 'XML::Twig::XPath'), 'getParentNode on the root');
ok( UNIVERSAL::isa( $t->root->first_child->getParentNode, 'XML::Twig::XPath::Elt'), 'getParentNode on an elt');
eval '$t6->root->node_cmp( []);';
matches( $@, "^unknown node type ", "compare elt with scalar");
my $elt= XML::Twig::XPath::Elt->new( elt => { att1 => 1, att2 => 2 }, "99");
my( $att1, $att2)= $elt->getAttributes;
is( $att1->node_cmp( $att2), -1, "attribute comparison");
is( $att2->node_cmp( $att1), 1, "attribute comparison (reverse order)");
is( $att2->node_cmp( $elt), 1, "compare attribute with elt");
is( $att2->node_cmp( $t6), 1, "compare attribute with elt");
is( $elt->node_cmp( $att1), -1, "compare elt with attribute");
is( $att1->node_cmp( $att1), 0, "compare attribute with itself");
is( $elt->node_cmp( $elt), 0, "compare elt with itself");
eval( '$att1->node_cmp( 1)');
matches( $@, "^unknown node type ", "compare att with scalar");
$elt->set_att( att3 => 3);
my $att3= XML::Twig::XPath::Attribute->new( $elt => 'att3');
is( $att1->node_cmp( $att3), -1, "attribute comparison");
ok( $att2->to_number == 2, "to_number on att");
ok( $elt->to_number == 99, "to_number on elt");
exit 0;
XML-Twig-3.50/t/test_attregexp_cond.t 0000755 0001750 0001750 00000002545 12346001775 017766 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
my $i=0;
my $failed=0;
my $TMAX=4; # do not forget to update!
print "1..$TMAX\n";
$i++;
print "ok $i\n"; # loading
my $t= XML::Twig->new(
twig_handlers =>
{ 'elt[@att=~/^v/]' => sub { $i++;
if( $_->att( 'ok') eq "ok")
{ print "ok $i\n";
}
else
{ print "NOK $i\n";
# print STDERR "id: ", $_->att( 'id'), "\n";
}
},
'elt[@change=~/^now$/]' => sub { $_[0]->setTwigHandler(
'elt[@att=~/^new/]' =>
sub { $i++;
if( $_->att( 'ok') eq "ok")
{ print "ok $i\n"; }
else
{ print "NOK $i\n";
# print STDERR "id: ", $_->att( 'id'), "\n";
}
});
},
},
);
$t->parse( \*DATA);
exit 0;
__DATA__
fooq
XML-Twig-3.50/t/test_expand_external_entities.t 0000755 0001750 0001750 00000002545 12346001775 022045 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
use XML::Twig;
my $TMAX=3;
print "1..$TMAX\n";
my $xml_file= File::Spec->catfile( "t", "test_expand_external_entities.xml");
my $dtd_file= File::Spec->catfile( "t", "test_expand_external_entities.dtd");
my( $xml, $dtd, $xml_expanded, %ent);
{ local undef $/;
open XML, "<$xml_file" or die "cannot open $xml_file: $!";
$xml= ;
close XML;
open DTD, "<$dtd_file" or die "cannot open $dtd_file: $!";
$dtd= ;
close DTD;
}
# extract entities
while( $dtd=~ m{}gx) { $ent{$1}= $2; } #"
# replace in xml
($xml_expanded= $xml)=~ s{&(\w+);}{$ent{$1}}g;
{
my $t= XML::Twig->new( load_DTD => 1);
$t->set_expand_external_entities;
$t->parsefile( $xml_file);
is( normalize_xml( $t->sprint), normalize_xml( $xml_expanded), "expanded document");
}
{
my $t= XML::Twig->new( load_DTD => 1, expand_external_ents => 1);
$t->parsefile( $xml_file);
is( normalize_xml( $t->sprint), normalize_xml( $xml_expanded), "expanded document");
}
{
(my $xml_no_dtd= $xml_expanded)=~ s{^}{}s;
my $t= XML::Twig->new( load_DTD => 1, expand_external_ents => 1, do_not_output_DTD => 1);
$t->parsefile( $xml_file);
is( normalize_xml( $t->sprint), normalize_xml( $xml_no_dtd), "expanded document");
}
exit 0;
XML-Twig-3.50/t/xmlxpath_05attrib.t 0000755 0001750 0001750 00000001036 12346001774 017271 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use Test;
plan( tests => 6);
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new->parse( \*DATA);
ok( $t);
my @ids = $t->findnodes( '//BBB[@id]');
ok(@ids, 2);
my @names = $t->findnodes( '//BBB[@name]');
ok(@names, 1);
my @attribs = $t->findnodes( '//BBB[@*]');
ok(@attribs, 3);
my @noattribs = $t->findnodes( '//BBB[not(@*)]');
ok(@noattribs, 1);
exit 0;
__DATA__
XML-Twig-3.50/t/xmlxpath_24namespaces.t 0000755 0001750 0001750 00000010164 12346001774 020126 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
if( defined $XML::XPathEngine::VERSION && $XML::XPathEngine::VERSION < 0.09)
{ print "1..1\nok 1\n";
warn "cannot use set_namespace, needs XML::XPathEngine 0.09+ (installed version is $XML::XPathEngine::VERSION)\n";
exit;
}
plan( tests => 15);
my $t= XML::Twig::XPath->new->parse( *DATA);
my $node= $t->findvalue( '//attr:node/@attr:findme');
ok( $node, 'someval');
my @nodes;
# Do not set namespace prefixes - uses element context namespaces
@nodes = $t->findnodes('//foo:foo', $t); # should find foobar.com foos
ok( @nodes, 3);
@nodes = $t->findnodes('//goo:foo', $t); # should find no foos
ok( @nodes, 0);
@nodes = $t->findnodes('//foo', $t); # should find default NS foos
ok( @nodes, 2);
$node= $t->findvalue( '//*[@attr:findme]');
ok( $node, 'attr content');
# Set namespace mappings.
$t->set_namespace("foo" => "flubber.example.com");
$t->set_namespace("goo" => "foobar.example.com");
@nodes = $t->findnodes('//foo:foo', $t); # should find flubber.com foos
ok( @nodes, 2);
@nodes = $t->findnodes('//goo:foo', $t); # should find foobar.com foos
ok( @nodes, 3);
@nodes = $t->findnodes('//foo', $t); # should find default NS foos
ok( @nodes, 2);
ok( $t->findvalue('//attr:node/@attr:findme'), 'someval');
## added to test set_namespace
if( ! defined $XML::XPathEngine::VERSION )
{ my_skip( 5, "can only test set_strict_namespaces with XML::XPathEngine 0.09+ installed"); }
else
{ my $xml= 'Node 1Node 2
';
{
my $twig = XML::Twig::XPath->new();
$twig->parse( $xml);
$twig->set_namespace('example','http://example.com/');
$twig->set_strict_namespaces(1);
my $v = $twig->findvalue('//foo');
ok( $v, '', '//foo (strict_namespaces)');
$twig->set_strict_namespaces(0);
my $v1 = $twig->findvalue('//foo');
ok( $v1, 'Node 1', '//foo (default behaviour)');
}
{
my $twig = XML::Twig::XPath->new();
$twig->set_namespace('example','http://example.com/');
$twig->parse( $xml);
my $v = $twig->findvalue('//example:foo');
ok( $v, 'Node 1Node 2', '//example:foo');
}
{
my $twig = XML::Twig::XPath->new();
$twig->parse( $xml);
my $v = $twig->findvalue('//foo');
ok( $v, 'Node 1', '//foo');
}
{
my $twig = XML::Twig::XPath->new();
$twig->parse( $xml);
$twig->set_namespace('example','http://example.com/');
my $v = $twig->findvalue('//foo');
ok( $v, 'Node 1', '//foo (default behaviour)');
}
}
# added to test namespaces on attributes
{
my $xml= 'Node 1Node 2Node 3Node 4
';
my $twig = XML::Twig::XPath->new();
$twig->parse( $xml);
$twig->set_namespace('b','http://example.com/');
ok( $twig->findvalue( '//*[@b:att]'), 'Node 1Node 3', 'namespaces on attributes');
}
{
my %seen_message;
sub my_skip
{ my( $nb_skip, $message)= @_;
$message ||='';
unless( $seen_message{$message})
{ warn "\n$message: skipping $nb_skip tests\n";
$seen_message{$message}++;
}
for (1..$nb_skip) { ok( 1); }
}
}
exit 0;
__DATA__
attr content
XML-Twig-3.50/t/xmlxpath_15axisfol_sib.t 0000755 0001750 0001750 00000001132 12346001774 020304 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 6);
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new->parse( \*DATA);
ok( $t);
my @nodes;
@nodes = $t->findnodes( '/AAA/BBB/following-sibling::*');
ok(@nodes, 2);
ok($nodes[1]->getName, "CCC"); # test document order
@nodes = $t->findnodes( '//CCC/following-sibling::*');
ok(@nodes, 3);
ok($nodes[1]->getName, "FFF");
exit 0;
__DATA__
XML-Twig-3.50/t/test_kwalitee.t 0000755 0001750 0001750 00000000674 12346001775 016566 0 ustar mrodrigu mrodrigu #!/usr/bin/perl
use strict;
use warnings;
if( ! $ENV{TEST_AUTHOR} ) { print "1..1\nok 1\n"; warn "Author test. Set \$ENV{TEST_AUTHOR} to a true value to run.\n"; exit; }
eval { require Test::More; Test::More->import(); };
if( $@) { print "1..1\nok 1\n"; warn "need test::More installed for this test\n"; exit; }
eval { require Test::Kwalitee; Test::Kwalitee->import() };
plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
XML-Twig-3.50/t/test_spaces.t 0000755 0001750 0001750 00000002164 12346001774 016232 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use XML::Twig;
$/="\n\n";
print "1..3\n";
my $twig=XML::Twig->new( keep_spaces_in => [ 'e']);
test( $twig, 1);
$twig=XML::Twig->new( keep_spaces_in => [ 'e', 'sub1']);
test( $twig, 2);
$twig=XML::Twig->new( keep_spaces => 1);
test( $twig, 3);
sub test
{ my( $twig, $test_nb)= @_;
my $doc= ; chomp $doc;
my $expected_res= ; chomp $expected_res;
$twig->parse( $doc);
my $res= $twig->sprint;
$res=~ s/\n+$//;
if( $res eq $expected_res)
{ print "ok $test_nb\n"; }
else
{ print "not ok $test_nb\n";
warn " expected: \n$expected_res\n result: \n$res\n";
}
}
exit 0;
__DATA__
&c;b &c;b &c;b
&c;
&c;b
&c;
&c;b
&c;
&c;b
&c;
XML-Twig-3.50/t/test_xml_split.xml 0000644 0001750 0001750 00000000550 12346001774 017316 0 ustar mrodrigu mrodrigu elt1 content 1elt1 content 2elt1 content 3elt1 content 4elt1 content 5elt1 content 6elt1 content 7elt1 content 8elt1 content 9
XML-Twig-3.50/t/test_changes.t 0000755 0001750 0001750 00000000373 12346001775 016365 0 ustar mrodrigu mrodrigu #!/usr/bin/perl
use Test::More;
eval 'use Test::CPAN::Changes';
plan skip_all => 'Test::CPAN::Changes required for this test' if $@;
plan skip_all => 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.' if ! $ENV{TEST_AUTHOR};
changes_ok();
XML-Twig-3.50/t/test_3_50.t 0000755 0001750 0001750 00000001212 12637027341 015414 0 ustar mrodrigu mrodrigu #!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use Test::More tests => 2;
use utf8;
{
my $doc=q{titlep 1p 2};
my $out;
open( my $out_fh, '>', \$out);
my $t= XML::Twig->new ( twig_handlers => { _default_ => sub { $_->flush( $out_fh); } });
$t->parse( $doc);
is( $out, $doc, 'flush with _default_ handler');
}
{
my $doc=q{titlep 1p 2};
my $out;
open( my $out_fh, '>', \$out);
my $t= XML::Twig->new ( twig_handlers => { 'd' => sub { $_->flush( $out_fh); } });
$t->parse( $doc);
is( $out, $doc, 'flush with handler on the root');
}
exit;
XML-Twig-3.50/t/test_need_io_scalar.t 0000755 0001750 0001750 00000040501 12346001775 017701 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
# tests that require IO::String to run
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;
BEGIN
{ eval "require IO::String";
if( $@)
{ print "1..1\nok 1\n";
warn "skipping, need IO::String\n";
exit;
}
else
{ import IO::String; }
}
print "1..1778\n";
{ my $out1='';
my $fh1= IO::String->new( \$out1);
my $out2='';
my $fh2= IO::String->new( \$out2);
my $doc='mainignoredcompletelyinignoredcompletely';
my $out= select $fh1;
my $t= XML::Twig->new( ignore_elts => { i => 'print' })->parse( $doc);
$t->print( $fh2);
select $out;
is( $out1,'ignoredcompletelyignoredcompletely', 'ignored with print option');
is( $out2,'mainin', 'print after ignored_elts');
}
{ my $doc='mainignoredcompletelyinignoredcompletely';
my $t= XML::Twig->new( ignore_elts => { i => 'string' })->parse( $doc);
is( $t->{twig_buffered_string} || '','ignoredcompletelyignoredcompletely', 'ignored with string option');
is( $t->sprint,'mainin', 'string after ignored_elts (to string)');
}
{ my $string='';
my $doc='mainignoredcompletelyinignoredcompletely';
my $t= XML::Twig->new( ignore_elts => { i => \$string })->parse( $doc);
is( $string,'ignoredcompletelyignoredcompletely', 'ignored with string reference option');
is( $t->sprint,'mainin', 'string after ignored_elts (to string reference)');
}
{ # test autoflush
my $out='';
my $fh= IO::String->new( \$out);
my $doc= "";
my $t= XML::Twig->nparse( twig_handlers => { elt => sub { $_->flush( $fh) } }, $doc);
is( $out, $doc, "autoflush, no args");
}
{ my $out='';
my $fh= IO::String->new( \$out);
my $doc= "";
my $t= XML::Twig->nparse( twig_handlers => { elt => sub { $_->flush( $fh, empty_tags => "expand") } }, $doc);
is( $out, "", "autoflush, no args, expand empty tags");
}
{ # test bug on comments after the root element RT #17064
my $out='';
my $fh= IO::String->new( \$out);
my $doc= q{};
XML::Twig->nparse( $doc)->print( $fh);
is( $out, $doc, 'comment after root element');
}
{ # more tests, with flush this time
my $c= '';
my $pi= '';
my @simple_docs= ('', '', 'foo');
my $i=0;
my @docs= map { $i++; (my $l= $_)=~ s{#}{$i}g;
$i++; (my $t= $_)=~ s{#}{$i}g;
map { ("$l$_", "$_$t", "$l$_$t") } @simple_docs;
}
( $c, $pi, $c.$pi, $pi.$c, $c.$c, $pi.$pi, $c.$pi.$c, $pi.$c.$pi, $c.$pi.$c.$pi, $pi.$c.$pi.$c, $c.$c.$pi, $c.$pi.$pi)
;
foreach my $doc (@docs)
{ foreach my $options ( { comments => "keep", pi => "keep" },
{ comments => "process", pi => "keep" },
{ comments => "keep", pi => "process" },
{ comments => "process", pi => "process" },
)
{ my $options_text= join( ', ', map { "$_ => $options->{$_}" } sort keys %$options);
is( XML::Twig->nparse( %$options, $doc)->sprint, $doc, "sprint cpi $options_text $doc");
is( XML::Twig->nparse( %$options, keep_encoding => 1, $doc)->sprint, $doc, "sprint cpi keep_encoding $options_text $doc");
{ my $out='';
my $fh= IO::String->new( \$out);
XML::Twig->nparse( %$options, $doc)->flush( $fh);
is( $out, $doc, "flush cpi $options_text $doc");
}
{ my $out='';
my $fh= IO::String->new( \$out);
XML::Twig->nparse( keep_encoding => 1, %$options, $doc)->flush( $fh);
is( $out, $doc, "flush cpi keep_encoding $options_text $doc");
}
}
}
}
{ my $out='';
my $fh= IO::String->new( \$out);
my $doc=q{foo};
my $t= XML::Twig->new( pretty_print => 'indented', empty_tags => 'expand',
twig_handlers => { elt => sub { $_[0]->flush( $fh, pretty_print => 'none',
empty_tags => 'html'
);
},
},
);
$t->{twig_autoflush}=0;
$t->parse( $doc);
is( $out => q{foo}, 'flush with a pretty_print arg');
is( $t->sprint => qq{\n \n \n \n \n \n\n},
'flush with a pretty_print arg (checking that option values are properly restored)'
);
}
{ my $out='';
my $fh= IO::String->new( \$out);
select $fh;
my $doc=q{foo};
my $t= XML::Twig->new( pretty_print => 'indented', empty_tags => 'expand',
twig_handlers => { elt => sub { $_[0]->flush( pretty_print => 'none',
empty_tags => 'html'
);
},
},
);
$t->{twig_autoflush}=0;
$t->parse( $doc);
select STDOUT;
is( $out => q{foo}, 'flush with a pretty_print arg (default fh)');
is( $t->sprint => qq{\n \n \n \n \n \n\n},
'flush with a pretty_print arg (checking that option values are properly restored) (default fh)'
);
}
{ my $out='';
my $fh= IO::String->new( \$out);
select $fh;
my $doc=q{foo};
my $t= XML::Twig->new( pretty_print => 'indented', empty_tags => 'expand',
twig_handlers => { elt => sub { $_[0]->flush_up_to( $_, pretty_print => 'none',
empty_tags => 'html'
);
},
},
);
$t->{twig_autoflush}=0;
$t->parse( $doc);
select STDOUT;
is( $out => q{foo}, 'flush with a pretty_print arg (default fh)');
is( $t->sprint => qq{\n \n\n},
'flush with a pretty_print arg (checking that option values are properly restored)'
);
}
{ my $out=''; my $out2=''; my $out3=''; my $out4='';
my $fh= IO::String->new( \$out);
my $fh2= IO::String->new( \$out2);
my $fh3= IO::String->new( \$out3);
my $fh4= IO::String->new( \$out4);
my $t= XML::Twig->new( empty_tags => 'expand', pretty_print => 'none')->parse( '');
$t->print( $fh);
is( $out, "", "empty_tags expand");
$t->print( $fh2, empty_tags => 'normal', pretty_print => 'indented' );
is( $out2, "\n \n\n", "print with args");
$t->print( $fh3);
is( $out3, "", "print without args");
is( $t->sprint( empty_tags => 'normal'), "", "empty_tags normal");
$t->print( $fh4);
is( $t->sprint( pretty_print => 'indented', empty_tags => 'normal'), "\n \n\n", "empty_tags expand");
$t->set_pretty_print( 'none');
$t->set_empty_tag_style( 'normal');
}
{ my $out=''; my $out2='';
my $fh= IO::String->new( \$out);
my $fh2= IO::String->new( \$out2);
my $t= XML::Twig->new( empty_tags => 'expand', pretty_print => 'none')->parse( '');
$t->root->print( $fh);
is( $out, "", "empty_tags expand");
$t->root->print( $fh2, { pretty_print => 'indented' } );
is( $out2, "\n \n\n", "print elt indented");
$out=''; $fh= IO::String->new( \$out); $t->root->print( $fh);
is( $out, "", "back to default");
$t->set_pretty_print( 'none');
$t->set_empty_tag_style( 'normal');
}
{ my $out=''; my $out2='';
my $fh= IO::String->new( \$out);
my $fh2= IO::String->new( \$out2);
my $t= XML::Twig->new( empty_tags => 'expand', pretty_print => 'none');
$t->parse( '')->flush( $fh);
is( $out, "", "empty_tags expand");
$t->parse( '')->flush( $fh2);
is( $t->sprint( empty_tags => 'normal'), "", "empty_tags normal");
$out=''; $t->parse( '')->flush( $fh);
is( $t->sprint( pretty_print => 'indented', empty_tags => 'normal'), "\n \n\n", "empty_tags expand");
$t->set_pretty_print( 'none');
$t->set_empty_tag_style( 'normal');
}
{ my $out='';
my $fh= IO::String->new( \$out);
my $doc= q{
}, "purge_up_to");
}
{ my $out='';
my $fh= IO::String->new( \$out);
my $t= XML::Twig->new()->parse( q{]>toto});
$t->dtd_print( $fh);
is( $out, "\n\n]>\n", "dtd_print");
close $fh;
}
{ my $out="";
my $fh= IO::String->new( \$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{beforefinish});
select STDOUT;
is( $out, q{[X]before[Y]finish}, "finish_print");
}
package test_handlers;
sub new { bless { } }
sub recognized_string { return 'recognized_string'; }
sub original_string { return 'original_string'; }
package main;
{
my $out='';
my $fh= IO::String->new( \$out);
my $stdout= select $fh;
XML::Twig::_twig_print_original_default( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'original_string', 'twig_print_original_default');
$out='';
$fh= IO::String->new( \$out);
select $fh;
XML::Twig::_twig_print( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'recognized_string', 'twig_print_default');
$out='';
$fh= IO::String->new( \$out);
select $fh;
XML::Twig::_twig_print_end_original( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'original_string', 'twig_print_end_original');
$out='';
$fh= IO::String->new( \$out);
select $fh;
XML::Twig::_twig_print( test_handlers->new);
select $stdout;
close $fh;
is( $out, 'recognized_string', 'twig_print_end');
}
XML::Twig::_twig_print_entity(); # does nothing!
{
my %ents= ( foo => '"toto"', pile => 'SYSTEM "file.bar" NDATA bar');
my %ent_text = hash_ent_text( %ents);
my $ent_text = string_ent_text( %ents);
my $doc= "";
my $t= XML::Twig->new->parse( $doc);
is( normalize_xml( $t->entity_list->text), $ent_text, 'entity_list');
my @entities= $t->entity_list->list;
is( scalar @entities, scalar keys %ents, 'entity_list');
foreach my $ent (@entities)
{ my $out='';
my $fh= IO::String->new( \$out);
my $stdout= select $fh;
$ent->print;
close $fh;
select $stdout;
is( normalize_xml( $out), $ent_text{$ent->name}, "print $ent->{name}");
}
my $out='';
my $fh= IO::String->new( \$out);
my $stdout= select $fh;
$t->entity_list->print;
close $fh;
select $stdout;
is( normalize_xml( $out), $ent_text, 'print entity_list');
}
{ my( $out1, $out2, $out3);
my $fh1= IO::String->new( \$out1);
my $fh2= IO::String->new( \$out2);
my $fh3= IO::String->new( \$out3);
my $stdout= select $fh3;
my $t= XML::Twig->new( twig_handlers => { e => sub { $_->print( $fh2);
print $fh1 "X";
$_[0]->finish_print( $fh1);
},
},
)
->parse( 'texte
text
more text
foo
');
print 'should be in $out3';
select $stdout;
is( $out1, 'Xmore text
foo
', 'finish_print');
is( $out2, 'e
text
', 'print to fh');
is( $out3, 'should be in $out3', 'restoring initial fh');
}
{ my $doc= 'tatat more';
my $out;
my $fh= IO::String->new( \$out);
my $t= XML::Twig->new( comments => 'process', pi => 'process')->parse( $doc);
$t->flush( $fh);
is( $out, $doc, 'flush with cdata');
}
{ my $out='';
my $fh= IO::String->new( \$out);
my $doc='texttext';
my $t= XML::Twig->new( twig_roots=> { elt2 => 1 },
start_tag_handlers => { elt => sub { print $fh ''; } },
end_tag_handlers => { elt3 => sub { print $fh ''; } },
twig_print_outside_roots => $fh,
keep_encoding => 1
)
->parse( $doc);
is( $out, 'texttext',
'twig_print_outside_roots, start/end_tag_handlers, keep_encoding');
close $fh;
$out='';
$fh= IO::String->new( \$out);
$t= XML::Twig->new( twig_roots=> { elt2 => 1 },
start_tag_handlers => { elt => sub { print $fh ''; } },
end_tag_handlers => { elt3 => sub { print $fh ''; } },
twig_print_outside_roots => $fh,
)
->parse( $doc);
is( $out, 'texttext',
'twig_print_outside_roots and start_tag_handlers');
}
{ my $t= XML::Twig->new->parse( '');
eval( '$t->set_output_encoding( "ISO-8859-1");');
if( $@)
{ skip( 1 => "your system does not seem to support conversions to ISO-8859-1: $@\n"); }
else
{ is( $t->sprint, qq{},
'creating an output encoding'
);
}
}
{ my $out='';
my $fh= IO::String->new( \$out);
select $fh;
my $doc=' ]>';
my( $expected)= $doc=~ m{()};
XML::Twig->new->parse( $doc)->dtd_print;
select STDOUT;
is_like( $out, $expected, "dtd_print to STDOUT");
}
{ my $out='';
my $fh= IO::String->new( \$out);
select $fh;
my $doc='';
XML::Twig->new( twig_handlers => { elt1 => sub { $_[0]->finish_print; } })->parse( $doc);
select STDOUT;
is( $out, '', "finish_print to STDOUT");
}
{ my $out='';
my $fh= IO::String->new( \$out);
select $fh;
my $doc='';
XML::Twig->new( keep_encoding => 1, twig_handlers => { elt1 => sub { $_[0]->finish_print; } })->parse( $doc);
select STDOUT;
is( $out, '', "finish_print to STDOUT");
}
exit 0;
XML-Twig-3.50/t/test_wrapped.t 0000755 0001750 0001750 00000006166 12346001774 016424 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
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 $TMAX=13;
print "1..$TMAX\n";
unless( XML::Twig::_use( 'Text::Wrap')) { print "1..1\nok 1\n"; warn "skipping: Text::Wrap not available\n"; exit; }
while( my $doc= get_doc())
{ my $result= XML::Twig->nparse( pretty_print => 'wrapped', $doc)->sprint;
my $expected= get_doc();
foreach ($result, $expected) { s{ }{.}g; }
is( $result, $expected, '');
}
XML::Twig::Elt->set_wrap(0);
is( XML::Twig::Elt->set_wrap(1), 0, "set_wrap - 1");
is( XML::Twig::Elt->set_wrap(1), 1, "set_wrap - 2");
is( XML::Twig::Elt->set_wrap(0), 1, "set_wrap - 3");
is( XML::Twig::Elt->set_wrap(0), 0, "set_wrap - 4");
is( XML::Twig::Elt::set_wrap(1), 0, "set_wrap - 5");
is( XML::Twig::Elt::set_wrap(1), 1, "set_wrap - 6");
is( XML::Twig::Elt::set_wrap(0), 1, "set_wrap - 7");
is( XML::Twig::Elt::set_wrap(0), 0, "set_wrap - 8");
sub get_doc
{ local $/="\n\n";
my $doc= ;
if( $doc)
{ $doc=~ s{\n\n}{\n};
$doc=~ s/\{([^}]*)\}/$1/eeg;
}
return $doc;
}
__DATA__
{"foo" x 40}foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoo
foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoo{"foo" x 80}foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoo
foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofo
ofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoof
oofoofoofoofoofoofoofoofoofoofoo{"foo" x 40}foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoof
oofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoo{"foo " x 40}{"bar " x 40}foo foo foo foo foo foo foo foo foo foo foo foo foo foo
foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo
foo foo foo foo foo foo foo foo bar bar bar bar bar bar bar bar bar bar bar bar bar bar
bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar
bar bar bar bar bar bar bar bar {"foo " x 40}{ "aaa" x 60}{ "foo "x20 }{"bar " x 40}foo foo foo foo foo foo foo foo foo foo foo foo foo foo
foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo
foo foo foo foo foo foo foo foo
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaafoo foo foo foo foo foo foo foo
foo foo foo foo foo foo foo foo foo foo foo foo bar bar bar bar bar bar bar bar bar bar bar bar bar bar
bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar bar
bar bar bar bar bar bar bar bar
XML-Twig-3.50/t/test_3_40.t 0000755 0001750 0001750 00000034751 12346001774 015430 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
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 $TMAX=96;
print "1..$TMAX\n";
{ my $d="titlep 1p 2";
is( lf_in_t( XML::Twig->parse( pretty_print => 'indented', discard_spaces => 1, $d)), 1, 'space prevents indentation');
is( lf_in_t( XML::Twig->parse( pretty_print => 'indented', discard_all_spaces => 1, $d)), 5, 'discard_all_spaces restores indentation');
}
sub lf_in_t
{ my($t)= @_;
my @lfs= $t->sprint=~ m{\n}g;
return scalar @lfs;
}
{ my $d='';
my @tests=
( [ 't1|t2', HN => 't1t2' ],
[ 't1|t2|t3[@att="a|b"]', HN => 't1t2t3-1' ],
[ 't1|t2|t3[@att!="a|b"]', HN => 't1t2t3-2t3-3' ],
[ 't1|level(1)', H => 't1t1t2t3-1t3-2t3-3' ],
[ 't1|level(2)', H => 't1t4' ],
[ 't1|_all_', H => 't1t1t2t3-1t3-2t4t3-3d'],
[ qr/t[12]/ . '|t3/t4', H => 't1t2t4' ],
[ 't3[@a2="a|b"]', HN => 't3-2' ],
[ 't3[@a2="a|b"]|t3|t3/t4', H => 't3-1t3-2t3-2t4t3-3' ],
);
foreach my $test (@tests)
{ my $nb=0;
my $ids='';
my( $trigger, $test_cat, $expected_ids)= @$test;
my $handlers= $test_cat =~ m{H} ? { $trigger => sub { $ids.=$_->id; 1; } } : {};
my $t= XML::Twig->new( twig_handlers => $handlers )->parse( $d);
is( $ids, $expected_ids, "(H) trigger with alt: '$trigger'");
my $uniq_ids= join '', sort $expected_ids=~m{(t\d(?:-\d)?)}g;
if( $test_cat =~ m{X})
{ (my $xpath= "//$trigger")=~ s{\|t}{|//t}g;
is( join( '', map { $_->id } $t->findnodes( $xpath)), $uniq_ids, " (X) path with |: '$trigger'");
}
if( $test_cat =~ m{N})
{ is( join( '', map { $_->id } $t->root->children( $trigger)), $uniq_ids, "(N)navigation with |: '$trigger'"); }
}
}
{ my $t1= XML::Twig->parse( '');
is( XML::Twig->active_twig()->root->id, 'd1', 'active_twig, one twig');
my $t2= XML::Twig->parse( '');
is( XML::Twig->active_twig()->root->id, 'd2', 'active_twig, second twig');
}
{ eval { XML::Twig->new(error_context => 1)->parse( $0); };
matches( $@, "you seem to have used the parse method on a filename", 'parse on a file name');
}
{ my $got;
XML::Twig->parse( twig_handlers => { 'e[@a]' => sub { $got .= $_->id; } }, '');
is( $got, 'i1i3', 'bare attribute in handler condition');
}
if( $] > 5.008)
{ my $doc= q{]>&ext;};
ok( XML::Twig->parse( expand_external_ents => -1, $doc), 'failsafe expand_external_ents');
}
else
{ skip( 1, 'not tested under perl < 5.8'); }
{ my $t=XML::Twig->parse( q{e11e21e12});
is( join( ':', $t->findvalues( [$t->root->children], "./e1")), 'e11:e12', 'findvalues on array');
}
{ my $t=XML::Twig->parse( "");
$t->set_encoding( "UTF-8");
is( $t->sprint, qq{\n}, 'set_encoding without XML declaration');
}
{ my $t=XML::Twig->parse( "");
$t->set_standalone( 1);
is( $t->sprint, qq{\n}, 'set_standalone (yes) without XML declaration');
}
{ my $t=XML::Twig->parse( "");
$t->set_standalone( 0);
is( $t->sprint, qq{\n}, 'set_standalone (no) without XML declaration');
}
{ my $t=XML::Twig->parse( "");
nok( $t->xml_version, 'xml_version with no XML declaration');
$t->set_xml_version( 1.1);
is( $t->sprint, qq{\n}, 'set_xml_version without XML declaration');
is( $t->xml_version, 1.1, 'xml_version after being set');
}
{ my $t= XML::Twig->new;
is( $t->_dump, "document\n", '_dump on an empty twig');
}
{ my $t=XML::Twig->parse( pretty_print => 'none', 'foobar');
$t->root->field_to_att( 'f[@a="b"]', 'g');
is( $t->sprint, 'foo', 'field_to_att on non-simple condition');
$t->root->att_to_field( g => 'gg');
is( $t->sprint, 'barfoo', 'att_to_field with att != field');
}
{ my $t=XML::Twig->parse( '');
$t->root->wrap_in( 'nroot');
is( $t->sprint, '', 'wrapping the root');
}
{
my $t=XML::Twig->new;
XML::Twig::_set_weakrefs(0);
my $doc='\n texttext more text foo\n more';
$t->parse( $doc);
$doc=~ s{\n }{}; # just the first one
is( $t->sprint, $doc, 'parse with no weakrefs');
$t->root->insert_new_elt( first_child => x => 'text');
$doc=~ s{}{text};
is( $t->sprint, $doc, 'insert first child with no weakrefs');
$t->root->insert_new_elt( last_child => x => 'text');
$doc=~ s{}{text};
is( $t->sprint, $doc, 'insert last child with no weakrefs');
$t->root->wrap_in( 'dd');
$doc=~ s{}{
}; $doc=~s{}{
};
is( $t->sprint, $doc, 'wrap with no weakrefs');
$t->root->unwrap;
$doc=~s{}{}g;
is( $t->sprint, $doc, 'unwrap with no weakrefs');
my $new_e= XML::Twig::Elt->new( ee => { c => 1 }, 'ee text');
$new_e->replace( $t->root->first_child( 'e'));
$doc=~ s{}{ee text};
is( $t->sprint, $doc, 'replace with no weakrefs');
XML::Twig::_set_weakrefs(1);
}
{
my $t= XML::Twig->new( no_expand => 1);
XML::Twig::_set_weakrefs(0);
my $doc=']> bar &bar; bar&bar;&foo; &bar; bar &foo;&bar; na &foo;';
$t->parse( $doc);
(my $got= $t->sprint)=~ s{\n}{}g;
is( $got, $doc, 'external entities without weakrefs');
XML::Twig::_set_weakrefs(1);
}
{
XML::Twig::_set_weakrefs(0);
{ my $t= XML::Twig->new; undef $t; }
ok( 1, "DESTROY doesn't crash when weakrefs is off");
XML::Twig::_set_weakrefs(1);
}
{ my $doc= 'foobarbar';
my( $got1, $got2);
XML::Twig->new( twig_handlers => { e1 => sub { $_->parent->set_att( get1 => 1); },
e2 => sub { $_->parent->set_att( '#get2' => 1); },
'[@get1]' => sub { $got1 .= 'a' . $_->id; },
'[@#get2]' => sub { $got2 .= 'a' . $_->id; },
'e[@get1]' => sub { $got1 .= 'b' . $_->id; },
'e[@#get2]' => sub { $got2 .= 'b' . $_->id; },
},
)
->parse( $doc);
is( $got1, 'be1ae1', 'handler on bare attribute');
is( $got2, 'be3ae3', 'handler on private (starting with #) bare attribute');
}
{ my $t=XML::Twig->parse( 'foo');
my $root= $t->root;
ok( $root->closed, 'closed on completely parsed tree');
ok( $root->_extra_data_before_end_tag, '_extra_data_before_end_tag (success)');
nok( $root->first_child->_extra_data_before_end_tag, '_extra_data_before_end_tag (no data)');
}
{ my $t= XML::Twig->parse( pi => 'process', '');
is( $t->first_elt( '#PI')->pi_string, '', 'pi_string with empty data');
}
{ my $t= XML::Twig->parse( '');
is( ids( $t->root->children( '.a')), 'e1:f1', 'nav on class');
}
{ my $t=XML::Twig->parse( 'foobarfoobar123');
is ( ids( $t->root->children( 'e[string()="foo"]')), 'e1', 'navigation condition using string() =');
is ( ids( $t->root->children( 'e[string()=~/foo/]')), 'e1:e3', 'navigation condition using string() =~');
is ( ids( $t->root->children( 'e[string()!~/foo/]')), 'e2:e4', 'navigation condition using string() !~');
is ( ids( $t->root->children( 'e[string()!="foo"]')), 'e2:e3:e4', 'navigation condition using string() !=');
is ( ids( $t->root->children( 'e[string()]')), 'e1:e2:e3', 'navigation condition using bare string()');
is ( ids( $t->root->findnodes( './e[string()="foo"]')), 'e1', 'xpath condition using string() =');
is ( ids( $t->root->findnodes( './e[string()=~/foo/]')), 'e1:e3', 'xpath condition using string() =~');
is ( ids( $t->root->findnodes( './e[string()!~/foo/]')), 'e2:e4', 'xpath condition using string() !~');
is ( ids( $t->root->findnodes( './e[string()!="foo"]')), 'e2:e3:e4', 'xpath condition using string() !=');
is ( ids( $t->root->findnodes( './e[string()]')), 'e1:e2:e3', 'xpath condition using bare string()');
is( ids( $t->root->children( 'n[string()=2]')), 'n2', 'navigation string() =');
is( ids( $t->root->children( 'n[string()!=2]')), 'n1:n3', 'navigation string() !=');
is( ids( $t->root->children( 'n[string()>2]')), 'n3', 'navigation string() >');
is( ids( $t->root->children( 'n[string()>=2]')), 'n2:n3', 'navigation string() >=');
is( ids( $t->root->children( 'n[string()<2]')), 'n1', 'navigation string() <');
is( ids( $t->root->findnodes( './n[string()=2]')), 'n2', 'xpath string() =');
is( ids( $t->root->findnodes( './n[string()!=2]')), 'n1:n3', 'xpath string() !=');
is( ids( $t->root->findnodes( './n[string()>2]')), 'n3', 'xpath string() >');
is( ids( $t->root->findnodes( './n[string()>=2]')), 'n2:n3', 'xpath string() >=');
is( ids( $t->root->findnodes( './n[string()<2]')), 'n1', 'xpath string() <');
is( ids( $t->root->findnodes( './n[string()<=2]')), 'n1:n2', 'xpath string() <=');
}
{ my $got;
my $t=XML::Twig->parse( twig_handlers => { d => sub { $got .="wrong"; },
'd[@id]' => sub { $got .= "ok"; 0 },
},
''
);
is( $got, 'ok', 'returning 0 prevents the next handler to be called');
}
{ my $d=q{foo
fooblank
};
my $expected=qq{\n \n foo\n \n \n
fooblank
\n \n };
XML::Twig::_indent_xhtml( \$d);
is( $d, $expected, '_indent_xhtml');
}
{ my $d='c';
my @handlers= ( '/d/e[@a="a" or @b="b"]',
'/d/e[@a="a" or @b="c"]|e',
'/d/e[@a="a"]',
'/d/e[@b="b"]',
'/d/e',
'd/e[@a="a" and @b="b"]',
'd/e[@a="a"]',
'd/e[@b="b"]',
'd/e',
'e[@a="a" or @b="b"]',
'e[@b="b" or @a="a"]',
'e[@a="a"]|f',
'e[@b="b"]',
'e',
qr/e|f/,
qr/e|f|g/,
'level(1)',
);
my $t= XML::Twig->new();
for my $stem ( 1, 100)
{ my $i= $stem;
my $expected= join '', ($stem..$stem+$#handlers);
my $got;
$t->setTwigHandlers( { map { $_ => sub { $got .= $i++; } } @handlers });
$t->parse( $d);
is( $got, $expected, 'handler order');
}
}
{ my $t=XML::Twig->parse( "");
$t->{twig_dtd}="";
is( $t->doctype(UpdateDTD => 1), "\n", 'doctype with an updated DTD');
}
{ my $t=XML::Twig->parse( '');
$t->elt_accessors( 'e', 'e');
$t->elt_accessors( { e2 => 'e[2]', se => 'se', sea => 'se[@a]' });
my $root= $t->root;
is( $root->e->id, 'e1', 'accessor, no alias, scalar context');
my $e2= ($root->e)[-1];
is( $e2->id, 'e2', 'accessor no alias, list context');
$e2= $root->e2;
is( $e2->id, 'e2', 'accessor alias, list context');
is( $e2->se->id, 'se1', 'accessor alias, scalar context');
is( $e2->sea->id, 'se2', 'accessor, with complex step, alias, scalar context');
}
{ my $t=XML::Twig->new( elt_accessors => [ 'e', 'se' ])
->parse( '');
my $root= $t->root;
is( $root->e->id, 'e1', 'accessor (created in new), no alias, scalar context');
my $se= ($root->e)[-1]->se;
is( $se->id, 'se1', 'accessor (created in new) no alias, scalar context, 2');
}
{ my $t=XML::Twig->new( elt_accessors => { e2 => 'e[2]', se => 'se', sea => 'se[@a]' })
->parse( '');
my $e2= $t->root->e2;
is( $e2->id, 'e2', 'accessor (created in new) alias, list context');
is( $e2->se->id, 'se1', 'accessor (created in new) alias, scalar context');
is( $e2->sea->id, 'se2', 'accessor (created in new), with complex step, alias, scalar context');
}
{ my $doc= ']>';
my $t= XML::Twig->parse( do_not_output_DTD => 1, $doc);
is( $t->sprint, qq{\n}, 'do_not_output_DTD');
}
{ my $t= XML::Twig->parse( no_prolog => 1, ']>');
is( $t->sprint, qq{}, 'no_prolog');
}
{ my $t= XML::Twig->parse( ']>');
is( $t->sprint, qq{\n\n]>\n}, 'no_prolog');
}
{ my $e= XML::Twig::Elt->new( 'e');
$e->set_empty;
is( $e->sprint, '', 'set_empty with no value');
$e->set_empty( 0);
is( $e->sprint, '', 'set_empty(0)');
$e->set_empty;
is( $e->sprint, '', 'set_empty with no value');
$e->set_empty( 1);
is( $e->sprint, '', 'set_empty(1');
$e->set_empty;
is( $e->sprint, '', 'set_empty with no value');
$e->set_empty( 1);
is( $e->sprint, '', 'set_empty(1)');
my $e2= XML::Twig::Elt->parse( '');
$e2->set_not_empty();
is( $e2->sprint, '', 'set_not_empty');
ok( ! $e2->closed, 'closed on an orphan elt');
}
{ my $t= XML::Twig->parse( '');
my $l2= $t->first_elt( 'l2');
my $l4= $t->first_elt( 'l4');
$l2->cut;
$l4->cut;
is( $l4->_root_through_cut->tag, 'd', '_root_through_cut');
is( $l4->_inherit_att_through_cut( 'a', 'd'), 'd', '_inherit_att_through_cut');
}
{ my $s= "foo";
is( XML::Twig::_to_utf8( 'iso-8859-1', $s), $s, 'trivial test of _to_utf8');
}
XML-Twig-3.50/t/test_with_lwp_not_wf.xml 0000644 0001750 0001750 00000000036 12346001775 020514 0 ustar mrodrigu mrodrigu text
XML-Twig-3.50/t/xmlxpath_30lang.t 0000755 0001750 0001750 00000001004 12346001775 016717 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 4);
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new( keep_spaces => 1)->parse( \*DATA);
ok( $t);
my @en = $t->findnodes( '//*[lang("en")]');
ok(@en, 2);
my @de = $t->findnodes( '//content[lang("de")]');
ok(@de, 1);
exit 0;
__DATA__
Here we go...und hier deutschsprachiger Text :-)
XML-Twig-3.50/t/test2.t 0000755 0001750 0001750 00000004223 12346001774 014754 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
# This tests the doctype and DTD access functions
$|=1;
use XML::Twig;
use Cwd;
$0 =~ s!\\!/!g;
my ($DIR,$PROG) = $0 =~ m=^(.*/)?([^/]+)$=;
$DIR =~ s=/$== || chop($DIR = cwd());
chdir $DIR;
my $i=0;
my $failed=0;
my $TMAX=15; # don't forget to update!
print "1..$TMAX\n";
# test twig creation
my $t= new XML::Twig();
ok( $t, 'twig creation');
# first test an internal DTD
my $in_file= "test2_1.xml";
my $res_file= "test2_1.res";
my $exp_file= "test2_1.exp";
# test parse no dtd info required
$t->parsefile( $in_file, ErrorContext=>2);
ok( $t, 'parse');
open( RES, ">$res_file") or die "cannot open $res_file:$!";
$t->print( \*RES);
close RES;
ok( $res_file, $exp_file, "flush");
$res_file= 'test2_2.res';
$exp_file= 'test2_2.exp';
open( RES, ">$res_file") or die "cannot open $res_file:$!";
$t->print( \*RES, Update_DTD => 1);
close RES;
ok( $res_file, $exp_file, "flush");
$t= new XML::Twig();
ok( $t, 'twig creation');
$in_file= "test2_2.xml";
$res_file= "test2_3.res";
$exp_file= "test2_3.exp";
$t->parsefile( $in_file, ErrorContext=>2);
ok( $t, 'parse');
open( RES, ">$res_file") or die "cannot open $res_file:$!";
my $e2=new XML::Twig::Entity( 'e2', 'entity2');
my $entity_list= $t->entity_list;
$entity_list->add( $e2);
my $e3=new XML::Twig::Entity( 'e3', undef, 'pic.jpeg', 'JPEG');
$entity_list= $t->entity_list;
$entity_list->add( $e3);
$t->print( \*RES, Update_DTD => 1);
close RES;
ok( $res_file, $exp_file, "flush");
my $dtd= $t->dtd;
ok( !$dtd, 'dtd exits');
$t= new XML::Twig(LoadDTD=>1);
ok( $t, 'twig creation');
$t->parsefile( $in_file, ErrorContext=>2, );
$dtd= $t->dtd;
ok( $dtd, 'dtd not found');
my @model= sort keys %{$dtd->{model}};
stest( stringify( @model), 'doc:intro:note:para:section:title', 'element list');
stest( $t->model( 'title'), '(#PCDATA)', 'title model');
mtest( $t->model( 'section'), '\(intro\?,\s*title,\s*\(para|note\)+\)', 'section model');
stest( $t->dtd->{att}->{section}->{id}->{type}, 'ID', 'section id type');
stest( $t->dtd->{att}->{section}->{id}->{default}, '#IMPLIED', 'section id default');
exit 0;
XML-Twig-3.50/t/test_pos.t 0000755 0001750 0001750 00000002755 12346001774 015563 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use Carp;
$|=1;
# test for the various conditions in navigation methods
use XML::Twig;
my $t= XML::Twig->new;
$t->parse(
'an elementan elementan elementan elementan elementan elementan element');
my @data=;
my @data_without_comments= grep { !m{^\s*(#.*)?$} } @data;
my @test= map { s{\#.*$}{}; $_ } @data_without_comments;
#my @test= map { s{#.*$}{}; $_ } grep { !m{^\s*(#.*)?$} } ;
my $nb_test= @test;
print "1..$nb_test\n";
my $i=1;
foreach my $test (@test)
{ my( $id, $exp, $expected_pos)= split /\t+/, $test;
chomp $expected_pos;
$exp= '' if( $exp eq '_');
test( $i++, $id, $exp, $expected_pos);
}
sub test
{ my( $i, $id, $exp, $expected_pos)= @_;
my $elt= $t->elt_id( $id);
my $pos= $elt->pos( $exp);
if( $pos == $expected_pos)
{ print "ok $i\n"; }
else
{ print "not ok $i\n";
my $filter= $exp ? " filter: $exp" : '';
warn "test $i: $id $filter - expected $expected_pos, actual $pos\n";
}
}
exit 0;
__DATA__
#id exp expected
doc _ 1
doc elt1 0
doc toto 0
elt1_1 _ 1
elt1_1 elt1 1
elt1_1 toto 0
elt1_2 _ 2
elt1_2 elt1 2
elt1_2 toto 0
elt2_1 _ 4
elt2_1 elt1 0
elt2_1 elt2 1
elt2_1 toto 0
elt2_2 _ 6
elt2_2 elt1 0
elt2_2 elt2 2
elt2_2 toto 0
XML-Twig-3.50/t/test_entities.t 0000755 0001750 0001750 00000011547 12346001774 016605 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
#use diagnostics;
use XML::Twig;
$|=1;
my $TMAX=6; # do not forget to update!
print "1..$TMAX\n";
my $doc= read_data();
# test 1 : roots and twig_print_outside_roots
my $result_file= "test_entities.res1";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
my $t= XML::Twig->new( twig_roots => { elt2 => sub { $_->print} },
twig_print_outside_roots => 1,
#load_DTD => 1,
error_context => 2,
);
select RESULT;
$t->safe_parse( $doc) or die "This error is probably due to an incompatibility between
XML::Twig and the version of libexpat that you are using\n See the README and the
XML::Twig FAQ for more information\n";;
close RESULT;
select STDOUT;
check_result( $result_file, 1);
# test 2 : roots only, test during parsing
$result_file= "test_entities.res2";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t= XML::Twig->new( twig_roots => { elt2 => sub { $_->print} },
error_context => 1,
);
select RESULT;
$t->parse( $doc);
close RESULT;
select STDOUT;
check_result( $result_file, 2);
# test 3 : roots only, test parse result
$result_file= "test_entities.res3";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t= XML::Twig->new( twig_roots => { elt2 => 1 },
pretty_print => 'indented',
error_context => 1,
);
$t->parse( $doc);
$t->print( \*RESULT);
close RESULT;
check_result( $result_file, 3);
# test 4 : roots and twig_print_outside_roots
$result_file= "test_entities.res4";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t= XML::Twig->new( twig_roots => { elt2 => sub { $_->print} },
twig_print_outside_roots => 1,
keep_encoding => 1,
error_context => 1,
);
select RESULT;
$t->parse( $doc);
close RESULT;
select STDOUT;
check_result( $result_file, 4);
# test 5 : roots only, test during parsing
$result_file= "test_entities.res5";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t= XML::Twig->new( twig_roots => { elt2 => sub { $_->print} },
keep_encoding => 1,
error_context => 1,
);
select RESULT;
$t->parse( $doc);
close RESULT;
select STDOUT;
check_result( $result_file, 5);
# test 6 : roots only, test parse result
$result_file= "test_entities.res6";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t= XML::Twig->new( twig_roots => { elt2 => 1 },
pretty_print => 'indented',
keep_encoding => 1,
error_context => 1,
);
$t->parse( $doc);
$t->print( \*RESULT);
close RESULT;
check_result( $result_file, 6);
exit 0;
sub check_result
{ my( $result_file, $test_no)= @_;
# now check result
my $expected_result= read_data();
my $result= read_result( $result_file);
if( $result eq $expected_result)
{ print "ok $test_no\n"; }
else
{ print "not ok $test_no\n";
print STDERR "\ntest $test_no:\n",
"expected: \n$expected_result\n",
"real: \n$result\n";
}
}
sub read_data
{ local $/="\n\n";
my $data= ;
$data=~ s{^\s*#.*\n}{}m; # get rid of comments
$data=~ s{\s*$}{}s; # remove trailing spaces (and \n)
$data=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
return $data;
}
sub read_result
{ my $file= shift;
local $/="\n";
open( RESULT, "<$file") or die "cannot read $file: $!";
my @result= grep {m/\S/} ;
my $result= join( '', @result);
$result=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
close RESULT;
unlink $file;
return $result;
}
__DATA__
# doc 1
toto &ent1;tata &ent2;tutu &ent3;tutu &ent4;tutu &ent5;
# expected_res 1
toto &ent1;tata &ent2;tutu &ent3;tutu &ent4;tutu &ent5;
# expected_res 2
tata &ent2;tutu &ent4;
# expected_res 3
tata &ent2;tutu &ent4;
# expected_res 4
toto &ent1;tata &ent2;tutu &ent3;tutu &ent4;tutu &ent5;
# expected_res 5
tata &ent2;tutu &ent4;
# expected_res 6
tata &ent2;tutu &ent4;
XML-Twig-3.50/t/test_xml_split_w_decl.xml 0000644 0001750 0001750 00000000576 12346001774 020643 0 ustar mrodrigu mrodrigu
elt1 content 1elt1 content 2elt1 content 3elt1 content 4elt1 content 5elt1 content 6elt1 content 7elt1 content 8elt1 content 9
XML-Twig-3.50/t/test_simplify.t 0000755 0001750 0001750 00000007764 12414174534 016624 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use XML::Twig;
foreach my $module ( qw( XML::Simple Test::More Data::Dumper YAML) )
{ if( eval "require $module")
{ import $module; }
else
{ print "1..1\nok 1\n";
warn "skipping: $module is not installed\n";
exit;
}
}
if( $XML::Simple::VERSION < 2.09)
{ print "1..1\nok 1\n";
warn "skipping: need XML::Simple 2.09 or above\n";
exit;
}
undef $XML::Simple::PREFERRED_PARSER;
$XML::Simple::PREFERRED_PARSER= 'XML::Parser';
$/="\n\n";
my @doc= ;
my @options= ( { },
{ content_key => 'foo' },
{ group_tags => { templates => 'template'} },
{ group_tags => { dirs => 'dir', templates => 'template'} },
{ forcearray => 1 },
{ forcearray => [ qw(server) ] },
{ noattr => 1, },
{ noattr => 0, },
{ content_key => 'mycontent' },
{ content_key => '-mycontent' },
{ var_attr => 'var' },
{ var_attr => 'var', var_regexp => qr/\$\{?(\w+)\}?/ },
{ variables => { var => 'foo' } },
{ keyattr => [ qw(name)] },
{ keyattr => [ 'name' ] },
{ keyattr => [ qw(foo bar)] },
{ keyattr => {server => 'name' } },
{ keyattr => {server => '+name' } },
{ keyattr => {server => '-name' } },
{ normalize_space => 1 },
{ normalise_space => 2 },
{ group_tags => { f1_ar => 'f1' } },
{ group_tags => { f1_ar => 'f1', f2_ar => 'f2'} },
);
plan( tests => @options * @doc);
$SIG{__WARN__} = sub { };
foreach my $doc (@doc)
{ foreach my $options (@options)
{ (my $options_text= Dumper( $options))=~ s{\s*\n\s*}{ }g;
$options_text=~ s{^\$VAR1 = }{};
my( $options_twig, $options_simple)= UNIVERSAL::isa( $options, 'ARRAY') ?
@$options : ($options, $options);
my $t = XML::Twig->new->parse( $doc);
my $twig = $t->root->simplify( %$options_twig);
my $doc_name = $t->root->att( 'doc');
delete $options_simple->{var_regexp};
my $simple = XMLin( $doc, %$options_simple);
my $res=is_deeply( $twig, $simple, "doc: $doc_name - options: $options_text" ); #. Dump( {twig => $twig, simple => $simple}));
#exit unless( $res);
}
}
exit 0;
__DATA__
10.0.0.101
10.0.1.101
10.0.0.102
10.0.0.103
10.0.1.103
localhost/home/mrodrigu/standards${base}/tools
std_def.templ
dummy
foovar is ${var}text with spaces text with spacestext with spaces text with spaces
f1 1f1 2f2 1f2 2something0
XML-Twig-3.50/t/test_3_32.t 0000755 0001750 0001750 00000001532 12346001775 015421 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
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 $TMAX=1;
print "1..$TMAX\n";
if( $] >= 5.008)
{ # test non ascii letters at the beginning of an element name in a selector
# can't use non ascii chars in script, so the tag name needs to come from the doc!
my $doc=q{étésummerestate};
my $t= XML::Twig->parse( $doc);
my $tag= $t->root->first_child( 'tag')->text;
foreach ($t->root->children( 'elt')) { $_->set_tag( $tag); }
is( $t->root->first_child( $tag)->text, 'summer', 'non ascii letter to start a name in a condition');
}
else
{ skip( 1, "known bug in perl $]: tags starting with a non ascii letter cannot be used in expressions"); }
exit;
1;
XML-Twig-3.50/t/test_new_features_3_22.html 0000644 0001750 0001750 00000000140 12637027427 020664 0 ustar mrodrigu mrodrigu Tt t2
t3 XML-Twig-3.50/t/xmlxpath_28ancestor2.t 0000755 0001750 0001750 00000002236 12346001775 017715 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 5);
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new->parse( \*DATA);
ok( $t);
my @nodes;
@nodes = $t->findnodes( '//Footnote');
ok(@nodes, 1);
my $footnote = $nodes[0];
#@nodes = $footnote->findnodes('ancestor::*', $t);
@nodes = $footnote->findnodes( 'ancestor::*');
ok(@nodes, 3);
@nodes = $footnote->findnodes('ancestor::text:footnote', $t);
ok(@nodes, 1);
exit 0;
__DATA__
2AxKit
is very flexible in how it lets you transform the XML on the
server, and there are many modules you can plug in to AxKit to
allow you to do these transformations. For this reason, the AxKit
installation does not mandate any particular modules to use,
instead it will simply suggest modules that might help when you
install AxKit.
XML-Twig-3.50/t/test3.t 0000755 0001750 0001750 00000007525 12346001775 014766 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
# This just tests a complete twig, no callbacks
# additional tests for element creation/parse and
# space policy
# plus test for the is_pcdata method
$|=1;
use XML::Twig;
my $i=0;
my $failed=0;
my $TMAX=23; # do not forget to update!
print "1..$TMAX\n";
my $p1= XML::Twig::Elt->new( 'para', 'p1');
$p1->set_id( 'p1');
etest( $p1, 'para', 'p1', 'Element creation');
my $p2= XML::Twig::Elt->parse( 'para2');
etest( $p2, 'para', 'p2', 'Element parse');
my $s1= parse XML::Twig::Elt( 'title1para 3');
etest( $s1, 'section', 's1', 'Element parse (complex)');
my $p3= $s1->first_child( 'para');
etest( $p3, 'para', 'p3', 'Element parse (sub-element)');
my $string= "\n
para
\n
\n";
my $t1= new XML::Twig( DiscardSpacesIn => [ 'doc']);
$t1->parse( $string);
sttest( $t1->root, "
para
\n
", 'DiscardSpacesIn');
my $t2= new XML::Twig( DiscardSpacesIn => [ 'doc', 'p']);
$t2->parse( $string);
sttest( $t2->root, "
para
", 'DiscardSpacesIn');
my $t3= new XML::Twig( KeepSpaces =>1);
$t3->parse( $string);
sttest( $t3->root, $string, 'KeepSpaces');
my $t4= new XML::Twig( KeepSpacesIn =>[ 'p']);
$t4->parse( $string);
sttest( $t4->root, "
};
# used to trigger an error, now XML::Twig is fault tolerant to bad attributes
#eval { XML::Twig->nparse_e( $doc); };
#ok( $@, "error in html (nparse_e mode 2, HTB < 3.23 or >= 4.00: $@)");
is_like( XML::Twig->nparse_e( $doc)->sprint,
'
dummy
',
'wrong attributes, nparse_e mode 2, HTB < 3.23 or >= 4.00'
);
}
{ my $doc=qq{
dummy
};
# used to trigger an error, now XML::Twig is fault tolerant to bad attributes
#eval { XML::Twig->nparse_e( $doc); };
#ok( $@, "error in html (nparse_e mode 3, HTB < 3.23 or >= 4.00: $@)");
is_like( XML::Twig->nparse_e( $doc)->sprint,
'
dummy
',
'wrong attributes, nparse_e mode 2, HTB < 3.23 or >= 4.00'
);
}
}
else
{ skip( 4 => "need HTML::TreeBuilder > 4.00 to test error display with HTML data"); }
{ my $e= XML::Twig::Elt->new( 'e');
is( $e->tag_to_span->sprint, '', "tag_to_span");
is( $e->tag_to_span->sprint, '', "tag_to_span again ");
is( $e->tag_to_div->sprint, '', "tag_to_div");
is( $e->tag_to_div->sprint, '', "tag_to_div again ");
}
# added coverage
{ my $doc= "\n";
my $t= XML::Twig->nparse( $doc);
(my $expected= $doc)=~ s{foo}{bar};
$t->root->first_child( '#CDATA')->set_content( ' bar ');
is( $t->root->sprint , $expected, 'set_content on a CDATA element');
}
{ my $doc= "
\n\n", 'sprint br with pretty_print indented');
is( $t->root->sprint( { pretty_print => 'none' } ) , $doc, 'sprint br with pretty_print none');
}
{ my $doc='&';
my $t= XML::Twig->new;
$t->set_keep_encoding( 1);
is( $t->parse( $doc)->sprint, $doc, 'set_keep_encoding(1)');
$t->set_keep_encoding( 0);
is( $t->parse( $doc)->sprint, $doc, 'set_keep_encoding(1)');
}
{ my $doc='';
is( XML::Twig->nparse( quote => 'single', $doc)->sprint, q{}, 'quote option');
}
{ my $doc= qq{]>\n};
(my $expected= $doc)=~ s{ \[.*?\]}{};
my $t= XML::Twig->nparse( $doc);
my $entity_list = $t->entity_list;
foreach my $entity ($entity_list->list()) { $entity_list->delete($entity->name); }
is( $t->sprint( Update_DTD => 1 ), $expected, 'parse entities with all chars in their name');
}
{ my $tmp= "tmp";
foreach my $doc ( qq{]>},
qq{},
qq{},
)
{ foreach my $keep_encoding ( 0..1)
{ open( MYOUT, ">$tmp") or die "cannot open $tmp: $!";
my $t= XML::Twig->new( twig_roots=> { dummy => sub {} },
twig_print_outside_roots => \*MYOUT,
keep_encoding => $keep_encoding,
)
->parse( $doc);
close MYOUT;
is_like( slurp( $tmp), $doc, "file with no DTD but entities (keep_encoding: $keep_encoding)");
unlink $tmp;
}
}
}
{ my $doc=qq{foobarbaztoto tutu};
my $t= XML::Twig->parse( $doc);
is( $t->elt_id( "e1")->text( 'no_recurse'), 'foobaz', "text_only");
is( $t->elt_id( "e2")->text_only, 'toto tata tutu', "text_only (cdata section)");
is( $t->elt_id( "e")->text_only, 'bar', "text_only (no embedded elt)");
}
{ my $doc=qq{tutu <&ent; notata};
my $t= XML::Twig->parse( $doc);
is( $t->elt_id( "e1")->text(), 'tutu <&ent; notata', "text wih ent");
is( $t->elt_id( "e1")->text( 'no_recurse'), 'tutu <&ent; tata', "text no_recurse wih ent");
is( $t->elt_id( "e1")->xml_text( ), 'tutu <&ent; notata', "xml_text wih ent");
is( $t->elt_id( "e1")->xml_text( 'no_recurse'), 'tutu <&ent; tata', "xml_text no_recurse wih ent");
}
if( $] > 5.008)
{ my $r;
XML::Twig->parse( twig_handlers => { '/a/b//c' => sub { $r++; } },
q{foo}
);
ok( $r, "handler condition with // and nested elts (/a//b/c)");
}
else
{ skip( 1, "not tested under perl < 5.8"); }
if( $] > 5.008)
{ my @r;
XML::Twig->parse( twig_handlers => { 's[@#a="1"]' => sub { push @r, $_->id},
's/e[@x="1"]' => sub { $_->parent->set_att( '#a' => 1); },
},
q{},
);
is( join( ':', @r), 's2:s3', 'inner handler changing parent attribute value');
}
else
{ skip( 1, "not tested under perl < 5.8"); }
if( $] > 5.008)
{ my @r;
XML::Twig->parse( twig_roots => { '/d/s[@a="1"]/e[@a="1"]' => => sub { push @r, $_->id}, },
q{},
);
is( join( ':', @r), 'e3:e8', 'complex condition with twig_roots');
}
else
{ skip( 1, "not tested under perl < 5.8"); }
exit 0; # or you get a weird error under 5.6.2
XML-Twig-3.50/t/pod_coverage.t 0000755 0001750 0001750 00000000615 12346001774 016351 0 ustar mrodrigu mrodrigu #!/usr/bin/perl
use strict;
use warnings;
if( ! $ENV{TEST_AUTHOR} ) { print "1..1\nok 1\n"; warn "Author test. Set \$ENV{TEST_AUTHOR} to a true value to run.\n"; exit; }
eval "use Test::Pod::Coverage 1.00 tests => 1";
if( $@)
{ print "1..1\nok 1\n";
warn "Test::Pod::Coverage 1.00 required for testing POD coverage";
exit;
}
pod_coverage_ok( "XML::Twig", { trustme => [ 'isa' ] });
XML-Twig-3.50/t/test_meta_json.t 0000755 0001750 0001750 00000000223 12346001775 016726 0 ustar mrodrigu mrodrigu use Test::More;
eval "use Test::CPAN::Meta::JSON";
plan skip_all => "Test::CPAN::Meta::JSON required for testing META.json" if $@;
meta_json_ok();
XML-Twig-3.50/t/xmlxpath_09string_length.t 0000755 0001750 0001750 00000001032 12346001774 020653 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 5);
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new->parse( \*DATA);
ok( $t);
my @nodes;
@nodes = $t->findnodes( '//*[string-length(name()) = 3]');
ok(@nodes, 2);
@nodes = $t->findnodes( '//*[string-length(name()) < 3]');
ok(@nodes, 2);
@nodes = $t->findnodes( '//*[string-length(name()) > 3]');
ok(@nodes, 3);
exit 0;
__DATA__
XML-Twig-3.50/t/xmlxpath_08name.t 0000755 0001750 0001750 00000001052 12346001774 016725 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 5);
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new->parse( \*DATA);
ok( $t);
my @nodes;
@nodes = $t->findnodes( '//*[name() = "BBB"]');
ok(@nodes, 5);
@nodes = $t->findnodes( '//*[starts-with(name(), "B")]');
ok(@nodes, 7);
@nodes = $t->findnodes( '//*[contains(name(), "C")]');
ok(@nodes, 3);
exit 0;
__DATA__
XML-Twig-3.50/t/test_mark.t 0000755 0001750 0001750 00000004622 12346001774 015707 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
# test the mark method
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 @data= map { chomp; [split /\t+/] } ;
my $TMAX= 2 * @data;
print "1..$TMAX\n";
foreach my $test (@data)
{ my( $doc, $regexp, $elts, $hits, $result)= @$test;
(my $quoted_elts= $elts)=~ s{(\w+)}{'$1'}g;
my @elts= eval( "($quoted_elts)");
my $t= XML::Twig->new->parse( $doc);
my $root= $t->root;
my @hits= $root->mark( $regexp, @elts);
is( $t->sprint, $result, "mark( /$regexp/, $quoted_elts) on $doc");
is( scalar @hits, $hits, 'nb hits');
}
exit 0;
# doc regexp elts hits result
__DATA__
text X (X) s 1 text Xtext X X s 1 text text X s 0 texttext (X) s 0 texttext X X s 1 text text X (X) s 1 text Xtext X \s*X\s* s 1 texttext X \s*(X)\s* s 1 textXtext X (\s*X\s*) s 1 text X text X text X s 1 text texttext X text (X) s 1 text X texttext X text \s*X\s* s 1 texttexttext X text \s*(X)\s* s 1 textXtexttext X text (\s*X\s*) s 1 text X texttext XX X s 2 text text XX (X) s 2 text XXtext X X X s 2 text text X X (X) s 2 text XXtext XX text X s 2 text texttext XX text (X) s 2 text XX texttext XY text Y text X ([XY]+) s 3 text XY text Y text Xtext X X s, {a => 1} 1 text text X (X) s, {a => 1, b => 2} 1 text Xtext X1Y2 text X0 Y0X3Y4 text X X(\d)Y(\d) s 4 text 12 text X0 Y034 text X
XML-Twig-3.50/t/test_3_48.t 0000755 0001750 0001750 00000000370 12346001775 015427 0 ustar mrodrigu mrodrigu #!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use Test::More tests => 1;
use utf8;
{
XML::Twig::_disallow_use( 'Tie::IxHash');
my $t;
eval { $t= XML::Twig->new( keep_atts_order => 0); };
ok( $t, 'keep_atts_order => 0');
}
exit;
XML-Twig-3.50/t/xmlxpath_09a_string_length.t 0000755 0001750 0001750 00000001276 12346001775 021166 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 5);
use XML::Twig::XPath;
my $doc_one = qq|para one|;
my $t= XML::Twig::XPath->new( keep_spaces => 1);
$t->parse( $doc_one);
ok( $t);
my $doc_one_chars = $t->find( 'string-length(/doc/text())');
ok($doc_one_chars == 0, 1);
my $doc_two = qq|
para one has bold text
|;
$t->parse( $doc_two);
ok( $t);
my $doc_two_chars = $t->find( 'string-length(/doc/text())');
ok($doc_two_chars == 3, 1);
my $doc_two_para_chars = $t->find( 'string-length(/doc/para/text())');
ok($doc_two_para_chars == 13, 1);
exit 0;
XML-Twig-3.50/t/xmlxpath_26predicate.t 0000755 0001750 0001750 00000000743 12346001775 017754 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 4);
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new->parse( \*DATA);
ok( $t);
my @bbb = $t->findnodes( '//a/b[2]');
ok(@bbb, 2);
@bbb = $t->findnodes( '(//a/b)[2]');
ok(@bbb, 1);
exit 0;
__DATA__
some 1value 1some 2value 2
XML-Twig-3.50/t/test_xml_split_entities.xml 0000644 0001750 0001750 00000000163 12346001775 021223 0 ustar mrodrigu mrodrigu text with < > & and ' & and ']]>
XML-Twig-3.50/t/test_xpath_cond.t 0000755 0001750 0001750 00000006131 12346001774 017101 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
my $t= XML::Twig->new;
$t->parse(
'elt 1elt 2elt 323
<:elt id=":elt">yep, that is a valid name
');
my @data= grep { !/^##/ && m{\S} } ;
my @exp;
my %result;
foreach( @data)
{ chomp;
my ($exp, $id_list) = split /\s*=>\s*/ ;
$id_list=~ s{\s+$}{};
$result{$exp}= $id_list;
push @exp, $exp;
}
my $nb_tests= keys %result;
print "1..$nb_tests\n";
my $i=1;
foreach my $exp ( @exp)
{ my $expected_result= $result{$exp};
my @result= $t->get_xpath( $exp);
my $result;
if( @result)
{ $result= join ' ', map { $_->id || $_->gi } @result; }
else
{ $result= 'none'; }
if( $result eq $expected_result)
{ print "ok $i\n"; }
else
{ print "not ok $i\n";
print STDERR "$exp: expected '$expected_result' - real '$result'\n";
}
$i++;
}
exit 0;
__DATA__
/elt => none
/elt[@foo="bar"] => none
/*[@foo="bar"] => none
//*[@foo="bar"] => none
/* => doc
/*[@id="doc"] => doc
//*[@id="doc"] => doc
//elt => elt-1 elt-2 elt-3
//*/elt => elt-1 elt-2 elt-3
/doc/elt => elt-1 elt-2
/*/elt => elt-1 elt-2
/doc/elt[ last()] => elt-2
/doc/*[ last()] => :elt
//elt[@id='elt-1'] => elt-1
//*[@id='elt-1'] => elt-1
//[@id='elt-1'] => elt-1
//elt[@id='elt-1' or @id='elt-2'] => elt-1 elt-2
//elt[@id='elt-1' and @id='elt-2'] => none
//elt[@id='elt-1' and @id!='elt-2'] => elt-1
//elt[@id=~ /elt/] => elt-1 elt-2 elt-3
//[@id='elt-1' or @id='elt-2'] => elt-1 elt-2
//[@id='elt-1' and @id='elt-2'] => none
//[@id='elt-1' and @id!='elt-2'] => elt-1
//[@id=~ /elt/] => elt-1 elt-2 elt2-1 elt-3 elt2-2 elt2-3 elt2-4 :elt
//*[@id='elt-1' or @id='elt-2'] => elt-1 elt-2
//*[@id='elt-1' and @id='elt-2'] => none
//*[@id='elt-1' and @id!='elt-2'] => elt-1
//*[@id=~ /elt/] => elt-1 elt-2 elt2-1 elt-3 elt2-2 elt2-3 elt2-4 :elt
//elt2[@att_int > 2] => elt2-4
/doc/elt2[ last()]/* => elt2-3 elt2-4
//*[@id=~/elt2/] => elt2-1 elt2-2 elt2-3 elt2-4
/doc/*[@id=~/elt2/] => elt2-1 elt2-2
/doc//*[@id=~/elt2/] => elt2-1 elt2-2 elt2-3 elt2-4
//*[@id=~/elt2-[34]/] => elt2-3 elt2-4
//*[@id!~/^elt/] => doc :elt
//[@id=~/elt2-[34]/] => elt2-3 elt2-4
//[@id!~/elt2-[34]/] => doc elt-1 elt-2 elt2-1 elt-3 elt2-2 :elt
//elt2[@id=~/elt2-[34]/] => elt2-3 elt2-4
//*[@id!~/elt2-[34]/] => doc elt-1 elt-2 elt2-1 elt-3 elt2-2 :elt
//:elt => :elt
//elt[string()="elt 1"] => elt-1
//elt[string()=~/elt 1/] => elt-1
//elt[string()=~/^elt 1/] => elt-1
//*[string()="elt 1"] => elt-1 #PCDATA
//*[string()=~/elt 1/] => doc elt-1 #PCDATA
//*[string()=~/^elt 1/] => doc elt-1 #PCDATA
//[string()="elt 1"] => elt-1 #PCDATA
//[string()=~/elt 1/] => doc elt-1 #PCDATA
//[string()=~/^elt 1/] => doc elt-1 #PCDATA
//[string()="elt 2"] => elt-2 #PCDATA
//[string()=~/elt 2/] => doc elt-2 #PCDATA
//[string()=~/^elt 2/] => elt-2 #PCDATA
XML-Twig-3.50/t/test_bugs_3_15.t 0000755 0001750 0001750 00000012316 12346001774 016443 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
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 $TMAX=17;
print "1..$TMAX\n";
{ # test bug outputing end tag with pretty_print => nsgmls on
my $out= XML::Twig->new( pretty_print => 'nsgmls')->parse( "text")->sprint;
ok( XML::Twig->new( error_context => 1)->safe_parse( $out), "end tag with nsgmls option" . ($@ || '') );
}
{ # test bug RT #8830: simplify dies on mixed content
ok( XML::Twig->new->parse( "text1")->root->simplify, "simplify mixed content");
}
{ # testing to see if bug RT #7523 is still around
my $t= XML::Twig->new->parse( '');
if( eval( '$t->iconv_convert( "utf8");'))
{ $t->set_output_encoding( 'utf8');
eval { $t->sprint;};
ok( !$@, 'checking bug RT 7523');
}
else
{ if( $@=~ m{^Can't locate Text/Iconv.pm} || $@=~ m{^Text::Iconv not available} )
{ skip( 1, "Text::Iconv not available"); }
elsif( $@=~ m{^Unsupported (encoding|conversion): utf8})
{ skip( 1, "your version of iconv does not support utf8"); }
else
{ skip( 1, "odd error creating filter with iconv: $@"); }
}
}
{ # bug on comments
my $doc= "\n \n foo\n\n";
my $t= XML::Twig->new( comments => 'keep', pretty_print => 'indented')
->parse( $doc);
is( $t->sprint => $doc, "comment with comments => 'keep'");
}
{ # bug with disapearing entities in attributes
my $text= '&ent3;';
my $doc= qq{]>$text};
XML::Twig::Elt::init_global_state();
my $regular=XML::Twig->new( pretty_print => 'none')->parse( $doc)->root->sprint;
(my $expected= $text)=~ s{&(uuml|ent2);}{}g; # yes, entities in attributes just vanish!
is( $regular => $expected, "entities in atts, no option");
XML::Twig::Elt::init_global_state();
my $with_keep=XML::Twig->new(keep_encoding => 1)->parse( $doc)->root->sprint;
is( $with_keep => $text, "entities in atts with keep_encoding");
XML::Twig::Elt::init_global_state();
my $with_dneaia=XML::Twig->new(do_not_escape_amp_in_atts => 1)->parse( $doc)->root->sprint;
if( $with_dneaia eq '&ent3;')
{ skip( 1, "option do_not_escape_amp_in_atts not available (it's only available in an old version of expat), no worries"); }
else
{ is( $with_dneaia => $text, "entities in atts with do_not_escape_amp_in_atts"); }
# checking that all goes back to normal
XML::Twig::Elt::init_global_state();
$regular=XML::Twig->new()->parse( $doc)->root->sprint;
is( $regular => $expected, "entities in atts, no option");
}
# bug on xmlns in path expression trigger
{ my $matched=0;
my $twig = XML::Twig->new( map_xmlns => { uri1 => 'aaa', },
twig_handlers => { '/aaa:doc/aaa:elt' => sub { $matched=1; } }
)
->parse( q{});
ok( $matched, "using name spaces in path expression trigger");
$matched=0;
$twig = XML::Twig->new( map_xmlns => { uri1 => 'aaa', },
twig_handlers => { 'aaa:doc/aaa:elt' => sub { $matched=1; } }
)
->parse( q{});
ok( $matched, "using name spaces in partial path expression trigger");
}
# bug where the leading spaces are discarded in an element like
foobar
{ # check that leading spaces after a \n are discarded
my $doc= "
\n foo\n
";
my $expected= "
foo
";
my $result= XML::Twig->new->parse( $doc)->sprint;
is( $result => $expected, 'leading spaces kept when not after a \n');
}
{
# check that leading spaces NOT after a \n are kept around
my $doc= "
foobar
";
my $result= XML::Twig->new->parse( $doc)->sprint;
is( $result => $doc, 'leading spaces kept when not after a \n');
}
{
my $t= XML::Twig->new->parse( " elt 1 elt 2 ");
is( scalar $t->descendants( '#PCDATA'), 3, 'properly parsed pcdata');
}
{
my $t= XML::Twig->new->parse( "\n elt 1 \n elt 2 \n");
is( scalar $t->descendants( '#PCDATA'), 2, 'properly parsed pcdata');
}
{ # bug RT 8137
my $doc= q{};
(my $expected= $doc)=~ s{ }{ };
is( XML::Twig->new( keep_encoding => 1)->parse( $doc)->sprint, $expected,
'keep_encoding and 2 spaces between gi and attribute'
);
}
{ # copy of an element with extra_data_before_end_tag
my $doc= 'datamore';
my $expected= 'datamore'; # pi's are not being moved around anymore
my $elt= XML::Twig->new( pi => 'keep')->parse( $doc)->root->copy;
is( $elt->sprint, $expected, 'copy of an element with extra_data_before_end_tag');
}
{ # copy of an element with extra_data_before_end_tag
my $doc= '';
my $elt= XML::Twig->new( pi => 'keep')->parse( $doc)->root->copy;
is( $elt->sprint, $doc, 'copy of an element with extra_data_before_end_tag');
}
XML-Twig-3.50/t/xmlxpath_10pipe.t 0000755 0001750 0001750 00000001055 12346001774 016736 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use FindBin qw($Bin); BEGIN { unshift @INC, $Bin; } use xmlxpath_tools;
use Test;
plan( tests => 6);
use XML::Twig::XPath;
ok(1);
my $t= XML::Twig::XPath->new->parse( \*DATA);
ok( $t);
my @nodes;
@nodes = $t->findnodes( '//CCC | //BBB');
ok(@nodes, 3);
ok($nodes[0]->getName, "BBB"); # test document order
@nodes = $t->findnodes( '/AAA/EEE | //BBB');
ok(@nodes, 2);
@nodes = $t->findnodes( '/AAA/EEE | //DDD/CCC | /AAA | //BBB');
ok(@nodes, 4);
exit 0;
__DATA__
XML-Twig-3.50/t/test_new_features_3_18.t 0000755 0001750 0001750 00000011261 12346001774 020173 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
my $DEBUG=0;
print "1..44\n";
{ # test tag regexp handler
my @res;
my $doc=q{};
my $handlers= { qr/^foo_/ => sub { push @res, $_->tag; },
foo_f2 => sub { push @res, uc $_->tag; 0 },
};
my $expected= 'foo_f1:FOO_F2:foo_f1:foo_f3';
XML::Twig->new( twig_handlers => $handlers)->parse( $doc);
my $res= join( ':', @res);
is( $res, $expected, "tag regexp handlers");
}
{ # test tag regexp handler with i modifier
my @res;
my $doc=q{};
my $handlers= { qr/^foo_/i => sub { push @res, $_->tag; },
foo_f2 => sub { push @res, uc $_->tag; 0 },
};
my $expected= 'foo_f1:FOO_F2:foo_f1:foo_f3:FOO_f4';
XML::Twig->new( twig_handlers => $handlers)->parse( $doc);
my $res= join( ':', @res);
is( $res, $expected, "tag regexp handlers");
}
{ # test tag regexp handler with all modifier
my @res;
my $doc=q{};
my $handlers= { qr/^foo_/xism => sub { push @res, $_->tag; },
foo_f2 => sub { push @res, uc $_->tag; 0 },
};
my $expected= 'foo_f1:FOO_F2:foo_f1:foo_f3:FOO_f4';
XML::Twig->new( twig_handlers => $handlers)->parse( $doc);
my $res= join( ':', @res);
is( $res, $expected, "tag regexp handlers");
}
{ # testing last_descendant
my $t= XML::Twig->new->parse( 't_e_3t_e_1t_e_2t_n
'
);
my %exp2id= ( '' => 't_n',
'n' => 'n1',
'#ELT' => 'n1',
'e' => 'e2',
'e[@id="e1"]' => 'e1',
'e2' => undef,
);
foreach my $exp (sort keys %exp2id)
{ my $expected= $exp2id{$exp};
is( result( $t->last_elt( $exp)), $expected, "last_elt( $exp)");
is( result( $t->root->last_descendant( $exp)), $expected, "last_descendant( $exp)");
}
# some more tests to check that we stay in te subtree and that we get the last descendant if it is itself
is( result( $t->last_elt( 'e3')), 'e3', 'last_elt( e3)');
is( result( $t->root->last_descendant( 'e3')), 'e3', 'last_descendant( e3)');
is( result( $t->root->first_child( 'e3')->last_descendant( 'e3')), 'e3', 'last_descendant( e3) (on e3)');
is( result( $t->root->first_child( 'e3')->last_descendant()), 't_e_3', 'last_descendant() (on e3)');
is_undef( $t->root->last_child->last_descendant( 'e3'), 'last_descendant (no result)');
is( result( $t->root->first_child( 'e4')->last_descendant( 'e4')), 'e4', 'last_descendant( e4) (on e4)');
is( result( $t->root->first_child( 'e4')->last_descendant( )), 'e4', 'last_descendant( ) (on e4)');
sub result
{ my( $elt)= @_;
return undef unless $elt;
return $elt->id || $elt->text;
}
}
{# testing trim
my $expected;
while( )
{ chomp;
next unless( m{\S});
if( s{^#}{}) { $expected= $_; }
is( XML::Twig->new->parse( $_)->trim->root->sprint, $expected, "trimming '$_'");
}
}
{ # testing children_trimmed_text
my $t = XML::Twig->new;
$t->parse(" hell foo o, \n world");
is( join( ':', $t->root->children_trimmed_text("e")), "hell:o, world" , "children_trimmed_text (list context)");
my $scalar= $t->root->children_trimmed_text("e");
is( $scalar, "hello, world" , "children_trimmed_text (scalar context)");
is( join( ':', $t->root->children_text("e")), " hell : o, \n world" , "children_text (list context)");
$scalar= $t->root->children_text("e");
is( $scalar, " hell o, \n world" , "children_text (scalar context)");
}
__DATA__
#text1 text2 text1 text2 text1 text2text1 text2 text1 text2 text1 text2 text1 text2 text1 text2 text1 text2
#text1 text2 text3text1 text2 text3
#text1 text2 text3text1 text2 text3
#
#text hah! yep text hah! yep
XML-Twig-3.50/t/test_3_35.t 0000755 0001750 0001750 00000004637 12346001774 015434 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
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 $TMAX=10;
print "1..$TMAX\n";
# escape_gt option
{
is( XML::Twig->parse( '')->root->insert_new_elt( '#COMMENT' => '- -- -')->twig->sprint,
'', 'comment escaping');
}
{ my $t= XML::Twig->parse( 'foobarbazfoobarbaz2foobar2');
$t->root->cut_descendants( 'e[@a="c"]');
is( $t->sprint, 'bazfoobarbaz2', 'cut_descendants');
}
{ my $t=XML::Twig->new( pretty_print => 'none')->parse( '');
is( $t->root->_pretty_print, 0, '_pretty_print');
$t->set_pretty_print( 'indented');
is( $t->root->_pretty_print, 3, '_pretty_print');
}
# additional tests to increase coverage
{ is( XML::Twig->parse( no_expand => 1, q{]>&foo;})->root->sprint, "&foo;\n", 'external entities with no_expand');
}
{ my $doc= q{fi4};
open( my $fh, '>', 'tmp_file');
my $t= XML::Twig->new( twig_handlers => { e => sub { $_->flush( $fh); },
g => sub { is( $_[0]->elt_id( 'i4')->text, 'fi4', 'elt_id, id exists');
nok( $_[0]->elt_id( 'i3'), 'elt_id, id flushed');
},
}
)
->parse( $doc);
}
{ my $xpath='';
XML::Twig->parse( map_xmlns => { "http://foo.com" => 'bar' },
twig_handlers => { "bar:e" => sub { $xpath= $_[0]->path( $_->gi);}, },
q{}
);
is( $xpath, '/bar:d/bar:e');
XML::Twig->parse( map_xmlns => { "http://foo.com" => 'bar' },
twig_handlers => { "bar:e" => sub { $xpath= $_[0]->path( $_->local_name);}, },
q{}
);
is( $xpath, '/bar:d/bar:e');
}
{ my $t=XML::Twig->parse( pretty_print => 'none', '');
$t->first_elt( 'e3')->replace( $t->first_elt( 'e1'));
is( $t->sprint, '', 'replace called on an element that has not been cut yet');
}
1;
XML-Twig-3.50/t/test_autoencoding_conversion.t 0000755 0001750 0001750 00000002237 12346001775 021702 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
#
use strict;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
print "1..2\n";
if( $] < 5.008)
{ skip( 2, "needs perl 5.8 or above to test auto conversion"); }
elsif( $ENV{PERL_UNICODE} && $ENV{PERL_UNICODE}=~ m{SA})
{ skip( 2, 'auto conversion does not happen when $PERL_UNICODE set to SA'); }
else
{ _use( 'Encode');
my $char_utf8 = qq{\x{e9}};
my $char_latin1 = encode("iso-8859-1", $char_utf8);
my $doc_utf8 = qq{$char_utf8};
my $doc_latin1 = qq{$char_latin1};
my $file_utf8 = "doc_utf8.xml";
spit( $file_utf8, $doc_utf8);
my $file_latin1 = "doc_latin1.xml";
spit( $file_latin1, $doc_latin1);
my( $q, $q2) = ( ($^O eq "MSWin32") || ($^O eq 'VMS') ) ? ('"', "'") : ("'", '"');
my $lib= File::Spec->catfile( 'blib', 'lib');
my $run_it=qq{$^X -I $lib -MXML::Twig -e$q print XML::Twig->parse( $q2$file_latin1$q2)->root->text$q};
my $parsed= `$run_it`;
is( $parsed, $char_utf8, 'testing auto transcoding of latin1 output');
is( $parsed, $char_latin1, 'testing auto transcoding of latin1 output');
}
XML-Twig-3.50/t/test_comment_handler.t 0000755 0001750 0001750 00000003572 12346001774 020117 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use Carp;
# test for the various conditions in navigation methods
use XML::Twig;
if( $] < 5.008)
{ warn "skipped, not tested under perl < 5.8\n"; print "1..1\nok 1\n"; exit 0; }
my $nb_tests=4;
print "1..$nb_tests\n";
{
my $result;
my $t= XML::Twig->new( comments => 'process',
twig_handlers => { '#COMMENT' => sub { $result .=$_->text; } },
);
$t->parse( q{});
my $expected= ' comment in doc ';
if( $result eq $expected)
{ print "ok 1\n"; }
else
{ print "not ok 1\n";
warn "expected: $expected\nfound : $result\n";
}
}
{
my $result='';
my $t= XML::Twig->new( comments => 'process',
twig_handlers => { '#COMMENT' => sub { $result .=$_->text; } },
);
$t->parse( q{});
my $expected= ' comment in doc ';
if( $result eq $expected)
{ print "ok 2\n"; }
else
{ print "not ok 2\n";
warn "expected: $expected\nfound : $result\n";
}
}
{
my $result='';
my $t= XML::Twig->new( twig_handlers => { 'doc' => sub { $result= $_->{extra_data}; } },);
$t->parse( q{});
my $expected= '';
if( $result eq $expected)
{ print "ok 3\n"; }
else
{ print "not ok 3\n";
warn "expected: $expected\nfound : $result\n";
}
}
{
my $result='';
my $t= XML::Twig->new( comments => 'process',
twig_roots => { '/#COMMENT' => sub { $result= $_->{extra_data}; },
elt => sub { },
});
$t->parse( q{});
my $expected= ''; # This is a bug!
if( $result eq $expected)
{ print "ok 4\n"; }
else
{ print "not ok 4\n";
warn "expected: $expected\nfound : $result\n";
}
}
exit 0;
XML-Twig-3.50/t/test_twig_roots.t 0000755 0001750 0001750 00000017254 12346001774 017162 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
#use diagnostics;
use XML::Twig;
$|=1;
my $TMAX=12; # do not forget to update!
print "1..$TMAX\n";
$/= "\n\n";
my $t= XML::Twig->new( twig_roots => { },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 1);
$t= XML::Twig->new( twig_roots => { elt2 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 2);
$t= XML::Twig->new( twig_roots => { elt3 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 3);
$t= XML::Twig->new( twig_roots => { },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 4);
$t= XML::Twig->new( twig_roots => { elt2 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 5);
$t= XML::Twig->new( twig_roots => { elt3 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 6);
$t= XML::Twig->new( twig_roots => { },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 7);
$t= XML::Twig->new( twig_roots => { elt2 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 8);
$t= XML::Twig->new( twig_roots => { elt3 => sub { } },
twig_print_outside_roots => \*RESULT,
error_context => 1,
);
test_twig( $t, 9);
$t= XML::Twig->new( twig_roots => { elt => sub { print RESULT "elt handler called on ", $_->gi, "\n"; }, },
start_tag_handlers => { doc => sub { print RESULT "start tag handler called on ", $_->gi, "\n"; }, },
end_tag_handlers => { doc => sub { print RESULT "end tag handler called on $_[1]\n"; }, },
);
test_twig( $t, 10);
# test with doc root as root
$t= XML::Twig->new( twig_roots => { doc => sub { $_->print( \*RESULT); } });
test_twig( $t, 11);
# test with elt as root
$t= XML::Twig->new( twig_roots => { elt => sub { $_->print( \*RESULT); } });
test_twig( $t, 12);
exit 0;
sub test_twig
{ my( $t, $test_nb)= @_;
my $doc= read_doc();
my $expected_result= read_expected_result();
my $result_file= "test_twig_roots.res1";
open( RESULT, ">$result_file") or die "cannot create $result_file: $!";
$t->parse( $doc);
check_result( $result_file, $test_nb, $expected_result);
close RESULT;
}
sub check_result
{ my( $result_file, $test_no, $expected_result)= @_;
# now check result
my $result= read_result( $result_file);
if( $result eq $expected_result)
{ print "ok $test_no\n"; }
else
{ print "not ok $test_no\n";
print STDERR "\ntest $test_no:\n",
"expected: \n$expected_result\n",
"real: \n$result\n";
}
}
{ my $last_doc;
my $buffered_result;
sub read_doc
{ local $/="\n\n";
my $doc= ;
# if the data starts with #doc then it's a doc, otherwise use the previous one
if( $doc=~ /^\s*#\s*doc/)
{ $doc= clean_data( $doc);
$last_doc= $doc;
$buffered_result='';
return $doc;
}
else
{ $buffered_result= clean_data( $doc);
return $last_doc;
}
}
sub read_expected_result
{ if( $buffered_result)
{ return $buffered_result; }
else
{ local $/="\n\n";
my $expected_result= ;
$expected_result= clean_data( $expected_result);
return $expected_result;
}
}
}
sub clean_data
{ my $data= shift;
$data=~ s{^\s*#.*\n}{}m; # get rid of comments
$data=~ s{\s*$}{}s; # remove trailing spaces (and \n)
$data=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
return $data;
}
sub read_result
{ my $file= shift;
local $/="\n";
open( RESULT, "<$file") or die "cannot read $file: $!";
my @result= grep {m/\S/} ;
my $result= join( '', @result);
$result=~ s{(^|\n)\s*(\n|$)}{}g; # remove empty lines
close RESULT;
unlink $file;
return $result;
}
__DATA__
# doc 1
text subelt textanother elt textan other type of element text of subelt
# expected_res 1
text subelt textanother elt textan other type of element text of subelt
# expected_res 2
text subelt textanother elt text text of subelt
# expected_res 3
text subelt textanother elt textan other type of element
# doc 2
text subelt textanother elt textan other type of element text of subelt
# expected_res 4
text subelt textanother elt textan other type of element text of subelt
# expected_res 5
text subelt textanother elt text text of subelt
# expected_res 6
text subelt textanother elt textan other type of element
# doc 3
text subelt textanother elt textan other type of element text of subelt
# expected_res 7
text subelt textanother elt textan other type of element text of subelt
# expected_res 8
text subelt textanother elt text text of subelt
# expected_res 9
text subelt textanother elt textan other type of element
# doc 4
# expected_res 10
start tag handler called on doc
elt handler called on elt
end tag handler called on doc
# expected_res 11
# expected_res 12
XML-Twig-3.50/t/test_class_methods.t 0000755 0001750 0001750 00000004167 12346001774 017611 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
# testing methods on class attribute:
# class set_class add_to_class att_to_class add_att_to_class move_att_to_class
# tag_to_class add_tag_to_class set_tag_class in_class
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
use XML::Twig;
my $DEBUG=0;
my $TMAX=26;
print "1..$TMAX\n";
{
my $root= XML::Twig->new->parse( q{})->root;
nok( $root->class, "no class");
$root->set_class( 'foo');
is( $root->class, 'foo', 'set_class');
$root->set_class( 'bar');
is( $root->class, 'bar', 'set_class');
ok( $root->in_class( 'bar'), 'in_class (ok)');
nok( $root->in_class( 'foo'), 'in_class (nok)');
$root->add_to_class( 'foo');
ok( $root->in_class( 'bar'), 'in_class (ok)');
ok( $root->in_class( 'foo'), 'in_class (ok)');
nok( $root->in_class( 'baz'), 'in_class (nok)');
$root->tag_to_class;
is( $root->class, 'doc', 'tag_to__class');
ok( $root->in_class( 'doc'), 'in_class (ok)');
nok( $root->in_class( 'foo'), 'in_class (nok)');
$root->tag_to_class;
is( $root->class, 'doc', 'tag_to_class (with existing class)');
$root->add_tag_to_class;
is( $root->class, 'doc', 'add_tag_to_class');
$root->att_to_class( 'att1');
is( $root->class, 'val1', 'att_to_class');
$root->att_to_class( 'att1');
is( $root->class, 'val1', 'att_to_class (with existing class)');
$root->add_att_to_class( 'att');
is( $root->class, 'val1', 'att_to_class (non existing att)');
$root->add_att_to_class( 'att2');
is( $root->class, 'val1 val2', 'att_to_class (2 classes now)');
ok( $root->in_class( 'val1'), 'in_class');
ok( $root->in_class( 'val2'), 'in_class');
nok( $root->in_class( 'val'), 'in_class (nok)');
$root->set_tag_class( 'new');
is( $root->sprint, '', 'set_tag_class');
$root->move_att_to_class( 'att2');
is( $root->sprint, '', 'set_tag_class');
ok( $root->matches( '.doc'), 'match on class (first)');
ok( $root->matches( '.val1'), 'match on class (middle)');
ok( $root->matches( '.val2'), 'match on class (last)');
nok( $root->matches( '.val'), 'match on class (not good)');
}
exit 0;
XML-Twig-3.50/t/test_class_selector.t 0000755 0001750 0001750 00000003145 12346001775 017762 0 ustar mrodrigu mrodrigu #!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,'t');
use tools;
my @DATA;
while( ) { chomp; my( $cond, $expected)= split /\s*=>\s*/; push @DATA, [$cond, $expected]; }
my $TMAX= 20;
print "1..$TMAX\n";
my $doc=q{e1e2e3};
my $doc_dot=q{wrong e1wrong e2wrong e3e1e2e3};
my $t= XML::Twig->parse( $doc);
foreach my $test (@DATA)
{ my( $cond, $expected)= @$test;
my $got= join '', map { $_->text } $t->root->children( $cond);
is( $got, $expected, "navigation: $cond" );
}
if( $] > 5.008)
{
foreach my $test (@DATA)
{ my( $cond, $expected)= @$test;
my $got='';
XML::Twig->new( twig_handlers => { $cond => sub { $got.= $_->text } },
css_sel => 1,
)
->parse( $doc);
is( $got, $expected, "handlers (css_sel enabled): $cond" );
}
foreach my $test (@DATA)
{ my( $cond, $expected)= @$test;
next if $cond !~ m{^e};
my $got='';
XML::Twig->new( twig_handlers => { $cond => sub { $got.= $_->text } },)
->parse( $doc_dot);
is( $got, $expected, "handlers (css_sel NOT enabled): $cond" );
}
}
else
{ skip( 12, 'not tested under perl < 5.8'); }
__DATA__
e.c1 => e1e2
e.c1[@a="v1"] => e2
e.c1[@a] => e2
e.c1[@a="v2"] =>
*.c1[@a="v1"] => e2
*.c1[@a="v2" or @a="v1"] => e2
.c1[@a="v1"] => e2
.c1[@a="v2" or @a="v1"] => e2
XML-Twig-3.50/t/test_cdata.t 0000755 0001750 0001750 00000003443 12346001775 016032 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use XML::Twig;
$|=1;
$/= "\n\n";
my $xml= ;
print "1..4\n";
my( $t, $result, $expected_result);
$t= XML::Twig->new( twig_handlers => { 'ehtml/#CDATA' => sub { $_->set_asis; } });
$t->parse( $xml);
$result= $t->sprint;
($expected_result=)=~ s{\n*$}{}s;
if( $result eq $expected_result) { print "ok 1\n"; }
else { print "not ok 1\n"; warn "expected: $expected_result\n result : $result"; }
$t= XML::Twig->new( twig_handlers => { 'ehtml/#CDATA' => sub { $_->remove_cdata; } });
$t->parse( $xml);
$result= $t->sprint;
($expected_result=)=~ s{\n*$}{}s;
if( $result eq $expected_result) { print "ok 2\n"; }
else { print "not ok 2\n"; warn "expected: $expected_result\n result : $result"; }
$t= XML::Twig->new( keep_encoding => 1, twig_handlers => { 'ehtml/#CDATA' => sub { $_->set_asis; } });
$t->parse( $xml);
$result= $t->sprint;
($expected_result=)=~ s{\n*$}{}s;
if( $result eq $expected_result) { print "ok 3\n"; }
else { print "not ok 3\n"; warn "test keep_encoding / asis\n expected: $expected_result\n result : $result"; }
$t= XML::Twig->new( keep_encoding => 1, twig_handlers => { 'ehtml/#CDATA' => sub { $_->remove_cdata; } });
$t->parse( $xml);
$result= $t->sprint;
($expected_result=)=~ s{\n*$}{}s;
if( $result eq $expected_result) { print "ok 4\n"; }
else { print "not ok 4\n"; warn "test keep_encoding / remove_cdata\n expected: $expected_result\n result : $result"; }
exit 0;
__DATA__
textworld & all]]>texthello world & alltexthello<br>world & alltexthello world & alltexthello<br>world & all
XML-Twig-3.50/t/test_3_45.t 0000755 0001750 0001750 00000007023 12346001775 015426 0 ustar mrodrigu mrodrigu #!/usr/bin/perl
use strict;
use warnings;
use XML::Twig;
use Test::More tests => 16;
is( XML::Twig->new( keep_encoding => 1)->parse( q{})->sprint, q{}, "quote in att with keep_encoding");
# test CDATA sections in HTML escaping https://rt.cpan.org/Ticket/Display.html?id=86773
my $html = <<'EOF';
body
EOF
# module => XML::Twig->new options
my %html_conv= ( 'HTML::TreeBuilder' => {},
'HTML::Tidy' => { use_tidy => 1 },
);
foreach my $module ( sort keys %html_conv)
{ SKIP:
{ eval "use $module";
skip "$module not available", 3 if $@ ;
my $parser= XML::Twig->new( %{$html_conv{$module}});
my $xml = $parser->safe_parse_html($html);
print $@ if $@;
my @cdata = $xml->get_xpath('//#CDATA');
ok(@cdata == 1, "1 CDATA section found (using $module)");
ok(((index $xml->sprint, "//]]>") >= 0), "end of cdata ok in doc (using $module)");
#diag "\n", $xml->sprint, "\n";
my @elts = $xml->get_xpath('//script');
foreach my $el (@elts)
{ #diag $el->sprint;
ok(((index $el->sprint, "//]]>") >= 0), "end of cdata ok in script element (using $module)");
}
}
}
# test & in HTML (RT #86633)
my $html_with_amp='
Marco&company
';
my $expected_body= '
Marco&company
';
SKIP:
{ eval "use HTML::Tidy";
skip "HTML::Tidy not available", 1 if $@ ;
my $parsert = XML::Twig->new();
my $html_tidy = $parsert->safe_parse_html( { use_tidy => 1 }, "
Marco&company
");
diag $@ if $@;
is( $html_tidy->first_elt( 'body')->sprint, $expected_body, "& in text, converting html with use_tidy");
}
SKIP:
{ eval "use HTML::TreeBuilder";
skip "HTML::TreeBuilder not available", 1 if $@ ;
my $parserh= XML::Twig->new();
my $html = $parserh->safe_parse_html("
Marco&company
");
diag $@ if $@;
is( $html->first_elt( 'body')->sprint , $expected_body, "& in text, converting html with treebuilder");
}
is( XML::Twig::_unescape_cdata( '<tag att="foo&bar&baz">>></tag>'), '>>', '_unescape_cdata');
SKIP:
{ skip "safe_print_to_file method does not work on Windows", 6 if $^O =~ m{win}i;
# testing safe_print_to_file
my $tmp= "safe_print_to_file.xml";
my $doc= "foo";
unlink( $tmp); # no check, it could not be there
my $t1= XML::Twig->nparse( $doc)->safe_print_to_file( $tmp);
ok( -f $tmp, "safe_print_to_file created document");
my $t2= XML::Twig->nparse( $tmp);
is( $t2->sprint, $t1->sprint, "generated document identical to original document");
unlink( $tmp);
my $e1= XML::Twig->parse( 'foobar')->first_elt( 'b')->safe_print_to_file( $tmp);
ok( -f $tmp, "safe_print_to_file on elt created document");
$t2= XML::Twig->nparse( $tmp);
is( $t2->sprint, 'bar', "generated sub-document identical to original sub-document");
unlink( $tmp);
# failure modes
eval { XML::Twig->nparse( $tmp); };
like( $@, qr/Couldn't open $tmp:/, 'parse a non-existent file');
my $non_existent="safe_non_existent_I_hope_01/tmp";
while( -f $non_existent) { $non_existent++; } # most likely unnecessary ;--)
eval { $t1->safe_print_to_file( $non_existent); };
like( $@, qr/(does not exist|is not a directory)/, 'safe_print_to_file in non-existent dir');
}
exit;
XML-Twig-3.50/t/test_with_lwp.t 0000755 0001750 0001750 00000004704 12346001775 016614 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use Carp;
use File::Spec;
use lib File::Spec->catdir(File::Spec->curdir,"t");
use tools;
$|=1;
use XML::Twig;
eval { require LWP; };
if( $@) { import LWP; print "1..1\nok 1\n"; warn "skipping, LWP not available\n"; exit }
# skip on Win32, it looks like we have a problem there (named pipes?)
if( ($^O eq "MSWin32") && ($]<5.008) ) { print "1..1\nok 1\n"; warn "skipping, *parseurl methods not available on Windows with perl < 5.8.0\n"; exit }
if( perl_io_layer_used())
{ print "1..1\nok 1\n";
warn "cannot test parseurl when UTF8 perIO layer used (due to PERL_UNICODE or -C option used)\n";
exit;
}
my $TMAX=13;
chdir 't';
print "1..$TMAX\n";
{ my $t= XML::Twig->new->parseurl( 'file:test_with_lwp.xml', LWP::UserAgent->new);
is( $t->sprint, 'text', "parseurl");
}
{
my $t= XML::Twig->new->parseurl( 'file:test_with_lwp.xml');
is( $t->sprint, 'text', "parseurl");
}
{
my $t= XML::Twig->new->safe_parseurl( 'file:test_with_lwp.xml');
is( $t->sprint, 'text', "parseurl");
}
{
warn "\n\n### warning is normal here ###\n\n";
my $t=0;
if ($^O ne 'VMS')
{ # On VMS we get '%SYSTEM-F-ABORT, abort' and an exit when a file does not exist
# Behaviour is probably different on VMS due to it not having 'fork' to do the
# LWP::UserAgent request and (safe) parse of that request not happening in a child process.
$t = XML::Twig->new->safe_parseurl( 'file:test_with_lwp_no_file.xml');
ok( !$t, "no file");
matches( $@, '^\s*(no element found|Ran out of memory for input buffer)', "no file, error message");
}
else
{ skip( 2 => "running on VMS, cannot test error message for non-existing file"); }
}
{
my $t= XML::Twig->new->safe_parseurl( 'file:test_with_lwp_not_wf.xml');
ok( !$t, "not well-formed");
matches( $@, '^\s*mismatched tag', "not well-formed, error message");
}
{
my $t= XML::Twig->new->parsefile( 'test_with_lwp.xml');
is( $t->sprint, 'text', "parseurl");
}
{
my $t= XML::Twig->new->safe_parsefile( 'test_with_lwp.xml');
is( $t->sprint, 'text', "parseurl");
}
{
my $t= XML::Twig->new->safe_parsefile( 'test_with_lwp_no_file.xml');
ok( !$t, "no file");
matches( $@, '^\s*Couldn', "no file, error message");
}
{
my $t= XML::Twig->new->safe_parsefile( 'test_with_lwp_not_wf.xml');
ok( !$t, "not well-formed");
matches( $@, '^\s*mismatched tag', "not well-formed, error message");
}
exit 0;
XML-Twig-3.50/META.yml 0000664 0001750 0001750 00000001133 12637027512 014531 0 ustar mrodrigu mrodrigu ---
abstract: 'XML, The Perl Way'
author:
- 'Michel Rodriguez '
build_requires:
ExtUtils::MakeMaker: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150005'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: XML-Twig
no_index:
directory:
- t
- inc
requires:
XML::Parser: '2.23'
resources:
repository: http://github.com/mirod/xmltwig
version: '3.50'
x_serialization_backend: 'CPAN::Meta::YAML version 0.012'
XML-Twig-3.50/filter_for_5.005 0000644 0001750 0001750 00000000320 12346001761 016053 0 ustar mrodrigu mrodrigu # $Id: /xmltwig/trunk/filter_for_5.005 4 2007-03-16T12:16:25.259192Z mrodrigu $
if( $] < 5.006) { s{^(\s*)no warnings;}{$1# no warnings;}; }
else { s{^(\s*)# no warnings; }{$1no warnings;}; }
XML-Twig-3.50/tools/ 0000755 0001750 0001750 00000000000 12637027512 014420 5 ustar mrodrigu mrodrigu XML-Twig-3.50/tools/xml_grep/ 0000755 0001750 0001750 00000000000 12637027512 016235 5 ustar mrodrigu mrodrigu XML-Twig-3.50/tools/xml_grep/xml_grep 0000755 0001750 0001750 00000032521 12346001777 020005 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
use strict;
use Getopt::Long;
use Pod::Usage;
use XML::Twig;
my $VERSION="0.9";
# options (all used globally in the script)
my( $help, $man, @roots, @paths, $files,
$count, $nb_results, $nb_results_per_file,
$encoding, @exclude,
$wrap, $nowrap, $descr, $group, $pretty_print, $version, $text_only, $date,
$html, $tidy,
$add_ns,
$verbose, $strict
);
# used to check if the wrapping tags need to be output
my $results = 0;
my $file_results = 0;
# first process the case where the user provides only
# an xpath expression and a list of files
if( @ARGV && ($ARGV[0] !~ m{^-}) )
{ splice( @ARGV, 0, 0, '--group_by_file', 'file', '--pretty_print', 'indented', '--cond'); }
GetOptions( 'help' => \$help,
'man' => \$man,
'Version' => \$version,
'cond=s' => \@paths,
'exclude|v=s' => \@exclude,
'root=s' => \@roots,
'files' => \$files,
'count' => \$count,
'nb_results=i' => \$nb_results,
'by_file=i' => \$nb_results_per_file,
'encoding=s' => \$encoding,
'wrap:s' => \$wrap,
'nowrap' => \$nowrap,
'descr:s' => \$descr,
'group_by_file:s' => \$group,
'pretty_print:s' => \$pretty_print,
'text_only' => \$text_only,
'date!' => \$date,
'strict' => \$strict,
'html' => \$html,
'tidy' => \$tidy,
'add_ns' => \$add_ns,
'verbose' => \$verbose,
) or pod2usage(2);
pod2usage(1) if $help;
pod2usage(-exitstatus => 0, -verbose => 2) if $man;
if( $version) { warn "$0 version $VERSION\n"; exit; }
binmode STDOUT, ':utf8';
# case where options are given, but no root or path, assume the
# first arg is a path
if( !@roots and !@paths and !@exclude and @ARGV) { @paths= shift @ARGV; }
unless( @roots or @paths or @exclude or $files) { pod2usage(1); exit; }
if( ($files or $count) and !@paths) { pod2usage(1); exit; }
if( ($files or $count) and (@roots or $encoding or defined( $wrap)
or defined( $group) or defined( $pretty_print)))
{ pod2usage(1); exit; }
if( $files and !@ARGV) { pod2usage(1); exit; }
if( !$files and !$count and @paths and !@roots) { @roots= @paths; @paths=(); }
$date=1 unless( defined $date);
# defaults for optional arguments to options
$group = 'file' if( defined $group and !$group);
$pretty_print = 'indented' if( defined $pretty_print and !$pretty_print);
if( $nowrap) { $wrap=''; } elsif( !defined( $wrap) and (@roots or @paths)) { $wrap= 'xml_grep'; }
if( !defined( $descr) and (@roots or @paths))
{ if( $date)
{ $date= localtime();
$descr = qq{version="$VERSION" date="$date"}
}
else
{ $descr = qq{version="$VERSION"}; }
}
# some globals
my $current_file;
my $count_file = 0;
my $count_total = 0;
my $nb_results_left_in_current_file=0;
# will be used to create the twig
my %options;
if( $count)
{ my $twig_roots={};
my $twig_root= sub { $count_file++; $_[0]->purge; };
foreach my $path (@paths)
{ $twig_roots->{$path}= $twig_root; }
$options{twig_roots}= $twig_roots;
}
elsif( @exclude)
{ # general options
$nowrap=1;
# twig options
$options{twig_print_outside_roots} = 1;
my $root_handlers={};
foreach my $exclude (@exclude)
{ $root_handlers->{$exclude}= sub { }; }
$options{twig_roots}= $root_handlers;
}
else
{ create_regular_handlers( \%options, \@roots, \@paths);
}
if( $tidy) { $html= 1; $options{use_tidy}= 1; }
$options{pretty_print} = $pretty_print if( $pretty_print);
$options{output_encoding} = $encoding if( $encoding);
my $t= create_twig( %options);
if( @ARGV)
{ foreach my $file (@ARGV)
{ $current_file= $file;
if( $nb_results_per_file) { $nb_results_left_in_current_file= $nb_results_per_file; }
if( $verbose) { warn "parsing '$file'\n"; }
my $ok= $html && ($current_file=~ m{^(http|ftp|file)://}) ? $t->safe_parseurl_html( $file)
: ($current_file=~ m{^(http|ftp|file)://}) ? $t->safe_parseurl( $file)
: $html ? $t->safe_parsefile_html( $file)
: $t->safe_parsefile( $file);
if( !$ok)
{ if( $@ =~ m{XMLGREP: FOUND})
{ # in files mode
print $current_file, "\n";
$nb_results--;
exit unless( $nb_results);
}
elsif( $@ =~ m{^XMLGREP: NB_RESULT_REACHED})
{ print file_result_end() if( $group && $file_results);
print result_end() if( $results);
exit;
}
else
{ $@ ||= 'unknown cause';
if( $strict) { die $@; }
warn $@;
if( !$count) { print "\n"; }
}
}
if( $count)
{ print "$current_file: $count_file\n";
$count_total += $count_file;
$count_file=0;
}
elsif( @roots) { print file_result_end() if( $file_results); }
elsif( $count) { print "$count_total matches\n"; }
}
if( $count) { print "total: $count_total\n"; }
print result_end() if( $results);
}
else
{ $file_results=0;
my $ok= $t->safe_parse( \*STDIN);
if( !$ok and ( $@ !~ m{^XMLGREP: NB_RESULT_REACHED}))
{ if( !$strict) { warn $@; } else { die $@; } }
if( $count) { print "$count_total matches\n"; }
else { print result_end(); }
}
sub create_regular_handlers
{ my( $options, $roots, $paths)= @_;
if( @$roots)
{ my $root_handlers={};
my $root_handler= twig_roots_handler( @$paths);
foreach my $root (@$roots)
{ $root_handlers->{$root}= $root_handler; }
$options->{twig_roots}= $root_handlers;
}
if( @$paths)
{ my $twig_handlers={};
my $twig_handler= twig_handlers();
foreach my $path (@$paths)
{ $twig_handlers->{$path}= $twig_handler; }
$options->{twig_handlers}= $twig_handlers;
}
}
sub create_twig
{ my( %options)= @_;
my $twig;
eval { $twig= XML::Twig->new( %options) };
if( $@)
{ # see if we are in the case where the only condition uses string() or regexp
if( ($@=~ m{^(regexp|string\(\)) condition not supported on twig_roots option})
&& $options{twig_roots} && !$options{twig_handlers}
&& ( keys %{$options{twig_roots}} == 1)
)
{ # in this case add the proper twig_roots option
my $cond= (keys %{$options{twig_roots}})[0];
(my $root= $cond)=~ s{\[[^\]]*\]$}{};
#warn "cond: '$cond' - root: '$root'\n";
delete $options{twig_roots};
delete $options{twig_handlers};
@paths= ($cond);
@roots= ($root);
create_regular_handlers( \%options, \@roots, \@paths);
return create_twig( %options);
}
elsif( $@=~ m{^wrong condition: unrecognized expression in handler: '(.*?)'})
{ die "error in filter condition '$1'\n"; }
else
{ die "error: $@"; }
}
return $twig;
}
sub twig_roots_handler
{ my( @paths)= @_;
return sub
{ my( $t, $root)= @_;
if( !@paths or $_->att( '#print'))
{ print result_start() if( !$results);
print file_result_start() if( $group && !$file_results);
if( $text_only)
{ print $root->text, "\n"; }
else
{ $root->print; }
if( ! -- $nb_results) { $@= "XMLGREP: NB_RESULT_REACHED"; die; }
if( ! -- $nb_results_left_in_current_file) { $t->finish_now(); }
}
$t->purge;
1;
};
}
sub twig_handlers
{ if( $files)
{ return sub { $@="XMLGREP: FOUND"; die; }; }
else
{ return sub { my( $t, $hit)= @_;
foreach my $elt ( $hit->ancestors_or_self)
{ $elt->set_att( '#print' => 1); }
1;
};
}
}
sub result_start
{ $results=1;
return if( $text_only);
my $enc_decl= $encoding ? qq{encoding="$encoding" } : '';
return $wrap ? qq{\n<$wrap $descr>\n}
: '';
}
sub result_end
{ my $result;
return if( $text_only);
if( !$group) { $result= "\n"; }
$result .= qq{\n} if( $wrap);
return $result;
}
sub file_result_start
{ $file_results=1;
return if( $text_only);
my $result;
$result= qq{<$group filename="$current_file">};
if( !$pretty_print)
{ $result.= "\n"; }
return $result;
}
sub file_result_end
{ $file_results=0;
return '' if( $text_only);
return qq{\n\n};
}
__END__
=head1 NAME
xml_grep - grep XML files looking for specific elements
=head1 SYNOPSYS
xml_grep [options]
or
xml_grep
By default you can just give C an XPath expression and
a list of files, and get an XML file with the result.
This is equivalent to writing
xml_grep --group_by_file file --pretty_print indented --cond
=head1 OPTIONS
=over 4
=item B<--help>
brief help message
=item B<--man>
full documentation
=item B<--Version>
display the tool version
=item B<--root>
look for and return xml chunks matching
if neither C<--root> nor C<--file> are used then the element(s)
that trigger the C<--cond> option is (are) used. If C<--cond> is
not used then all elements matching the are returned
several C<--root> can be provided
=item B<--cond>
return the chunks (or file names) only if they contain elements matching
several C<--cond> can be provided (in which case they are OR'ed)
=item B<--files>
return only file names (do not generate an XML output)
usage of this option precludes using any of the options that define the XML output:
C<--roots>, C<--encoding>, C<--wrap>, C<--group_by_file> or C<--pretty_print>
=item B<--count>
return only the number of matches in each file
usage of this option precludes using any of the options that define the XML output:
C<--roots>, C<--encoding>, C<--wrap>, C<--group_by_file> or C<--pretty_print>
=item B<--strict>
without this option parsing errors are reported to STDOUT and the file skipped
=item B<--date>
when on (by default) the wrapping element get a C attribute that gives
the date the tool was run.
with C<--nodate> this attribute is not added, which can be useful if you need
to compare 2 runs.
=item B<--encoding>
encoding of the xml output (utf-8 by default)
=item B<--nb_results>
output only results
=item B<--by_file>
output only results by file
=item B<--wrap>
wrap the xml result in the provided tag (defaults to 'xml_grep')
If wrap is set to an empty string (C<--wrap ''>) then the xml result is not wrapped at all.
=item B<--nowrap>
same as using C<--wrap ''>: the xml result is not wrapped.
=item B<--descr>
attributes of the wrap tag (defaults to C<< version="" date="" >>)
=item B<--group_by_file>
wrap results for each files into a separate element. By default that element
is named C. It has an attribute named C that gives the name of the
file.
the short version of this option is B<-g>
=item B<--exclude>
same as using C<-v> in grep: the elements that match the condition are excluded
from the result, the input file(s) is (are) otherwise unchanged
the short form of this option is B<-v>
=item B<--pretty_print>
pretty print the output using XML::Twig styles ('C', 'C'
or 'C' are probably what you are looking for)
if the option is used but no style is given then 'C' is used
short form for this argument is B<-s>
=item B<--text_only>
Displays the text of the results, one by line.
=item B<--html>
Allow HTML input, files are converted using HTML::TreeBuilder
=item B<--Tidy>
Allow HTML input, files are converted using HTML::Tidy
=back
=head2 Condition Syntax
is an XPath-like expression as allowed by XML::Twig to trigger handlers.
exemples:
'para'
'para[@compact="compact"]'
'*[@urgent]'
'*[@urgent="1"]'
'para[string()="WARNING"]'
see XML::Twig for a more complete description of the syntax
options are processedby Getopt::Long so they can start with '-' or '--'
and can be abbreviated (C<-r> instead of C<--root> for example)
=head1 DESCRIPTION
B does a grep on XML files. Instead of using regular
expressions it uses XPath expressions (in fact the subset of
XPath supported by XML::Twig)
the results can be the names of the files or XML elements
containing matching elements.
=head1 SEE ALSO
XML::Twig Getopt::Long
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=head1 AUTHOR
Michel Rodriguez
XML-Twig-3.50/tools/xml_pp/ 0000755 0001750 0001750 00000000000 12637027512 015717 5 ustar mrodrigu mrodrigu XML-Twig-3.50/tools/xml_pp/xml_pp 0000755 0001750 0001750 00000017516 12346001777 017160 0 ustar mrodrigu mrodrigu #!/usr/bin/perl -w
# $Id: /xmltwig/trunk/tools/xml_pp/xml_pp 32 2008-01-18T13:11:52.128782Z mrodrigu $
use strict;
use XML::Twig;
use File::Temp qw/tempfile/;
use File::Basename qw/dirname/;
my @styles= XML::Twig->_pretty_print_styles; # from XML::Twig
my $styles= join '|', @styles; # for usage
my %styles= map { $_ => 1} @styles; # to check option
my $DEFAULT_STYLE= 'indented';
my $USAGE= "usage: $0 [-v] [-i] [-s ($styles)] [-p ] [-e ] [-l] [-f ] []";
# because of the -i.bak option I don't think I can use one of the core
# option processing modules, so it's custom handling and no clusterization :--(
my %opt= process_options(); # changes @ARGV
my @twig_options=( pretty_print => $opt{style},
error_context => 1,
);
if( $opt{preserve_space_in})
{ push @twig_options, keep_spaces_in => $opt{preserve_space_in};}
if( $opt{encoding})
{ push @twig_options, output_encoding => $opt{encoding};
}
else
{ push @twig_options, keep_encoding => 1; }
# in normal (ie not -l) mode tags are output as soon as possible
push @twig_options, twig_handlers => { _all_ => sub { $_[0]->flush } }
unless( $opt{load});
if( @ARGV)
{ foreach my $file (@ARGV)
{ print STDERR "$file\n" if( $opt{verbose});
my $t= XML::Twig->new( @twig_options);
my $tempfile;
if( $opt{in_place})
{ (undef, $tempfile)= tempfile( DIR => dirname( $file)) or die "cannot create tempfile for $file: $!\n" ;
open( PP_OUTPUT, ">$tempfile") or die "cannot create tempfile $tempfile: $!";
select PP_OUTPUT;
}
$t= $t->safe_parsefile( $file);
if( $t)
{ if( $opt{load}) { $t->print; }
select STDOUT;
if( $opt{in_place})
{ close PP_OUTPUT;
my $mode= mode( $file);
if( $opt{backup})
{ my $backup= backup( $file, $opt{backup});
rename( $file, $backup) or die "cannot create backup file $backup: $!";
}
rename( $tempfile, $file) or die "cannot overwrite file $file: $!";
if( $mode ne mode( $file)) { chmod $mode, $file or die "cannot set $file mode to $mode: $!"; }
}
}
else
{ if( defined $tempfile)
{ unlink $tempfile or die "cannot unlink temp file $tempfile: $!"; }
die $@;
}
}
}
else
{ my $t= XML::Twig->new( @twig_options);
$t->parse( \*STDIN);
if( $opt{load}) { $t->print; }
}
sub mode
{ my( $file)= @_;
return (stat($file))[2];
}
sub process_options
{ my %opt;
while( @ARGV && ($ARGV[0]=~ m{^-}) )
{ my $opt= shift @ARGV;
if( ($opt eq '-v') || ($opt eq '--verbose') )
{ die $USAGE if( $opt{verbose});
$opt{verbose}= 1;
}
elsif( ($opt eq '-s') || ($opt eq '--style') )
{ die $USAGE if( $opt{style});
$opt{style}= shift @ARGV;
die $USAGE unless( $styles{$opt{style}});
}
elsif( ($opt=~ m{^-i(.*)$}) || ($opt=~ m{^--in_place(.*)$}) )
{ die $USAGE if( $opt{in_place});
$opt{in_place}= 1;
$opt{backup}= $1 ||'';
}
elsif( ($opt eq '-p') || ($opt eq '--preserve') )
{ my $tags= shift @ARGV;
my @tags= split /\s+/, $tags;
$opt{preserve_space_in} ||= [];
push @{$opt{preserve_space_in}}, @tags;
}
elsif( ($opt eq '-e') || ($opt eq '--encoding') )
{ die $USAGE if( $opt{encoding});
$opt{encoding}= shift @ARGV;
}
elsif( ($opt eq '-l') || ($opt eq '--load'))
{ die $USAGE if( $opt{load});
$opt{load}=1;
}
elsif( ($opt eq '-f') || ($opt eq '--files') )
{ my $file= shift @ARGV;
push @ARGV, files_from( $file);
}
elsif( ($opt eq '-h') || ($opt eq '--help'))
{ system "pod2text", $0; exit; }
elsif( $opt eq '--')
{ last; }
else
{ die $USAGE; }
}
$opt{style} ||= $DEFAULT_STYLE;
return %opt;
}
# get the list of files (one per line) from a file
sub files_from
{ my $file= shift;
open( FILES, "<$file") or die "cannot open file $file: $!";
my @files;
while( ) { chomp; push @files, $_; }
close FILES;
return @files;
}
sub backup
{ my( $file, $extension)= @_;
my $backup;
if( $extension=~ m{\*})
{ ($backup= $extension)=~ s{\*}{$file}g; }
else
{ $backup= $file.$extension; }
return $backup;
}
__END__
=head1 NAME
xml_pp - xml pretty-printer
=head1 SYNOPSYS
xml_pp [options] []
=head1 DESCRIPTION
XML pretty printer using XML::Twig
=head1 OPTIONS
=over 4
=item -i[]
edits the file(s) in place, if an extension is provided (no space between
C<-i> and the extension) then the original file is backed-up with that extension
The rules for the extension are the same as Perl's (see perldoc perlrun): if
the extension includes no "*" then it is appended to the original file name,
If the extension does contain one or more "*" characters, then each "*" is
replaced with the current filename.
=item -s