Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Send all debugging output to STDERR.

Don't read in digest files if the files have changed since writing.
  This should get rid of "ignoring extra" errors.
Also delete structure information for changed files.
Allow tests to specify whether coverage should be run.
Just quieten "../../lib/Storable.pm" messages.
Add change.t test.
Add a second sleep in md5.t test between runs to ensure ordering.
  • Loading branch information...
commit 3782c11854a7000846d20a59494a81a3aabb9114 1 parent 06c51ca
@pjcj authored
View
2  MANIFEST
@@ -47,6 +47,7 @@ tests/alias
tests/alias1
tests/Alias1.pm
tests/branch_return_sub
+tests/change.t
tests/cond_and
tests/cond_branch
tests/cond_or
@@ -99,6 +100,7 @@ test_output/cover/alias1.5.006001
test_output/cover/alias1.5.008
test_output/cover/branch_return_sub.5.006001
test_output/cover/branch_return_sub.5.008
+test_output/cover/change.5.006001
test_output/cover/cond_and.5.006001
test_output/cover/cond_and.5.008
test_output/cover/cond_and.5.008001
View
82 lib/Devel/Cover.pm
@@ -90,6 +90,7 @@ BEGIN
($File, $Line, $Collect) = ("", 0, 1);
$Silent = ($ENV{HARNESS_PERL_SWITCHES} || "") =~ /Devel::Cover/ ||
($ENV{PERL5OPT} || "") =~ /Devel::Cover/;
+ *OUT = $ENV{DEVEL_COVER_DEBUG} ? *STDERR : *STDOUT;
}
if (0 && $Config{useithreads})
@@ -100,15 +101,15 @@ if (0 && $Config{useithreads})
my $original_join;
BEGIN { $original_join = \&threads::join }
- # print "original_join: $original_join\n";
+ # print STDERR "original_join: $original_join\n";
- # $original_join = sub { print "j\n" };
+ # $original_join = sub { print STDERR "j\n" };
# sub threads::join
*threads::join = sub
{
- # print "threads::join- ", \&threads::join, "\n";
- # print "original_join- $original_join\n";
+ # print STDERR "threads::join- ", \&threads::join, "\n";
+ # print STDERR "original_join- $original_join\n";
my $self = shift;
print STDERR "(joining thread ", $self->tid, ")\n";
my @ret = $original_join->($self, @_);
@@ -126,7 +127,7 @@ if (0 && $Config{useithreads})
$original_destroy->($self, @_);
};
- # print "threads::join: ", \&threads::join, "\n";
+ # print STDERR "threads::join: ", \&threads::join, "\n";
my $new = \&threads::new;
*threads::new = *threads::create = sub
@@ -138,12 +139,12 @@ if (0 && $Config{useithreads})
$new->($class,
sub
{
- print "Starting thread\n";
+ print STDERR "Starting thread\n";
set_coverage(keys %Coverage);
my $ret = [ $sub->(@_) ];
- print "Ending thread\n";
+ print STDERR "Ending thread\n";
report() if $Initialised;
- print "Ended thread\n";
+ print STDERR "Ended thread\n";
$wantarray ? @{$ret} : $ret->[0];
},
@_
@@ -180,7 +181,7 @@ EOM
@coverage = get_coverage();
my $last = pop @coverage || "";
- print STDOUT __PACKAGE__, " $VERSION: Collecting coverage data for ",
+ print OUT __PACKAGE__, " $VERSION: Collecting coverage data for ",
join(", ", @coverage),
@coverage ? " and " : "",
"$last.\n",
@@ -206,14 +207,14 @@ EOM
my $run_end = 0;
sub first_end
{
- # print "**** END 1 - $run_end\n";
+ # print STDERR "**** END 1 - $run_end\n";
set_last_end() unless $run_end++
}
my $run_init = 0;
sub first_init
{
- # print "**** INIT 1 - $run_init\n";
+ # print STDERR "**** INIT 1 - $run_init\n";
collect_inits() unless $run_init++
}
}
@@ -253,7 +254,7 @@ sub import
my $class = shift;
my @o = (@_, split ",", $ENV{DEVEL_COVER_OPTIONS} || "");
- # print __PACKAGE__, ": Parsing options from [@_]\n";
+ # print STDERR __PACKAGE__, ": Parsing options from [@_]\n";
my $blib = -d "blib";
@Inc = () if "@o" =~ /-inc /;
@@ -405,8 +406,9 @@ sub normalised_file
my $f = $file;
$file =~ s/ \(autosplit into .*\)$//;
- # print "file is <$file>\n";
- # use Data::Dumper; print "file is <$file>\ncoverage is ", Dumper coverage(0);
+ # print STDERR "file is <$file>\n";
+ # use Data::Dumper;
+ # print STDERR "file is <$file>\ncoverage: ", Dumper coverage(0);
if (exists coverage(0)->{module} && exists coverage(0)->{module}{$file} &&
!File::Spec->file_name_is_absolute($file))
{
@@ -484,10 +486,11 @@ sub use_file
for (@Ignore_re) { return $Files{$file} = 0 if $f =~ $_ }
for (@Inc_re) { return $Files{$file} = 0 if $f =~ $_ }
- # system "pwd; ls -l $file";
+ # system "pwd; ls -l '$file'";
$Files{$file} = -e $file ? 1 : 0;
- warn __PACKAGE__ . qq(: Can't find file "$file": ignored.\n)
- unless $Files{$file} || $Silent || $file =~ /\(eval \d+\)/;
+ warn __PACKAGE__ . qq(: Can't find file "$file" (@_): ignored.\n)
+ unless $Files{$file} || $Silent || $file =~ /\(eval \d+\)/ ||
+ $file eq "../../lib/Storable.pm";
$Files{$file}
}
@@ -503,7 +506,7 @@ sub check_file
my $file = $op->file;
my $use = use_file($file);
- # printf "%6s $file\n", $use ? "use" : "ignore";
+ # printf STDERR "%6s $file\n", $use ? "use" : "ignore";
$use
}
@@ -513,7 +516,7 @@ sub B::GV::find_cv
my $cv = $_[0]->CV;
return unless $$cv;
- # print "find_cv $$cv\n" if check_file($cv);
+ # print STDERR "find_cv $$cv\n" if check_file($cv);
push @Cvs, $cv if check_file($cv);
push @Cvs, grep check_file($_), $cv->PADLIST->ARRAY->ARRAY
if $cv->can("PADLIST") &&
@@ -530,7 +533,7 @@ sub sub_info
{
return unless $cv->GV->can("SAFENAME");
$name = $cv->GV->SAFENAME;
- # print "--[$name]--\n";
+ # print STDERR "--[$name]--\n";
$name =~ s/(__ANON__)\[.+:\d+\]/$1/ if defined $name;
}
my $root = $cv->ROOT;
@@ -553,7 +556,7 @@ sub sub_info
sub check_files
{
- # print "Checking files\n";
+ # print STDERR "Checking files\n";
@Cvs = grep check_file($_), B::main_cv->PADLIST->ARRAY->ARRAY;
@@ -572,7 +575,7 @@ sub check_files
local ($Line, $File);
get_location($start);
$line = $Line;
- # print "$name - $File:$Line\n";
+ # print STDERR "$name - $File:$Line\n";
}
($line, $name)
};
@@ -609,7 +612,8 @@ sub report
$Structure = Devel::Cover::DB::Structure->new(base => $DB);
$Structure->read_all;
$Structure->add_criteria(@collected);
- # use Data::Dumper; print STDERR "Start structure", Dumper $Structure;
+ # use Data::Dumper; $Data::Dumper::Indent = 1;
+ # use Data::Dumper; print STDERR "Start structure: ", Dumper $Structure;
# print STDERR "Processing cover data\n@Inc\n";
$Coverage = coverage(1) || die "No coverage data available.\n";
@@ -631,17 +635,17 @@ sub report
get_cover($_)
for get_ends()->isa("B::AV") ? get_ends()->ARRAY : ();
}
- # print "--- @Cvs\n";
+ # print STDERR "--- @Cvs\n";
get_cover($_) for @Cvs;
my %files;
$files{$_}++ for keys %{$Run{count}}, keys %{$Run{vec}};
for my $file (sort keys %files)
{
- # print "looking at $file\n";
+ # print STDERR "looking at $file\n";
unless (use_file($file))
{
- # print "deleting $file\n";
+ # print STDERR "deleting $file\n";
delete $Run{count}->{$file};
delete $Run{vec} ->{$file};
$Structure->delete_file($file);
@@ -658,7 +662,7 @@ sub report
$Structure->store_counts($file);
}
- # use Data::Dumper; print STDERR "End structure", Dumper $Structure;
+ # use Data::Dumper; print STDERR "End structure: ", Dumper $Structure;
my $run = time . ".$$." . sprintf "%05d", rand 2 ** 16;
my $cover = Devel::Cover::DB->new
@@ -678,7 +682,7 @@ sub report
$cover->{db} = $DB;
- print STDOUT __PACKAGE__, ": Writing coverage database to $DB\n"
+ print OUT __PACKAGE__, ": Writing coverage database to $DB\n"
unless $Silent;
$cover->write;
$cover->print_summary if $Summary && !$Silent;
@@ -691,7 +695,7 @@ sub add_subroutine_cover
get_location($op);
return unless $File;
- # print "Subroutine $Sub_name $Line:$File: ", $op->name, "\n";
+ # print STDERR "Subroutine $Sub_name $Line:$File: ", $op->name, "\n";
my $key = get_key($op);
my $val = $Coverage->{statement}{$key} || 0;
@@ -888,7 +892,7 @@ sub deparse
my $name = $op->can("name") ? $op->name : "Unknown";
- # print "$class:$name at $File:$Line\n";
+ # print STDERR "$class:$name at $File:$Line\n";
{
# Collect everything under here.
@@ -896,7 +900,7 @@ sub deparse
$deparse = eval { $Original{deparse}->($self, @_) };
$deparse =~ s/^\010+//mg if defined $deparse;
$deparse = "Deparse error: $@" if $@;
- # print "Collect Deparse $op $$op => <$deparse>\n";
+ # print STDERR "Collect Deparse $op $$op => <$deparse>\n";
}
# Get the coverage on this op.
@@ -957,7 +961,7 @@ sub deparse
$deparse = eval { $Original{deparse}->($self, @_) };
$deparse =~ s/^\010+//mg if defined $deparse;
$deparse = "Deparse error: $@" if $@;
- # print "Deparse => <$deparse>\n";
+ # print STDERR "Deparse => <$deparse>\n";
}
$deparse
@@ -1042,11 +1046,11 @@ sub get_cover
($Sub_name, my $start) = sub_info($cv);
- # print "get_cover: <$Sub_name>\n";
+ # print STDERR "get_cover: <$Sub_name>\n";
return unless defined $Sub_name; # Only happens within Safe.pm, AFAIK.
get_location($start) if $start;
- # print "[[$File:$Line]]\n";
+ # print STDERR "[[$File:$Line]]\n";
# return unless length $File;
return if length $File && !use_file($File);
@@ -1098,7 +1102,7 @@ sub get_cover
}
}
$Pod = "Pod::Coverage" if delete $opts{nocp};
- # use Data::Dumper; print "$Pod, ", Dumper \%opts;
+ # use Data::Dumper; print STDERR "$Pod, ", Dumper \%opts;
if ($Pod{$file} ||= $Pod->new(package => $pkg, %opts))
{
my $covered;
@@ -1129,9 +1133,9 @@ sub get_cover
# my $dd = @_ && ref $_[0]
# ? $deparse->deparse($_[0], 0)
# : $deparse->deparse_sub($cv, 0);
- # print "get_cover: <$Sub_name>\n";
- # print "[[$File:$Line]]\n";
- # print "<$dd>\n";
+ # print STDERR "get_cover: <$Sub_name>\n";
+ # print STDERR "[[$File:$Line]]\n";
+ # print STDERR "<$dd>\n";
no warnings "redefine";
local *B::Deparse::deparse = \&deparse;
@@ -1141,7 +1145,7 @@ sub get_cover
my $de = @_ && ref $_[0]
? $deparse->deparse($_[0], 0)
: $deparse->deparse_sub($cv, 0);
- # print "<$de>\n";
+ # print STDERR "<$de>\n";
$de
}
View
43 lib/Devel/Cover/DB.pm
@@ -114,13 +114,15 @@ sub merge_runs
{
my $self = shift;
my $db = $self->{db};
- # print "merge_runs from $db/runs/*\n";
+ # print STDERR "merge_runs from $db/runs/*\n";
# system "ls -al $db/runs";
return $self unless length $db;
opendir DIR, "$db/runs" or return $self;
my @runs = map "$db/runs/$_", grep !/^\.\.?/, readdir DIR;
closedir DIR or die "Can't closedir $db/runs: $!";
+ $self->{changed_files} = {};
+
# The ordering is important here. The runs need to be merged in the order
# they were created. We're only at a granularity of one second, but that
# shouldn't be a problem unless a file is altered and the coverage run
@@ -132,8 +134,22 @@ sub merge_runs
my $r = Devel::Cover::DB->new(base => $self->{base}, db => $run);
$self->merge($r);
}
+
$self->write($db) if @runs;
rmtree(\@runs);
+
+ if (keys %{$self->{changed_files}})
+ {
+ my $st = Devel::Cover::DB::Structure->new(base => $self->{base});
+ $st->read_all;
+ for my $file (sort keys %{$self->{changed_files}})
+ {
+ # print STDERR "dealing with changed file <$file>\n";
+ $st->delete_file($file);
+ }
+ $st->write($self->{base});
+ }
+
$self
}
@@ -146,7 +162,7 @@ sub validate_db
# die if the db is invalid.
# just warn for now
- print "Devel::Cover: $self->{db} is an invalid database\n"
+ print STDERR "Devel::Cover: $self->{db} is an invalid database\n"
unless $self->is_valid;
$self
@@ -180,7 +196,7 @@ sub merge
my ($self, $from) = @_;
# use Data::Dumper; $Data::Dumper::Indent = 1;
- # print "Merging ", Dumper($self), "From ", Dumper($from);
+ # print STDERR "Merging ", Dumper($self), "From ", Dumper($from);
while (my ($fname, $frun) = each %{$from->{runs}})
{
@@ -188,7 +204,8 @@ sub merge
{
while (my ($name, $run) = each %{$self->{runs}})
{
- # print "digests for $file: $digest, $run->{digests}{$file}\n";
+ # print STDERR
+ # "digests for $file: $digest, $run->{digests}{$file}\n";
if ($run->{digests}{$file} && $digest &&
$run->{digests}{$file} ne $digest)
{
@@ -199,6 +216,7 @@ sub merge
delete $run->{digests}{$file};
delete $run->{count} {$file};
delete $run->{vec} {$file};
+ $self->{changed_files}{$file}++;
}
}
}
@@ -207,7 +225,7 @@ sub merge
_merge_hash($self->{runs}, $from->{runs});
_merge_hash($self->{collected}, $from->{collected});
- return $self;
+ return $self; # TODO - what's going on here?
# When the database gets big, it's quicker to merge into what's
# already there.
@@ -220,7 +238,7 @@ sub merge
$from->{$_} = $self->{$_} unless $_ eq "runs" || $_ eq "collected";
}
- # print "Giving ", Dumper($from);
+ # print STDERR "Giving ", Dumper($from);
$_[0] = $from;
}
@@ -404,7 +422,7 @@ sub add_statement
my %line;
for my $i (0 .. $#$fc)
{
- # print "statement: $i\n";
+ # print STDERR "statement: $i\n";
my $l = $sc->[$i];
unless (defined $l)
{
@@ -419,7 +437,7 @@ sub add_statement
$cc->{$l}[$n][0] += $fc->[$i];
$cc->{$l}[$n][1] ||= $uc->{$l}[$n][0][1];
}
- # use Data::Dumper; print Dumper $uc;
+ # use Data::Dumper; print STDERR Dumper $uc;
# use Data::Dumper; print STDERR "cc: ", Dumper $cc;
}
@@ -480,7 +498,8 @@ sub add_subroutine
{
my $self = shift;
my ($cc, $sc, $fc, $uc) = @_;
- # use Data::Dumper; print STDERR "add_subroutine():\n", Dumper $cc, $sc, $fc, $uc;
+ # use Data::Dumper;
+ # print STDERR "add_subroutine():\n", Dumper $cc, $sc, $fc, $uc;
# $cc = { line_number => [ [ count, sub_name, uncoverable ], [ ... ] ], .. }
# $sc = [ [ line_number, sub_name ], [ ... ] ]
# $fc = [ count, ... ]
@@ -547,7 +566,7 @@ sub uncoverable
}
}
- # use Data::Dumper; $Data::Dumper::Indent = 1; print Dumper $u;
+ # use Data::Dumper; $Data::Dumper::Indent = 1; print STDERR Dumper $u;
# Now change the format of the uncoverable information.
for my $file (sort keys %$u)
@@ -569,7 +588,7 @@ sub uncoverable
}
close F;
my $f = $u->{$file};
- # use Data::Dumper; $Data::Dumper::Indent = 1; print Dumper $f;
+ # use Data::Dumper; $Data::Dumper::Indent = 1; print STDERR Dumper $f;
for my $crit (keys %$f)
{
my $c = $f->{$crit};
@@ -595,7 +614,7 @@ sub uncoverable
$u->{$df->hexdigest} = delete $u->{$file};
}
- # use Data::Dumper; $Data::Dumper::Indent = 1; print Dumper $u;
+ # use Data::Dumper; $Data::Dumper::Indent = 1; print STDERR Dumper $u;
$u
}
View
49 lib/Devel/Cover/DB/Structure.pm
@@ -59,7 +59,7 @@ sub AUTOLOAD
{
my $self = shift;
my $file = shift;
- # print "file: $file, condition: $c\n";
+ # print STDERR "file: $file, condition: $c\n";
# TODO - why no file?
return unless defined $file;
$self->{f}{$file}{$c}
@@ -143,7 +143,7 @@ sub set_subroutine
for $self->criteria;
}
# use Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1;
- # print Dumper $self->{f}{$file}{start};
+ # print STDERR Dumper $self->{f}{$file}{start};
}
sub store_counts
@@ -156,7 +156,7 @@ sub store_counts
$self->get_count($_)
for $self->criteria;
# use Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1;
- # print Dumper $self->{f}{$file}{start};
+ # print STDERR Dumper $self->{f}{$file}{start};
}
sub reuse
@@ -171,16 +171,14 @@ sub set_file
my $self = shift;
my ($file) = @_;
$self->{file} = $file;
- $self->digest($file)
-}
-
-sub add_digest_xxx
-{
- my $self = shift;
- my ($file, $digest) = @_;
- print "Adding $digest for $file\n";
- $self->{f}{$file}{digest} = $digest;
- push @{$self->{digests}{$digest}}, $file;
+ my $digest = $self->digest($file);
+ if ($digest)
+ {
+ # print STDERR "Adding $digest for $file\n";
+ $self->{f}{$file}{digest} = $digest;
+ push @{$self->{digests}{$digest}}, $file;
+ }
+ $digest
}
sub digest
@@ -188,18 +186,11 @@ sub digest
my $self = shift;
my ($file) = @_;
- my $f = $self->{f}{$file};
- # return $f->{digest} if $f->{digest};
-
my $digest;
if (open my $fh, "<", $file)
{
binmode $fh;
$digest = Digest::MD5->new->addfile($fh)->hexdigest;
- # $self->add_digest($file, $digest);
- # print "Adding $digest for $file\n";
- $self->{f}{$file}{digest} = $digest;
- push @{$self->{digests}{$digest}}, $file;
}
else
{
@@ -237,7 +228,7 @@ sub write
{
my $self = shift;
my ($dir) = @_;
- # use Data::Dumper; print Dumper $self;
+ # use Data::Dumper; print STDERR Dumper $self;
$dir .= "/structure";
unless (-d $dir)
{
@@ -254,7 +245,7 @@ sub write
my $df = "$dir/$self->{f}{$file}{digest}";
# TODO - determine if Structure has changed to save writing it.
# my $f = $df; my $n = 1; $df = $f . "." . $n++ while -e $df;
- # print "Writing [$file] to [$df]\n";
+ # print STDERR "Writing [$file] to [$df]\n";
Storable::nstore($self->{f}{$file}, $df); # unless -e $df;
}
}
@@ -265,8 +256,18 @@ sub read
my ($digest) = @_;
my $file = "$self->{base}/structure/$digest";
my $s = retrieve($file);
- # print "reading $digest: ", Dumper $s;
- $self->{f}{$s->{file}} = $s;
+ my $d = $self->digest($s->{file});
+ # use Data::Dumper; print STDERR "reading $digest from $file: ", Dumper $s;
+ if ($d && $d eq $s->{digest})
+ {
+ $self->{f}{$s->{file}} = $s;
+ }
+ else
+ {
+ warn "Devel::Cover: Deleting old coverage ",
+ "for changed file $s->{file}\n";
+ unlink $file or warn "Devel::Cover: can't delete $file: $!\n";
+ }
$self
}
View
46 lib/Devel/Cover/Test.pm
@@ -177,14 +177,16 @@ sub run_command
my $debug = $ENV{DEVEL_COVER_DEBUG} || 0;
- print "Running test [$command]\n" if $debug;
+ print STDERR "Running test [$command]\n" if $debug;
open T, "$command 2>&1 |" or die "Cannot run $command: $!";
while (<T>)
{
- print if $debug;
+ print STDERR if $debug;
}
close T or die "Cannot close $command: $!";
+
+ 1
}
sub run_test
@@ -199,8 +201,9 @@ sub run_test
open I, $gold or die "Cannot open $gold: $!";
my @cover = <I>;
close I or die "Cannot close $gold: $!";
+ $self->{cover} = \@cover;
- print "gold from $gold\n", @cover if $debug;
+ # print STDERR "gold from $gold\n", @cover if $debug;
eval "use Test::Differences";
my $differences = $INC{"Test/Differences.pm"};
@@ -221,8 +224,21 @@ sub run_test
? $self->{run_test}->($self)
: $self->run_command($self->test_command);
+ $self->run_cover unless $self->{no_report};
+
+ $self->{end}->() if $self->{end};
+}
+
+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 "Running cover [$cover_com]\n" if $debug;
+ print STDERR "Running cover [$cover_com]\n" if $debug;
my @at;
my @ac;
@@ -236,7 +252,7 @@ sub run_test
{
$_ = scalar $get_line->();
$_ = "" unless defined $_;
- print if $debug;
+ print STDERR $_ if $debug;
redo if /^Devel::Cover: merging run/;
s/^(Reading database from ).*/$1/;
s|(__ANON__\[) .* (/tests/ \w+ : \d+ \])|$1$2|x;
@@ -261,10 +277,11 @@ sub run_test
open T, "$cover_com 2>&1 |" or die "Cannot run $cover_com: $!";
while (!eof T)
{
- my $t = $change_line->(sub {<T>});
- my $c = $change_line->(sub {shift @cover});
+ my $t = $change_line->(sub { <T> });
+ my $c = $change_line->(sub { shift @{$self->{cover}} });
# print STDERR "[$t]\n[$c]\n" if $t ne $c;
- # chomp(my $tn = $t); chomp(my $cn = $c); print "c-[$tn] $.\ng=[$cn]\n";
+ # chomp(my $tn = $t); chomp(my $cn = $c);
+ # print STDERR "c-[$tn] $.\ng=[$cn]\n";
if ($differences)
{
push @at, $t;
@@ -273,7 +290,7 @@ sub run_test
else
{
$ENV{DEVEL_COVER_NO_COVERAGE} ? ok 1 : ok $t, $c;
- last if $ENV{DEVEL_COVER_NO_COVERAGE} && !@cover;
+ last if $ENV{DEVEL_COVER_NO_COVERAGE} && !@{$self->{cover}};
}
}
if ($differences)
@@ -284,10 +301,9 @@ sub run_test
}
elsif ($ENV{DEVEL_COVER_NO_COVERAGE})
{
- ok 1 for @cover;
+ ok 1 for @{$self->{cover}};
}
close T or die "Cannot close $cover_com: $!";
- $self->{end}->() if $self->{end};
}
sub create_gold
@@ -317,7 +333,7 @@ sub create_gold
: $self->run_command($self->test_command);
my $cover_com = $self->cover_command;
- print "Running cover [$cover_com]\n" if $debug;
+ print STDERR "Running cover [$cover_com]\n" if $debug;
open G, ">$new_gold" or die "Cannot open $new_gold: $!";
open T, "$cover_com|" or die "Cannot run $cover_com: $!";
@@ -326,7 +342,7 @@ sub create_gold
next if $l =~ /^Devel::Cover: merging run/;
$l =~ s/^($_: ).*$/$1.../
for "Run", "Perl version", "OS", "Start", "Finish";
- print $l if $debug;
+ print STDERR $l if $debug;
print G $l;
$ng .= $l;
}
@@ -339,7 +355,7 @@ sub create_gold
my $g = do { local $/; <G> };
close G or die "Cannot close $gold: $!";
- # print "checking $new_gold against $gold\n";
+ # print STDERR "checking $new_gold against $gold\n";
if ($ng eq $g)
{
print "Output from $new_gold matches $gold\n";
@@ -353,7 +369,7 @@ sub create_gold
END
{
my $self = $Test;
- $self->run_test if $self->{run_test_at_end};
+ $self->run_test if $self->{run_test_at_end};
}
1;
View
53 test_output/cover/change.5.006001
@@ -0,0 +1,53 @@
+Reading database from /home/pjcj/g/perl/svk/dc/cover_db
+Devel::Cover: Deleting old coverage for changed file tests/change
+
+
+------------------------------------------ ------ ------ ------ ------ ------
+File stmt bran cond sub total
+------------------------------------------ ------ ------ ------ ------ ------
+tests/change 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: ...
+
+Run: ...
+Perl version: ...
+OS: ...
+Start: ...
+Finish: ...
+
+tests/change
+
+line err stmt bran cond sub code
+1 #!/usr/bin/perl
+2
+3 # Copyright 2004-2006, 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 1 my $x = 1;
+11 sub new_sub
+12 {
+13 1 1 my $y = 1;
+14 }
+15
+16 1 new_sub;
+
+
+Covered Subroutines
+-------------------
+
+Subroutine Count Location
+---------- ----- ---------------
+new_sub 1 tests/change:13
+
+
View
57 tests/change.t
@@ -0,0 +1,57 @@
+#!/usr/bin/perl
+
+# Copyright 2002-2006, 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
+
+use strict;
+use warnings;
+
+use File::Copy;
+
+use Devel::Cover::Inc 0.59;
+use Devel::Cover::Test 0.59;
+
+my $base = $Devel::Cover::Inc::Base;
+
+my $t = "change";
+my $ft = "$base/tests/$t";
+my $fg = "$base/tests/trivial";
+
+my $run_test = sub
+{
+ my $test = shift;
+
+ copy($fg, $ft) or die "Cannot copy $fg to $ft: $!";
+
+ $test->run_command($test->test_command);
+
+ sleep 1;
+
+ copy($fg, $ft) or die "Cannot copy $fg to $ft: $!";
+
+ open T, ">>$ft" or die "Cannot open $ft: $!";
+ print T <<'EOT';
+sub new_sub
+{
+ my $y = 1;
+}
+
+new_sub;
+EOT
+ close T or die "Cannot close $ft: $!";
+
+ $test->{test_parameters} .= " -merge 1";
+ $test->run_command($test->test_command);
+};
+
+my $test = Devel::Cover::Test->new
+(
+ $t,
+ run_test => $run_test,
+ end => sub { unlink $ft },
+ no_report => 0,
+);
View
2  tests/md5.t
@@ -33,6 +33,8 @@ my $run_test = sub
$test->run_command($test->test_command);
+ sleep 1;
+
copy($fg, $ft) or die "Cannot copy $fg to $ft: $!";
$test->{test_parameters} .= " -merge 1";
Please sign in to comment.
Something went wrong with that request. Please try again.