Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

180 lines (142 sloc) 3.218 kB
#!/usr/bin/env perl
use strict;
use warnings;
use IPC::Run3 'run3';
use Time::HiRes qw( gettimeofday tv_interval );
my %report_test =
(
# EXIT_OK
0 => \&report_success,
# EXIT_FAILURE
10 => \&report_failure,
# EXIT_NOT_APPLICABLE
11 => \&report_not_applicable,
);
exit main(@ARGV);
sub main
{
my @tests = find_tests();
return run_tests( @tests );
}
sub find_tests
{
return grep { -x } <spec/*_spec.sh>;
}
sub run_tests
{
my $seen_failure = 0;
for my $test (@_)
{
my ($xml, $status) = run_one_test( $test );
write_xml( $test, $xml );
$seen_failure++ if $status;
}
return $seen_failure;
}
sub run_one_test
{
my $test = shift;
my $cur_time = [ gettimeofday ];
run3( "./$test", undef, \my $out, \my $err );
my $time = tv_interval( $cur_time );
my $status = $? >> 8;
return $report_test{ $status }->( $test, $out, $err, $time )
if exists $report_test{ $status };
return report_unknown_status( $test, $out, $err, $time );
}
sub report_success
{
return report_ok( @_ );
}
sub report_ok
{
my ($test, $out, $err, $time, %args) = @_;
my $xml = create_xml_header(
name => $test,
time => $time,
%args
);
my $name = filename_to_test_name( $test );
$xml .=<<"TESTCASE";
<testcase name="$name" time="$time">
</testcase>
TESTCASE
$xml .= create_xml_footer( stdout => $out, stderr => $err );
return $xml;
}
sub report_failure
{
my ($test, $out, $err, $time) = @_;
my $xml = create_xml_header(
failures => 1,
name => $test,
time => $time
);
my $name = filename_to_test_name( $test );
my ($first_line) = $out =~ /^(.+)$/m;
$xml .=<<"TESTCASE";
<testcase name="$name" time="$time">
<failure type="acceptanceFailure" message="$first_line">
$out
</failure>
</testcase>
TESTCASE
$xml .= create_xml_footer( stdout => $out, stderr => $err );
# this one reports a failure
return( $xml, 1 );
}
sub report_not_applicable
{
return report_ok( @_, skipped => 1 );
}
sub report_unknown_status
{
# this one also reports a failure
return( report_ok( @_, errors => 1 ), 1 );
}
sub create_xml_header
{
my %args =
(
errors => 0,
failures => 0,
name => 'unknown',
tests => 1,
skipped => 0,
time => '0.00',
@_,
);
return <<"XML";
<?xml version="1.0" encoding="UTF-8"?>
<testsuite errors="$args{errors}" failures="$args{failures}" name="$args{name}" tests="$args{tests}" skipped="$args{skipped}" time="$args{time}">
XML
}
sub create_xml_footer
{
my %args = @_;
return <<"XML";
<system-out>
$args{stdout}
</system-out>
<system-err>
$args{stderr}
</system-err>
</testsuite>
XML
}
sub write_xml
{
my ($test, $xml) = @_;
$test =~ s[spec/][results/];
$test =~ s/.sh$/.xml/;
open my $out, '>', $test or die "Cannot write '$test': $!\n";
print {$out} $xml;
close $out;
}
sub filename_to_test_name
{
my $filename = shift;
$filename =~ s/^spec.(\w+)_spec.sh/$1/;
$filename =~ tr/_/ /;
return $filename;
}
Jump to Line
Something went wrong with that request. Please try again.