#!/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{<?xml version="1.0" encoding="UTF-8"?>
<widget
xmlns="http://xmlns.oracle.com/widgets"
id="first.widget"
class="FirstWidgetClass">
<!-- This is a comment about widget instance -->
<widget-instance>
<!-- This is OK, on one line because there is only one attribute -->
<subwidget id="sub.widget" />
<!-- This one has two attributes, so is split up. -->
<subwidget
id="sub.widget.2"
name="SubWidget2"
/>
</widget-instance>
</widget>
};
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{<!DOCTYPE x [ <!ENTITY ent SYSTEM "$ent_file_base" > ]><x>&ent;</x>};
my $ent= qq{<foo/>};
spit( $xml_file, $doc);
spit( $ent_file, $ent);
my $expected= '<x><foo/></x>';
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= "<d><s><a/><e/><e/></s></d>";
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= "<d><s><a/><e/><e/><a></d>";
my $invalid_doc_file= "invalid_doc.xml";
spit( $invalid_doc_file, $invalid_doc);
my $expected="e";
my( $result);
my $expected_sprint="<d><s><a/><e/></s></d>";
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{<?xml version="1.0" encoding="UTF-8"?>\n<!DOCTYPE d1 [\n<!ELEMENT d1 (#PCDATA)><!ENTITY e1 "[e1]"><!ENTITY e2 "[e2]">\n]>\n<d1> t1 &e1; &e2;</d1>};
my $doc2=qq{<?xml version="1.0" encoding="UTF-8"?>\n<!DOCTYPE d2 [\n<!ELEMENT d2 (#PCDATA)><!ENTITY e1 "[e1]"><!ENTITY e3 "[e3]">\n]>\n<d2> t1 &e1; &e3;</d2>};
(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 { $_ => "<!ENTITY $_ $ent_desc{$_}>" } keys %ent_desc;
my $decl_string= join( '', values %decl);
my $doc= qq{<!DOCTYPE d [ $decl_string ]><d/>};
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{<d><e1/><e2/><e3/></d>});
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{<d><e1/><e2/><e3/></d>});
is( $t->root->first_child->tag, 'e2', "purge on an element");
}
{ my $t= XML::Twig->parse( twig_handlers => { e2 => sub { $_->prev_sibling->purge( $_) } }, q{<d><e1/><e2/><e3/></d>});
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{<d><e1/><e2/><e3/></d>});
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{<d><e1/><e2/><e3/></d>});
is( $t->root->first_child->tag, 'e2', "purge_up_to");
}
}
{ my $t= XML::Twig->parse( '<!DOCTYPE foo PUBLIC "-//xmltwig//DTD xmltwig test 1.0//EN" "foo.dtd" [<!ELEMENT d (#PCDATA)>]><d/>');
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, '<!ELEMENT d (#PCDATA)>', 'internal subset (with value)');
}
{ my $t= XML::Twig->parse( '<d/>');
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( '<!DOCTYPE foo SYSTEM "foo.dtd"><d/>');
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( '<!DOCTYPE foo [<!ELEMENT d (#PCDATA)>]><d/>');
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, '<!ELEMENT d (#PCDATA)>', 'internal subset (with value)');
}
{ my $prolog= '<!DOCTYPE foo PUBLIC "-//xmltwig//DTD xmltwig test 1.0//EN" "foo.dtd" [<!ELEMENT d (#PCDATA)>]>';
my $doc= '<d/>';
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{<!DOCTYPE foo [<!ENTITY % bar1 PUBLIC "toto1" "tata1">%bar1;<!ENTITY bar2 PUBLIC "toto2" "tata2">%bar2;]><d><elt/></d>};
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{<doc><elt><selt>selt 1</selt><selt>selt 2</selt></elt></doc>};
my $t= XML::Twig->parse( pretty_print => 'indented', $doc);
my $elt_indented = "\n <selt>selt 1</selt>\n <selt>selt 2</selt>";
my $elt_not_indented = "<selt>selt 1</selt><selt>selt 2</selt>";
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{<!DOCTYPE foo [ <!ENTITY zzent SYSTEM "zznot_there"> ]><foo>&zzent;</foo>};
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{<html><body><h1>Title</h1><p>foo<br>bar</p>};
my $expected= q{<html><head></head><body><h1>Title</h1><p>foo<br />bar</p></body></html>};
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{<doc id="1"><elt>text</elt></doc>})->_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{<!DOCTYPE d [ <!ENTITY foo "bar">]><d>&foo;</d>})->entity( 'foo')->_dump;
is( $dump, q{name => 'foo' - val => 'bar'}, "entity dump");
}
{ if( $XML::Parser::VERSION > 2.27)
{ my $t= XML::Twig->parse( q{<!DOCTYPE d [ <!ENTITY afoo "bar"> <!ENTITY % bfoo "baz">]><d>&afoo;</d>});
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{<!DOCTYPE d [<!ENTITY foo SYSTEM "$entity_file"><!ENTITY bar SYSTEM "$missing_file">]><d>&foo;</d>};
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{<!DOCTYPE d [ <!ENTITY foon SYSTEM "$entity_file" NDATA gif> <!ENTITY barn SYSTEM "$missing_file" NDATA gif>]>
<d><elt ent1="foon" ent2="barn" /></d>};
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{<d><elt>foo <b>bar</b> baz <b>foobar</b><c>xyz</c><b>toto</b>tata<b>tutu</b></elt></d>};
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{<d><e>e</e><e1>e1</e1><e1>e1-2</e1></d>};
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= '<ns1:doc xmlns:ns1="foo" xmlns="bar"><ns1:elt att="bar"/></ns1: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;