use strict;
use Test::More;
BEGIN {
plan tests => 26;
}
no warnings; # SAVERRR used only once
open SAVEERR, ">&STDERR" or die "can't dup stderr";
use warnings;
my $errors;
close STDERR;
open STDERR, '>', \$errors or die "can't stderr: $!";
eval 'use XML::XPathScript';
open STDERR, ">&SAVEERR"; # return to normal
is $errors => undef, 'late inclusion of XML::XPathScript';
sub test_xml {
my( $xml, $style, $result, $comment ) = @_;
my $xps = new XML::XPathScript( xml => $xml, stylesheet => $style );
my $buffer;
$xps->process( \$buffer );
is $buffer => $result, $comment ;
}
test_xml( '<doc>dummy</doc>', 'working', 'working', 'empty run' );
test_xml( '<doc>dummy</doc>', '<%= apply_templates() %>',
'<doc>dummy</doc>', 'simple in/out');
test_xml( '<doc>dummy</doc>', '<% print "Hello!" %>', 'Hello!',
'rogue print statement' );
test_xml( '<doc><!-- hello world --></doc>', <<'EOT', "<doc>comment: hello world </doc>\n", 'processing a comment' );
<% $t->{'#comment'}{pre} = "comment:"; %><%= apply_templates() %>
EOT
test_xml( '<doc><!-- hello world --></doc>', <<'EOT', "<doc></doc>\n", 'masking a comment' );
<% $t->{'#comment'}{testcode} = sub{ 0 } %><%= apply_templates() %>
EOT
############################################################
# Interpolation
my $xml = "<doc><node color='blue'>Hello</node></doc>";
my $xps = <<'EOT';
<%
set_interpolation( 0 );
$t->{node}{testcode} = sub {
my( $n, $t ) = @_;
$t->{pre} = '{@color}';
return DO_SELF_ONLY
};
%>
<%= apply_templates() %>
EOT
test_xml( $xml, $xps, "\n<doc>{\@color}</doc>\n", 'Interpolation (disabled)' );
$xps = <<'EOT';
<%
$XML::XPathScript::DoNotInterpolate = 0;
$t->{node}{testcode} = sub
{
my( $n, $t ) = @_;
$t->{pre} = '{@color}';
return DO_SELF_ONLY()
}; %>
<%= apply_templates() %>
EOT
test_xml( $xml, $xps, "\n<doc>blue</doc>\n", 'Interpolation (enabled)' );
############################################################
# double interpolation
$xps = <<'EOT';
<%
$XML::XPathScript::DoNotInterpolate = 0;
$t->{node}{testcode} = sub
{
my( $n, $t ) = @_;
$t->{pre} = '{@color}:{@color}';
return DO_SELF_ONLY()
}; %>
<%= apply_templates() %>
EOT
test_xml( $xml, $xps, "\n<doc>blue:blue</doc>\n", 'Double interpolation' );
############################################################
# interpolation regex
test_xml( '<doc arg="stuff" />', <<'XPS' , "stuff\n", 'interpolation regex' );
<%
set_interpolation_regex( qr/\[\[(.*?)\]\]/ );
$t->{doc}{pre} = '[[@arg]]';
%><%= apply_templates() %>
XPS
test_xml( '<doc><apple/><banana/></doc>', <<'EOT', "<doc>!<apple></apple><banana></banana>?</doc>\n", 'Prechildren and Postchildren tags, with children' );
<%
$t->{doc}{prechildren} = '!';
$t->{doc}{postchildren} = '?';
$t->{doc}{showtag} = 1;
%><%= apply_templates() %>
EOT
test_xml( '<doc></doc>', <<'EOT', "<doc></doc>\n", 'Prechildren and Postchildren tags, without children' );
<%
$t->{doc}{prechildren} = '!';
$t->{doc}{postchildren} = '?';
$t->{doc}{showtag} = 1;
%><%= apply_templates() %>
EOT
test_xml( '<doc><apple/><banana/></doc>', <<'EOT', "<doc>!<apple></apple>?!<banana></banana>?</doc>\n", 'Prechild and Postchild tags' );
<%
$t->{doc}{prechild} = '!';
$t->{doc}{postchild} = '?';
$t->{doc}{showtag} = 1;
%><%= apply_templates() %>
EOT
test_xml( '<doc>empty</doc>', '<!--#include file="t/include.xps" -->', "#include works!\n", '<!--#include -->' );
test_xml( '<doc>empty</doc>', '<!--#include file="t/include2.xps" -->', "#include works!\n\n", '2 levels of <!--#include -->' );
close STDERR;
open STDERR, '>', \{ my $x };
test_xml( '<doc>empty</doc>', '<!--#include file="t/recursive.xps" -->', "Ooops.\n", 'recursive <!--#include -->' );
test_xml( '<doc>empty</doc>', '<!--#include file="t/include3.xps" -->', "Ooops.\n\n", '2 levels of <!--#include --> + recursion' );
open STDERR, ">&SAVEERR"; # return to normal
# override of printform
$xps = new XML::XPathScript( xml => '<doc/>', stylesheet => 'how about a shout-o-matic?' );
my $buffer;
$xps->process( sub{ $buffer .= uc shift } );
is $buffer => 'HOW ABOUT A SHOUT-O-MATIC?', 'override of printform';
test_xml( '<doc><a/><b/><c/></doc>', <<'EOXPS', "only b: <b></b>\n", 'xpath testcode return statement' );
<%
$t->{doc}{pre} = 'only b: ';
$t->{doc}{testcode} = sub{ 'b'; }
%><%= apply_templates() %>
EOXPS
# encoding
#test_xml( '<doc>Ϩ</doc>', '<%= apply_templates() %>', '', 'Encoding' );
# testing for proper STDOUT management
{
my $xps = new XML::XPathScript( xml => '<blah>hello</blah>', stylesheet => '<%= apply_templates()%>' );
my $output_file = 't/output.xml';
local *STDOUT;
die "file $output_file shouldn't be there" if -f $output_file;
open STDOUT, ">$output_file" or die $!;
$xps->process;
close STDOUT;
open FILE, $output_file or die "$!";
is <FILE> => '<blah>hello</blah>', 'STDOUT management';
close FILE;
unlink $output_file or die $!;
}
# get_xpath_of_node()
{
my $xps = new XML::XPathScript( xml => '<coucou><bloh><blah /><blah>hello <em>world</em> ! </blah></bloh></coucou>',
stylesheet => <<'STYLESHEET' );
<%
$t->{'*'}{pre}="";
$t->{'text()'}{testcode} = sub {
my ($self, $t)=@_;
$t->{pre} = get_xpath_of_node($self)."\n";
return DO_SELF_ONLY;
};
%><%= apply_templates() %>
STYLESHEET
my $result=""; $xps->process(\$result);
ok($result eq <<'EXPECTED') or warn $result;
/coucou[1]/bloh[1]/blah[2]/text()[1]
/coucou[1]/bloh[1]/blah[2]/em[1]/text()[1]
/coucou[1]/bloh[1]/blah[2]/text()[2]
EXPECTED
}
test_xml( '<rootnode><tag>0</tag></rootnode>', '<%= apply_templates() %>', '<rootnode><tag>0</tag></rootnode>', 'string "0" appears' );
{
my $xps = <<'XPS';
<%
$t->{foo}{showtag} = 1;
$t->{foo}{pre} = "before ";
$t->{foo}{intro} = " post-opening ";
$t->{foo}{prechildren} = "pre-children ";
$t->{foo}{postchildren} = " post-children";
$t->{foo}{extro} = " pre-closing ";
$t->{foo}{post} = " post-closing";
%><%= apply_templates() %>
XPS
test_xml( '<foo><child/></foo>', $xps,
"before <foo> post-opening pre-children <child></child> post-children pre-closing </foo> post-closing\n",
'full template with child');
test_xml( '<foo></foo>', $xps,
"before <foo> post-opening pre-closing </foo> post-closing\n",
'full template without child');
}
{
close STDERR;
my $errors;
open STDERR, '>', \$errors;
my $exp;
test_xml( '<foo />', '<% my $nothing; print $nothing; %>', '',
$exp = 'printing undefs should not trigger a warning' );
is $errors => undef, $exp;
open STDERR, ">&SAVEERR"; # return to normal
}