Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Handle || bless {}, "XXX" (reported by Marcel Grünauer).

 Add preliminary dor support.
 Add eval_sub test.
 Package buildperl script.
 Add -report option to cpancover.
 Update cpancover CSS.
 Partial solution for structure problems including debugging code.
 Add outputfile option to Html_basic.
  • Loading branch information...
commit 84539e78aebb6af06c3326f5191eabf178875938 1 parent f0c313c
@pjcj authored
View
1  CHANGES
@@ -5,6 +5,7 @@ Release 0.54 -
- Fix pod coverage percentages.
- Fix integer <-> pointer conversion warnings (Robin Barker).
- Add more tests for sort bug fixed in 0.53 (Rob Kinyon).
+ - Handle || bless {}, "XXX" (reported by Marcel Grünauer).
Release 0.53 - 17th April 2005
- Clean up database directories.
View
25 Cover.xs
@@ -487,13 +487,20 @@ static void cover_logop(pTHX)
else
{
dSP;
- int left_val = SvTRUE(TOPs);
+ int left_val = SvTRUE(TOPs);
+#ifdef KEY_err
+ int left_val_def = SvOK(TOPs);
+#endif
NDEB(D(L, "cover_logop [%s]\n", get_key(PL_op)));
- if (PL_op->op_type == OP_AND && left_val ||
- PL_op->op_type == OP_ANDASSIGN && left_val ||
- PL_op->op_type == OP_OR && !left_val ||
- PL_op->op_type == OP_ORASSIGN && !left_val ||
+ if (PL_op->op_type == OP_AND && left_val ||
+ PL_op->op_type == OP_ANDASSIGN && left_val ||
+ PL_op->op_type == OP_OR && !left_val ||
+ PL_op->op_type == OP_ORASSIGN && !left_val ||
+#ifdef KEY_err
+ PL_op->op_type == OP_DOR && !left_val_def ||
+ PL_op->op_type == OP_DORASSIGN && !left_val_def ||
+#endif
PL_op->op_type == OP_XOR)
{
/* no short circuit */
@@ -747,7 +754,7 @@ static int runops_cover(pTHX)
}
sv_setpv(lastfile, file);
}
-#if (PERL_VERSION > 6)
+#if PERL_VERSION > 6
if (SvTRUE(MY_CXT.module))
{
STRLEN mlen,
@@ -834,9 +841,13 @@ static int runops_cover(pTHX)
}
case OP_AND:
- case OP_OR:
case OP_ANDASSIGN:
+ case OP_OR:
case OP_ORASSIGN:
+#ifdef KEY_err
+ case OP_DOR:
+ case OP_DORASSIGN:
+#endif
case OP_XOR:
{
cover_logop(aTHX);
View
3  MANIFEST
@@ -1,5 +1,6 @@
all_versions
BUGS
+buildperl
CHANGES
cover
Cover.xs
@@ -137,6 +138,8 @@ tests/E3.pm
tests/E4.pm
tests/eval1
tests/eval2
+tests/eval3
+tests/eval_sub.t
tests/eval_use.t
tests/fork
tests/if
View
2  MANIFEST.SKIP
@@ -19,3 +19,5 @@ lib/Devel/Cover/Inc.pm$
^Devel-Cover-
.patch$
.rej$
+.debug$
+^tmp/
View
1  TODO
@@ -32,6 +32,7 @@
- Overhaul test system. Include patt?
- Tests for INIT and END blocks included in required files when the
files are used in some runs.
+ - Make sure dor is handled correctly and add more tests to cond_or.
- Build:
- meta.yaml file to control pause indexing.
- Fix up make text and friends for module_ignore.
View
11 cover
@@ -134,7 +134,7 @@ sub main
}
print "$0 version $VERSION\n" and exit 0 if $Options->{version};
- pod2usage(-exitval => 0, -verbose => 0) if $Options->{help};
+ pod2usage(-exitval => 0, -verbose => 1) if $Options->{help};
pod2usage(-exitval => 0, -verbose => 2) if $Options->{info};
my $dbname = Cwd::abs_path(@ARGV ? shift @ARGV : "cover_db");
@@ -156,7 +156,8 @@ sub main
{
delete_db($dbname, @ARGV);
local $ENV{ -d "t" ? "HARNESS_PERL_SWITCHES" : "PERL5OPT" } =
- "-Mblib=$Bin -MDevel::Cover";
+ # "-Mblib=$Bin -MDevel::Cover";
+ "-MDevel::Cover";
system "make test";
$Options->{report} ||= "html";
}
@@ -190,6 +191,12 @@ sub main
$d->Indent(1);
$d->Sortkeys(1) if $] >= 5.008;
print $d->Dump;
+ my $structure = Devel::Cover::DB::Structure->new(base => $dbname);
+ $structure->read_all;
+ my $s = Data::Dumper->new([$structure], ["structure"]);
+ $s->Indent(1);
+ $s->Sortkeys(1) if $] >= 5.008;
+ print $s->Dump;
exit 0
}
View
84 cpancover
@@ -33,6 +33,7 @@ my $Options =
directory => Cwd::cwd(),
force => 0,
module => [],
+ report => "html_basic",
};
sub get_options
@@ -51,6 +52,7 @@ sub get_options
outputfile=s
redo_cpancover_html!
redo_html!
+ report=s
version|v!
));
@@ -125,7 +127,8 @@ sub get_cover
my $od = "$Options->{outputdir}/$module";
my $of = $Options->{outputfile};
- sys "$^X $inc $s/cover -report html -outputdir $od -outputfile $of"
+ sys "$^X $inc $s/cover -report $Options->{report} " .
+ "-outputdir $od -outputfile $of"
if !-e "$od/$of" || $Options->{redo_html};
my $results = read_results;
@@ -148,7 +151,7 @@ sub write_stylesheet
print CSS <<EOF;
/* Stylesheet for Devel::Cover cpancover reports */
-/* You may modify this file to alter the appearance of your cpancover
+/* You may modify this file to alter the appearance of your coverage
* reports. If you do, you should probably flag it read-only to prevent
* future runs from overwriting it.
*/
@@ -160,9 +163,11 @@ body {
}
h1 {
- background-color: #3399ff;
+ text-align : center;
+ background-color: #cc99ff;
border: solid 1px #999999;
padding: 0.2em;
+ -moz-border-radius: 10px;
}
a {
@@ -172,49 +177,67 @@ a:visited {
color: #333333;
}
-code {
- white-space: pre;
-}
-
table {
-/* border: solid 1px #000000;*/
-/* border-collapse: collapse;*/
+ border-spacing: 1px;
}
-td,th {
- border: solid 1px #cccccc;
+tr {
+ text-align : center;
+ vertical-align: top;
}
-
-/* Classes for color-coding coverage information:
- * header : column/row header
- * uncovered : path not covered or coverage < 75%
- * covered75 : coverage >= 75%
- * covered90 : coverage >= 90%
- * covered : path covered or coverage = 100%
- */
-.header {
+th,.h,.hh {
background-color: #cccccc;
border: solid 1px #333333;
padding-left: 0.2em;
padding-right: 0.2em;
+ width: 2.5em;
+ -moz-border-radius: 4px;
+}
+.hh {
+ width: 25%;
+}
+td {
+ border: solid 1px #cccccc;
+ -moz-border-radius: 4px;
}
-.uncovered {
+.hblank {
+ height: 0.5em;
+}
+.dblank {
+ border: none;
+}
+
+/* source code */
+pre,.s {
+ text-align: left;
+ font-family: monospace;
+ white-space: pre;
+ padding: 0.2em 0.5em 0em 0.5em;
+}
+
+/* Classes for color-coding coverage information:
+ * c0 : path not covered or coverage < 75%
+ * c1 : coverage >= 75%
+ * c2 : coverage >= 90%
+ * c3 : path covered or coverage = 100%
+ */
+.c0 {
background-color: #ff9999;
border: solid 1px #cc0000;
}
-.covered75 {
+.c1 {
background-color: #ffcc99;
border: solid 1px #ff9933;
}
-.covered90 {
+.c2 {
background-color: #ffff99;
border: solid 1px #cccc66;
}
-.covered {
+.c3 {
background-color: #99ff99;
border: solid 1px #009900;
}
-
EOF
+
close CSS or die "Can't close $css: $!\n";
}
@@ -222,10 +245,10 @@ sub class
{
my ($pc) = @_;
$pc eq "n/a" ? "na" :
- $pc < 75 ? "uncovered" :
- $pc < 90 ? "covered75" :
- $pc < 100 ? "covered90" :
- "covered"
+ $pc < 75 ? "c0" :
+ $pc < 90 ? "c1" :
+ $pc < 100 ? "c2" :
+ "c3"
}
sub write_html
@@ -249,7 +272,8 @@ sub write_html
{
my $dbdir = "$Options->{directory}/$module/cover_db";
next unless -d $dbdir;
- print "Adding $module\n";
+ chdir "$Options->{directory}/$module";
+ print "Adding $module from $dbdir\n";
my $db = Devel::Cover::DB->new(db => $dbdir);
# next unless $db->is_valid;
View
22 lib/Devel/Cover.pm
@@ -592,7 +592,7 @@ sub report
$Structure = Devel::Cover::DB::Structure->new(base => $DB);
$Structure->read_all;
$Structure->add_criteria(@collected);
- # use Data::Dumper; print STDERR Dumper $Structure;
+ # 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";
@@ -612,7 +612,7 @@ sub report
my %files;
$files{$_}++ for keys %{$Run{count}}, keys %{$Run{vec}};
- for my $file (keys %files)
+ for my $file (sort keys %files)
{
# print "looking at $file\n";
unless (use_file($file))
@@ -624,7 +624,7 @@ sub report
next;
}
- $Structure->add_digest($file, \%Run);
+ # $Structure->add_digest($file, \%Run);
for my $run (keys %{$Run{vec}{$file}})
{
@@ -634,6 +634,8 @@ sub report
$Structure->store_counts($file);
}
+ # use Data::Dumper; print STDERR "End structure", Dumper $Structure;
+
my $run = time . ".$$." . sprintf "%05d", rand 2 ** 16;
my $cover = Devel::Cover::DB->new
(
@@ -685,9 +687,9 @@ sub add_statement_cover
get_location($op);
return unless $File;
- # print STDERR "Stmt $File:$Line: <$deparse> $op $$op ", $op->name, "\n";
+ # print STDERR "Stmt $File:$Line: $op $$op ", $op->name, "\n";
- $Structure->set_file($File);
+ $Run{digests}{$File} ||= $Structure->set_file($File);
my $key = get_key($op);
my $val = $Coverage->{statement}{$key} || 0;
my ($n, $new) = $Structure->add_count("statement");
@@ -772,6 +774,7 @@ sub add_condition_cover
my $type = $op->name;
$type =~ s/assign$//;
+ $type = "or" if $type eq "dor";
my $c = $Coverage->{condition}{$key};
@@ -786,7 +789,7 @@ sub add_condition_cover
$name = $r->first->name if $name eq "sassign";
# TODO - exec? any others?
# print STDERR "Name [$name]\n";
- if ($name =~ /^const|s?refgen|gelem|die|undef$/)
+ if ($name =~ /^const|s?refgen|gelem|die|undef|bless$/)
{
$c = [ $c->[3], $c->[1] + $c->[2] ];
$count = 2;
@@ -1048,6 +1051,7 @@ sub get_cover
my $pkg = $stash->NAME;
my $file = $cv->FILE;
my %opts;
+ $Run{digests}{$File} ||= $Structure->set_file($File);
if (ref $Coverage_options{pod})
{
my $p;
@@ -1178,9 +1182,9 @@ now defunct. See L<http://lists.perl.org/showlist.cgi?name=perl-qa>.
Perl 5.7.0 is unsupported. Perl 5.8.2 or greater is recommended.
Whilst Perl 5.6 should mostly work you will probably miss out on
coverage information which would be available using a more modern
-version and will likely run into bugs in perl. Perl 5.8.0 and 5.8.1
-will give slightly different results to more recent versions due to
-changes in the op tree.
+version and will likely run into bugs in perl. Perl 5.8.0 will give
+slightly different results to more recent versions due to changes in the
+op tree.
=item * The ability to compile XS extensions.
View
44 lib/Devel/Cover/DB.pm
@@ -116,6 +116,7 @@ sub merge_runs
my $self = shift;
my $db = $self->{db};
# print "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;
@@ -165,25 +166,31 @@ sub merge
while (my ($fname, $frun) = each %{$from->{runs}})
{
- while (my ($file, $digest) = each %{$frun->{digest}})
+ while (my ($file, $digest) = each %{$frun->{digests}})
{
while (my ($name, $run) = each %{$self->{runs}})
{
- if (exists $run->{digest}{$file} &&
- $run->{digest}{$file} ne $digest)
+ # print "digests for $file: $digest, $run->{digests}{$file}\n";
+ if (exists $run->{digests}{$file} &&
+ $run->{digests}{$file} ne $digest)
{
# File has changed. Delete old coverage instead of merging.
print STDOUT "Devel::Cover: Deleting old coverage for ",
"changed file $file\n"
unless $Devel::Cover::Silent;
- delete $run->{digest}{$file};
- delete $run->{count} {$file};
- delete $run->{vec} {$file};
+ delete $run->{digests}{$file};
+ delete $run->{count} {$file};
+ delete $run->{vec} {$file};
}
}
}
}
+ _merge_hash($self->{runs}, $from->{runs});
+ _merge_hash($self->{collected}, $from->{collected});
+
+ return $self;
+
# When the database gets big, it's quicker to merge into what's
# already there.
@@ -195,6 +202,8 @@ sub merge
$from->{$_} = $self->{$_} unless $_ eq "runs" || $_ eq "collected";
}
+ # print "Giving ", Dumper($from);
+
$_[0] = $from;
}
@@ -377,6 +386,7 @@ sub add_statement
my %line;
for my $i (0 .. $#$fc)
{
+ # print "statement: $i\n";
my $l = $sc->[$i];
unless (defined $l)
{
@@ -392,7 +402,7 @@ sub add_statement
$cc->{$l}[$n][1] ||= $uc->{$l}[$n][0][1];
}
# use Data::Dumper; print Dumper $uc;
- # use Data::Dumper; print Dumper $cc;
+ # use Data::Dumper; print STDERR "cc: ", Dumper $cc;
}
sub add_time
@@ -609,15 +619,23 @@ sub cover
my $uncoverable = $self->uncoverable;
my $st = Devel::Cover::DB::Structure->new(base => $self->{base})->read_all;
- while (my ($run, $r) = each %{$self->{runs}})
+ # use Data::Dumper; print STDERR "runs: ", Dumper $self->{runs};
+ my @runs;
{
+ no warnings "numeric";
+ # TODO - change sort order
+ @runs = sort { $b <=> $a } keys %{$self->{runs}};
+ }
+ for my $run (@runs)
+ {
+ my $r = $self->{runs}{$run};
@{$self->{collected}}{@{$r->{collected}}} = ();
$st->add_criteria(@{$r->{collected}});
my $count = $r->{count};
+ # use Data::Dumper; print STDERR "run $run, count: ", Dumper $count;
while (my ($file, $f) = each %$count)
{
- # print "Looking at <$file>\n";
- my $digest = $r->{digest}{$file};
+ my $digest = $r->{digests}{$file};
unless ($digest)
{
print STDERR "Devel::Cover: Can't find digest for $file\n";
@@ -628,8 +646,6 @@ sub cover
"into $digests{$digest}\n"
if !$files{$file}++ && $digests{$digest};
my $cf = $cover->{$digests{$digest} ||= $file} ||= {};
- # print "Structure from $st->{file}\n";
- # use Data::Dumper;
# print STDERR "st ", Dumper($st),
# "f ", Dumper($f),
# "uc ", Dumper($uncoverable->{$digest});
@@ -637,16 +653,20 @@ sub cover
{
my $get = "get_$criterion";
my $sc = $st->$get($file);
+ # print STDERR "$criterion: ", Dumper $sc, $fc;
next unless $sc; # TODO - why?
my $cc = $cf->{$criterion} ||= {};
my $add = "add_$criterion";
+ # print STDERR "$add():\n", Dumper $cc, $sc, $fc;
$self->$add($cc, $sc, $fc, $uncoverable->{$digest}{$criterion});
+ # print STDERR "--> $add():\n", Dumper $cc;
# $cc - coverage being filled in
# $sc - structure information
# $fc - coverage from this file
# $uc - uncoverable information
}
}
+ # print STDERR "Cover: ", Dumper $cover;
}
unless (UNIVERSAL::isa($self->{cover}, "Devel::Cover::DB::Cover"))
View
56 lib/Devel/Cover/DB/Structure.pm
@@ -59,7 +59,9 @@ sub AUTOLOAD
{
my $self = shift;
my $file = shift;
- $file = "" unless defined $file;
+ # print "file: $file, condition: $c\n";
+ # TODO - why no file?
+ return unless defined $file;
$self->{f}{$file}{$c}
}
};
@@ -70,6 +72,8 @@ sub AUTOLOAD
{
my $self = shift;
my $file = shift;
+ die "Bad file: $func: $file, expecting $self->{file}"
+ unless $file eq $self->{file};
push @{$self->{f}{$file}{$criterion}}, @_;
};
}
@@ -93,6 +97,7 @@ sub set_subroutine
{
my $self = shift;
my ($sub_name, $file, $line) = @{$self}{qw( sub_name file line )} = @_;
+
$self->{additional} = 0;
if ($self->reuse($file))
{
@@ -100,7 +105,7 @@ sub set_subroutine
if (exists $self->{f}{$file}{start}{$line}{$sub_name})
{
# sub already exists - normal case
- # print STDERR "reuse $file:$line:$sub_name\n";
+ print STDERR "reuse $file:$line:$sub_name\n";
$self->{count}{$_}{$file} =
$self->{f}{$file}{start}{$line}{$sub_name}{$_}
for $self->criteria;
@@ -112,7 +117,7 @@ sub set_subroutine
if (exists $self->{additional_count}{($self->criteria)[0]}{$file})
{
# already had such a sub in module
- # print STDERR "reuse additional $file:$line:$sub_name\n";
+ print STDERR "reuse additional $file:$line:$sub_name\n";
$self->{count}{$_}{$file} =
$self->{f}{$file}{start}{$line}{$sub_name}{$_} =
($self->add_count($_))[0]
@@ -121,7 +126,7 @@ sub set_subroutine
else
{
# first such a sub in module
- # print STDERR "reuse first $file:$line:$sub_name\n";
+ print STDERR "reuse first $file:$line:$sub_name\n";
$self->{count}{$_}{$file} =
$self->{additional_count}{$_}{$file} =
$self->{f}{$file}{start}{$line}{$sub_name}{$_} =
@@ -133,7 +138,7 @@ sub set_subroutine
else
{
# first time sub seen in new structure
- # print STDERR "new $file:$line:$sub_name\n";
+ print STDERR "new $file:$line:$sub_name\n";
$self->{count}{$_}{$file} =
$self->{f}{$file}{start}{$line}{$sub_name}{$_} =
$self->get_count($_)
@@ -166,31 +171,44 @@ sub reuse
sub set_file
{
my $self = shift;
- ($self->{file}) = @_;
+ my ($file) = @_;
+ $self->{file} = $file;
+ $self->digest($file)
}
-sub add_digest
+sub add_digest_xxx
{
my $self = shift;
- my ($file, $run) = @_;
+ my ($file, $digest) = @_;
+ print "Adding $digest for $file\n";
+ $self->{f}{$file}{digest} = $digest;
+ push @{$self->{digests}{$digest}}, $file;
+}
+
+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;
- $run->{digest}{$file} = Digest::MD5->new->addfile($fh)->hexdigest;
- $self->set_digest($file, $run->{digest}{$file});
+ $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
{
warn "Devel::Cover: Can't open $file for MD5 digest: $!\n";
# warn "in ", `pwd`;
}
-}
-
-sub set_digest
-{
- my $self = shift;
- my ($file, $digest) = @_;
- $self->{f}{$file}{digest} = $digest;
+ $digest
}
sub get_count
@@ -238,6 +256,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";
Storable::nstore($self->{f}{$file}, $df); # unless -e $df;
}
}
@@ -248,6 +267,7 @@ sub read
my ($digest) = @_;
my $file = "$self->{base}/structure/$digest";
my $s = retrieve($file);
+ # print "reading $digest: ", Dumper $s;
$self->{f}{$s->{file}} = $s;
$self
}
@@ -258,7 +278,7 @@ sub read_all
my $dir = $self->{base};
$dir .= "/structure";
opendir D, $dir or return;
- for my $d (grep $_ !~ /\./, readdir D)
+ for my $d (sort grep $_ !~ /\./, readdir D)
{
$self->read($d);
}
View
16 lib/Devel/Cover/Report/Html_basic.pm
@@ -14,6 +14,7 @@ our $VERSION = "0.53";
use Devel::Cover::DB 0.53;
+use Getopt::Long;
use Template 2.00;
my $Template;
@@ -21,7 +22,7 @@ my %R;
sub print_stylesheet
{
- my $file = "$R{db}{db}/cover.css";
+ my $file = "$R{options}{outputdir}/cover.css";
open CSS, '>', $file or return;
my $p = tell DATA;
print CSS <DATA>;
@@ -80,7 +81,7 @@ sub print_summary
files => [ grep($R{db}->summary($_), @{$R{options}{file}}), "Total" ],
};
- my $html = "$R{options}{outputdir}/coverage.html";
+ my $html = "$R{options}{outputdir}/$R{options}{option}{outputfile}";
$Template->process("summary", $vars, $html) or die $Template->error();
print "HTML output sent to $html\n";
@@ -293,6 +294,17 @@ sub print_subroutines
$Template->process("subroutines", $vars, $html) or die $Template->error();
}
+sub get_options
+{
+ my ($self, $opt) = @_;
+ $opt->{option}{outputfile} = "coverage.html";
+ die "Bad option" unless
+ GetOptions($opt->{option},
+ qw(
+ outputfile=s
+ ));
+}
+
sub report
{
my ($pkg, $db, $options) = @_;
View
7 tests/cond_or
@@ -49,6 +49,7 @@ for (0 .. 10)
my $t = $y | $z;
my $u = $y || 0;
my $v = $y || undef;
+ my $w = $z || 0;
$p ||= $y;
$p ||= $z;
@@ -62,6 +63,12 @@ for (0 .. 10)
$x[13] ||= sub { 1 };
$x[14] ||= *::foo{SCALAR};
$x[15] ||= *STDIO{IO};
+ $x[16] ||= bless {}, "XXX";
+ $x[17] //= 0;
+ if ($] >= 5.009)
+ {
+ # eval '$x[17] //= 0';
+ }
}
# print join(", ", @x), "\n";
View
2  tests/md5.t
@@ -29,7 +29,7 @@ my $run_test = sub
open T, ">>$ft" or die "Cannot open $ft: $!";
print T "# blah blah\n";
- close T or die "Cannot close $ft: $!";
+ close T or die "Cannot close $ft: $!";
$test->run_command($test->test_command);
Please sign in to comment.
Something went wrong with that request. Please try again.