Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge branch 'test'

  • Loading branch information...
commit 879ff5fd1e2b3034868d631bb6b8a4344bdf28aa 2 parents 43fae73 + 2c0be70
@pjcj authored
View
8 Makefile.PL
@@ -18,7 +18,7 @@ use File::Copy;
$| = 1;
-my $Version = "0.82";
+my $Version = "0.82_01";
my $Author = 'pjcj@cpan.org';
my @perlbug = ("perlbug", "-a", $Author,
"-s", "Installation of Devel::Cover $Version");
@@ -124,7 +124,9 @@ use lib "$base/t";
use Devel::Cover::Test;
-Devel::Cover::Test->new("$t");
+my \$test = Devel::Cover::Test->new("$t");
+\$test->run_test;
+\$test # for create_gold
EOT
close T or die "Cannot close t/e2e/a$t.t: $!";
}
@@ -414,7 +416,7 @@ GEOM = 260x85+0+0
diff : out
\t \$(PERL) utils/makeh strip_criterion 'time' \$(TEST).out
\t \$(PERL) utils/makeh strip_criterion ' pod' \$(TEST).out
-\t gvim -geom \$(GEOM) -d -font \$(FONT) `\$(PERL) -Mblib -MDevel::Cover::Test -e '\$\$t = Devel::Cover::Test->new("\$(TEST)", run_test_at_end => 0); print \$\$t->cover_gold'` \$(TEST).out
+\t gvim -geom \$(GEOM) -d -font \$(FONT) `\$(PERL) -Mblib -MDevel::Cover::Test -e '\$\$t = Devel::Cover::Test->new("\$(TEST)"); print \$\$t->cover_gold'` \$(TEST).out
gold : pure_all
\t \$(PERL) utils/create_gold \$(TEST)
View
239 lib/Devel/Cover/Test.pm
@@ -15,12 +15,10 @@ use warnings;
use Carp;
use File::Spec;
-use Test;
+use Test ();
use Devel::Cover::Inc;
-my $Test;
-
sub new
{
my $class = shift;
@@ -33,7 +31,10 @@ sub new
my $criteria = delete $params{criteria} ||
"statement branch condition subroutine";
- my $self =
+ eval "use Test::Differences";
+ my $differences = $INC{"Test/Differences.pm"};
+
+ my $self = bless
{
test => $test,
criteria => [ $criteria ],
@@ -43,11 +44,11 @@ sub new
ignore => [],
changes => [],
test_parameters => [],
- run_test_at_end => 1,
+ debug => $ENV{DEVEL_COVER_DEBUG} || 0,
+ differences => $differences,
+ no_coverage => $ENV{DEVEL_COVER_NO_COVERAGE} || 0,
%params
- };
-
- $Test = bless $self, $class;
+ }, $class;
$self->get_params
}
@@ -100,12 +101,10 @@ sub get_params
$self
}
-sub test { $Test }
-
sub shell_quote
{
my ($item) = @_;
- # properly quote the item
+
$^O eq "MSWin32" ? (/ / and $_ = qq("$_")) : s/ /\\ /g for $item;
$item
};
@@ -114,12 +113,10 @@ sub perl
{
my $self = shift;
- my $perl = shell_quote $Devel::Cover::Inc::Perl;
- my $base = $Devel::Cover::Inc::Base;
-
- $perl .= " " . shell_quote "-I$base/$_" for "", "blib/lib", "blib/arch";
-
- $perl
+ join " ",
+ map shell_quote($_),
+ $Devel::Cover::Inc::Perl,
+ map "-I$Devel::Cover::Inc::Base/$_", "", "blib/lib", "blib/arch"
}
sub test_command
@@ -127,10 +124,12 @@ sub test_command
my $self = shift;
my $c = $self->perl;
- unless ($ENV{DEVEL_COVER_NO_COVERAGE})
+ unless ($self->{no_coverage})
{
$c .= " -MDevel::Cover=" .
- join(",", '-db', $self->{cover_db}, split ' ', $self->{test_parameters})
+ join ",",
+ "-db", $self->{cover_db},
+ split " ", $self->{test_parameters}
}
$c .= " " . shell_quote $self->test_file;
$c .= " " . $self->test_file_parameters;
@@ -186,7 +185,7 @@ sub cover_gold
$v = $ENV{DEVEL_COVER_GOLDEN_VERSION}
if exists $ENV{DEVEL_COVER_GOLDEN_VERSION};
- "$td/$test.$v"
+ ("$td/$test", $v eq "5.0" ? 0 : $v)
}
sub run_command
@@ -194,14 +193,12 @@ sub run_command
my $self = shift;
my ($command) = @_;
- my $debug = $ENV{DEVEL_COVER_DEBUG} || 0;
-
- print STDERR "Running test [$command]\n" if $debug;
+ print STDERR "Running test [$command]\n" if $self->{debug};
open T, "$command 2>&1 |" or die "Cannot run $command: $!";
while (<T>)
{
- print STDERR if $debug;
+ print STDERR if $self->{debug};
}
close T or die "Cannot close $command: $!";
@@ -212,33 +209,29 @@ sub run_test
{
my $self = shift;
- $self->{run_test_at_end} = 0;
-
- my $debug = $ENV{DEVEL_COVER_DEBUG} || 0;
-
if ($self->{skip})
{
- plan tests => 1;
- skip($self->{skip}, 1);
+ Test::plan tests => 1;
+ Test::skip($self->{skip}, 1);
return;
}
- my $gold = $self->cover_gold;
+ my ($base, $v) = $self->cover_gold;
+ return 1 unless $v; # assume we are generating the golden results
+ my $gold = "$base.$v";
+
open I, $gold or die "Cannot open $gold: $!";
my @cover = <I>;
close I or die "Cannot close $gold: $!";
$self->{cover} = \@cover;
- # print STDERR "gold from $gold\n", @cover if $debug;
-
- eval "use Test::Differences";
- my $differences = $INC{"Test/Differences.pm"};
+ # print STDERR "gold from $gold\n", @cover if $self->{debug};
- plan tests => $differences
- ? 1
- : exists $self->{tests}
- ? $self->{tests}->(scalar @cover)
- : scalar @cover;
+ Test::plan tests => $self->{differences}
+ ? 1
+ : exists $self->{tests}
+ ? $self->{tests}->(scalar @cover)
+ : scalar @cover;
local $ENV{PERL5OPT};
@@ -249,18 +242,16 @@ sub run_test
$self->run_cover unless $self->{no_report};
$self->{end}->() if $self->{end};
+
+ 1
}
sub run_cover
{
my $self = shift;
- my $debug = $ENV{DEVEL_COVER_DEBUG} || 0;
- eval "use Test::Differences";
- my $differences = $INC{"Test/Differences.pm"};
-
my $cover_com = $self->cover_command;
- print STDERR "Running cover [$cover_com]\n" if $debug;
+ print STDERR "Running cover [$cover_com]\n" if $self->{debug};
my @at;
my @ac;
@@ -274,7 +265,7 @@ sub run_cover
{
$_ = scalar $get_line->();
$_ = "" unless defined $_;
- print STDERR $_ if $debug;
+ print STDERR $_ if $self->{debug};
redo if /^Devel::Cover: merging run/;
redo if /^Set up gcc environment/; # for MinGW
if (/Can't opendir\(.+\): No such file or directory/)
@@ -314,51 +305,49 @@ sub run_cover
{
chomp(my $tn = $t); chomp(my $cn = $c);
print STDERR "c-[$tn] $.\ng=[$cn]\n";
- } if $debug;
+ } if $self->{debug};
- if ($differences)
+ if ($self->{differences})
{
push @at, $t;
push @ac, $c;
}
else
{
- $ENV{DEVEL_COVER_NO_COVERAGE} ? ok 1 : ok $t, $c;
- last if $ENV{DEVEL_COVER_NO_COVERAGE} && !@{$self->{cover}};
+ $self->{no_coverage} ? Test::ok 1 : Test::ok $t, $c;
+ last if $self->{no_coverage} && !@{$self->{cover}};
}
}
- if ($differences)
+ if ($self->{differences})
{
no warnings "redefine";
local *Test::_quote = sub { "@_" };
- $ENV{DEVEL_COVER_NO_COVERAGE} ? ok 1 : eq_or_diff(\@at, \@ac, "output");
+ $self->{no_coverage} ? Test::ok 1 : eq_or_diff(\@at, \@ac, "output");
}
- elsif ($ENV{DEVEL_COVER_NO_COVERAGE})
+ elsif ($self->{no_coverage})
{
- ok 1 for @{$self->{cover}};
+ Test::ok 1 for @{$self->{cover}};
}
close T or die "Cannot close $cover_com: $!";
+
+ 1
}
sub create_gold
{
my $self = shift;
- $self->{run_test_at_end} = 0;
-
# Pod::Coverage not available on all versions, but it must be there on
# 5.6.1 and 5.8.0
return if $self->{criteria} =~ /\bpod\b/ &&
$] != 5.006001 &&
$] != 5.008000;
- my $debug = $ENV{DEVEL_COVER_DEBUG} || 0;
-
- my $gold = $self->cover_gold;
- my $new_gold = $gold;
- $new_gold =~ s/(5\.\d+)$/$]/;
- my $gv = $1;
- my $ng = "";
+ my ($base, $v) = $self->cover_gold;
+ my $gold = "$base.$v";
+ my $new_gold = "$base.$]";
+ my $gv = $v;
+ my $ng = "";
unless (-e $new_gold)
{
@@ -378,7 +367,7 @@ sub create_gold
: $self->run_command($self->test_command);
my $cover_com = $self->cover_command;
- print STDERR "Running cover [$cover_com]\n" if $debug;
+ print STDERR "Running cover [$cover_com]\n" if $self->{debug};
open G, ">$new_gold" or die "Cannot open $new_gold: $!";
open T, "$cover_com 2>&1 |" or die "Cannot run $cover_com: $!";
@@ -388,38 +377,34 @@ sub create_gold
$l =~ s/^($_: ).*$/$1.../
for "Run", "Perl version", "OS", "Start", "Finish";
$l =~ s/^(Reading database from ).*$/$1.../;
- print STDERR $l if $debug;
+ print STDERR $l if $self->{debug};
print G $l;
$ng .= $l;
}
close T or die "Cannot close $cover_com: $!";
close G or die "Cannot close $new_gold: $!";
- print STDERR "gv is $gv and this is $]\n" if $debug;
- print STDERR "gold is $gold and new_gold is $new_gold\n" if $debug;
- unless ($gv eq "5.0" || $gv eq $])
+ print STDERR "gv is $gv and this is $]\n" if $self->{debug};
+ print STDERR "gold is $gold and new_gold is $new_gold\n" if $self->{debug};
+ unless ($gv eq "0" || $gv eq $])
{
open G, "$gold" or die "Cannot open $gold: $!";
my $g = do { local $/; <G> };
close G or die "Cannot close $gold: $!";
- print STDERR "checking $new_gold against $gold\n" if $debug;
+ print STDERR "checking $new_gold against $gold\n" if $self->{debug};
# print "--[$ng]--\n";
# print "--[$g]--\n";
if ($ng eq $g)
{
- print "Output from $new_gold matches $gold\n";
+ print "matches $v";
unlink $new_gold;
}
}
$self->{end}->() if $self->{end};
-}
-END
-{
- my $self = $Test;
- $self->run_test if $self->{run_test_at_end};
+ 1
}
1
@@ -430,4 +415,108 @@ __END__
Devel::Cover::Test - Internal module for testing
+=head1 METHODS
+
+=cut
+
+=head2 new
+
+ my $test = Devel::Cover::Test->new($test, criteria => $string)
+
+Constructor.
+
+"criteria" parameter (optional, defaults to "statement branch condition
+subroutine") is a space separated list of tokens.
+Supported tokens are "statement", "branch", "condition", "subroutine" and
+"pod".
+
+More optional parameters are supported. Refer to L</get_params> sub.
+
+=head2 shell_quote
+
+ my $quoted_item = shell_quote($item)
+
+Returns properly quoted item to cope with embedded spaces.
+
+=head2 perl
+
+ my $perl = $self->perl()
+
+Returns absolute path to Perl interpreter with proper -I options (blib-wise).
+
+=head2 test_command
+
+ my $command = $self->test_command()
+
+Returns test command, made of:
+
+=over 4
+
+=item absolute path to Perl interpreter
+
+=item Devel::Cover -M option (if applicable)
+
+=item test file
+
+=item test file parameters (if applicable)
+
+=back
+
+=head2 cover_command
+
+ my $command = $self->cover_command()
+
+Returns test command, made of:
+
+=over 4
+
+=item absolute path to Perl interpreter
+
+=item absolute path to cover script
+
+=item cover parameters
+
+=back
+
+=head2 test_file
+
+ my $file = $self->test_file()
+
+Returns absolute path to test file.
+
+=head2 test_file_parameters
+
+ my $parameters = $self->test_file_parameters()
+
+Accessor to test_file_parameters property.
+
+=head2 cover_gold
+
+ my ($base, $v) = $self->cover_gold;
+
+Returns the absolute path of the base to the golden file and the suffix
+version number.
+
+$base comes from the name of the test and $v will be $] from the earliest perl
+version for which the golden results should be the same as for the current $]
+
+=head2 run_command
+
+ $self->run_command($command)
+
+Runs command, most likely obtained from L</test_command> sub.
+
+=head1 BUGS
+
+Huh?
+
+=head1 LICENCE
+
+Copyright 2001-2012, Paul Johnson (pjcj@cpan.org)
+
+This software is free. It is licensed under the same terms as Perl itself.
+
+The latest version of this software should be available from my homepage:
+http://www.pjcj.net
+
=cut
View
51 test_output/cover/cmp_ok.5.008
@@ -0,0 +1,51 @@
+Reading database from ...
+
+
+------------------------------------------ ------ ------ ------ ------ ------
+File stmt bran cond sub total
+------------------------------------------ ------ ------ ------ ------ ------
+tests/cmp_ok 100.0 n/a n/a 100.0 100.0
+Total 100.0 n/a n/a 100.0 100.0
+------------------------------------------ ------ ------ ------ ------ ------
+
+
+Run: ...
+Perl version: ...
+OS: ...
+Start: ...
+Finish: ...
+
+tests/cmp_ok
+
+line err stmt bran cond sub code
+1 #!/usr/bin/perl
+2
+3 # Copyright 2004-2011, Paul Johnson (pjcj@cpan.org)
+4
+5 # This software is free. It is licensed under the same terms as Perl itself.
+6
+7 # The latest version of this software should be available from my homepage:
+8 # http://www.pjcj.net
+9
+10 # test case for RT #63568 https://rt.cpan.org/Public/Bug/Display.html?id=63568
+11
+12 # __COVER__ skip_test $] < 5.008 || !(eval "use Test::More; 23")
+13 # __COVER__ skip_reason Test::More not available
+14
+15 1 1 use Test::More;
+ 1
+ 1
+16
+17 1 plan tests => 1;
+18
+19 1 cmp_ok("", "eq", "");
+
+
+Covered Subroutines
+-------------------
+
+Subroutine Count Location
+---------- ----- ---------------
+BEGIN 1 tests/cmp_ok:15
+
+
View
77 test_output/cover/inc_sub.5.012001
@@ -0,0 +1,77 @@
+Reading database from ...
+
+
+------------------------------------------ ------ ------ ------ ------ ------
+File stmt bran cond sub total
+------------------------------------------ ------ ------ ------ ------ ------
+tests/inc_sub 100.0 75.0 n/a 100.0 95.0
+Total 100.0 75.0 n/a 100.0 95.0
+------------------------------------------ ------ ------ ------ ------ ------
+
+
+Run: ...
+Perl version: ...
+OS: ...
+Start: ...
+Finish: ...
+
+tests/inc_sub
+
+line err stmt bran cond sub code
+1 #!/bin/perl
+2
+3 # Copyright 2002-2011, Paul Johnson (pjcj@cpan.org)
+4
+5 # This software is free. It is licensed under the same terms as Perl itself.
+6
+7 # The latest version of this software should be available from my homepage:
+8 # http://www.pjcj.net
+9
+10 # __COVER__ changes s/(2[12] )[23]/$1X/
+11 # __COVER__ changes s/(22 100 )[12]/$1X/
+12
+13 1 1 use lib ();
+ 1
+ 1
+14
+15 BEGIN
+16 {
+17 lib->import
+18 (
+19 sub
+20 {
+21 2 print map("[$_]", @_), "\n";
+22 2 100 return unless $_[1] eq "IncSub.pm";
+23 1 my $fh;
+24 *** 1 50 open $fh, "tests/IncSub.pm" or die $!;
+25 1 $fh
+26 }
+27 )
+28 1 1 }
+29
+30 1 1 use IncSub;
+ 1
+ 1
+31
+32 1 IncSub::check
+
+
+Branches
+--------
+
+line err % true false branch
+----- --- ------ ------ ------ ------
+22 100 1 1 unless $_[1] eq 'IncSub.pm'
+24 *** 50 0 1 unless open $fh, 'tests/IncSub.pm'
+
+
+Covered Subroutines
+-------------------
+
+Subroutine Count Location
+---------- ----- ----------------
+BEGIN 1 tests/inc_sub:13
+BEGIN 1 tests/inc_sub:28
+BEGIN 1 tests/inc_sub:30
+
+
View
77 test_output/cover/inc_sub.5.012002
@@ -0,0 +1,77 @@
+Reading database from ...
+
+
+------------------------------------------ ------ ------ ------ ------ ------
+File stmt bran cond sub total
+------------------------------------------ ------ ------ ------ ------ ------
+tests/inc_sub 100.0 75.0 n/a 100.0 95.0
+Total 100.0 75.0 n/a 100.0 95.0
+------------------------------------------ ------ ------ ------ ------ ------
+
+
+Run: ...
+Perl version: ...
+OS: ...
+Start: ...
+Finish: ...
+
+tests/inc_sub
+
+line err stmt bran cond sub code
+1 #!/bin/perl
+2
+3 # Copyright 2002-2011, Paul Johnson (pjcj@cpan.org)
+4
+5 # This software is free. It is licensed under the same terms as Perl itself.
+6
+7 # The latest version of this software should be available from my homepage:
+8 # http://www.pjcj.net
+9
+10 # __COVER__ changes s/(2[12] )[23]/$1X/
+11 # __COVER__ changes s/(22 100 )[12]/$1X/
+12
+13 1 1 use lib ();
+ 1
+ 1
+14
+15 BEGIN
+16 {
+17 lib->import
+18 (
+19 sub
+20 {
+21 3 print map("[$_]", @_), "\n";
+22 3 100 return unless $_[1] eq "IncSub.pm";
+23 1 my $fh;
+24 *** 1 50 open $fh, "tests/IncSub.pm" or die $!;
+25 1 $fh
+26 }
+27 )
+28 1 1 }
+29
+30 1 1 use IncSub;
+ 1
+ 1
+31
+32 1 IncSub::check
+
+
+Branches
+--------
+
+line err % true false branch
+----- --- ------ ------ ------ ------
+22 100 2 1 unless $_[1] eq 'IncSub.pm'
+24 *** 50 0 1 unless open $fh, 'tests/IncSub.pm'
+
+
+Covered Subroutines
+-------------------
+
+Subroutine Count Location
+---------- ----- ----------------
+BEGIN 1 tests/inc_sub:13
+BEGIN 1 tests/inc_sub:28
+BEGIN 1 tests/inc_sub:30
+
+
View
4 tests/change.t
@@ -61,3 +61,7 @@ my $test = Devel::Cover::Test->new
end => sub { unlink $ft },
no_report => 0,
);
+
+$test->run_test;
+
+$test # for create_gold
View
19 tests/cmp_ok
@@ -0,0 +1,19 @@
+#!/usr/bin/perl
+
+# Copyright 2004-2011, Paul Johnson (pjcj@cpan.org)
+
+# This software is free. It is licensed under the same terms as Perl itself.
+
+# The latest version of this software should be available from my homepage:
+# http://www.pjcj.net
+
+# test case for RT #63568 https://rt.cpan.org/Public/Bug/Display.html?id=63568
+
+# __COVER__ skip_test $] < 5.008 || !(eval "use Test::More; 23")
+# __COVER__ skip_reason Test::More not available
+
+use Test::More;
+
+plan tests => 1;
+
+cmp_ok("", "eq", "");
View
4 tests/eval_sub.t
@@ -39,7 +39,7 @@ my $run_test = sub
my $runs = 4;
-$Devel::Cover::Test::test = Devel::Cover::Test->new
+my $test = Devel::Cover::Test->new
(
"eval3",
golden_test => "eval_sub.t",
@@ -47,3 +47,5 @@ $Devel::Cover::Test::test = Devel::Cover::Test->new
changes => [ 'if (/^Run: /) { $get_line->() for 1 .. 5; redo }' ],
tests => sub { $_[0] - $runs * 6 }, # number of lines deleted above
);
+$test->run_test;
+$test # for create_gold
View
4 tests/eval_use.t
@@ -36,7 +36,7 @@ my $run_test = sub
$test->run_command($test->test_command);
};
-$Devel::Cover::Test::test = Devel::Cover::Test->new
+my $test = Devel::Cover::Test->new
(
"eval2",
golden_test => "eval_use.t",
@@ -44,3 +44,5 @@ $Devel::Cover::Test::test = Devel::Cover::Test->new
changes => [ 'if (/^Run: /) { $get_line->() for 1 .. 5; redo }' ],
tests => sub { $_[0] - 24 }, # number of lines deleted above
);
+$test->run_test;
+$test # for create_gold
View
2  tests/md5.t
@@ -53,3 +53,5 @@ my $test = Devel::Cover::Test->new
run_test => $run_test,
end => sub { unlink $ft },
);
+$test->run_test;
+$test # for create_gold
View
19 utils/create_gold
@@ -42,11 +42,16 @@ unless (@tests)
for my $test (@tests)
{
- my $d = "t/e2e";
- my $t = -e "$d/$test" ? "$d/$test" :
- -e "$d/a$test.t" ? "$d/a$test.t" :
- $test;
- print STDERR "creating golden results for $test\n";
- require $t or die "Can't require $t: $!";
- Devel::Cover::Test::test->create_gold;
+ my $e = "t/e2e";
+ my ($file) = grep -e, "$e/$test", "$e/a$test.t";
+ $file ||= $test;
+ print STDERR "creating golden results for $test: ";
+ my $t;
+ {
+ no warnings "redefine";
+ local *Devel::Cover::Test::run_test = sub {};
+ $t = require $file or die "Can't require $file: $!";
+ }
+ $t->create_gold;
+ print "\n";
}
Please sign in to comment.
Something went wrong with that request. Please try again.