Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

import Devel::Cover 0.12

  • Loading branch information...
commit b6b6594403222f7f7ab031caf156efbd7ccefed5 1 parent 3884285
@pjcj authored
View
10 CHANGES
@@ -49,4 +49,12 @@ Release 0.11 - 10th September 2001
Devel::Cover::Statement.pm
Devel::Cover::Condition.pm
Devel::Cover::Pod.pm
- - Some inprovements to the cover program.
+ - Some improvements to the cover program.
+
+Release 0.12 - 14th October 2001
+ - Improve pod coverage by considering private subs.
+ - Add time coverage, aka profiling.
+ - Add:
+ Devel::Cover::DB::File.pm
+ Devel::Cover::Time.pm
+ - Abstract summary and percentage calculations to appropriate classes.
View
104 Cover.pm
@@ -12,31 +12,33 @@ use warnings;
use DynaLoader ();
-use Devel::Cover::DB 0.11;
-use Devel::Cover::Inc 0.11;
+use Devel::Cover::DB 0.12;
+use Devel::Cover::Inc 0.12;
our @ISA = qw( DynaLoader );
-our $VERSION = "0.11";
+our $VERSION = "0.12";
use B qw( class ppname main_root main_start main_cv svref_2object OPf_KIDS );
use B::Debug;
-BEGIN { eval "use Pod::Coverage" } # We'll use this if it is available.
-my $Covering = 1; # Coverage on.
+BEGIN { eval "use Pod::Coverage 0.06" } # We'll use this if it is available.
-my $DB = "cover_db"; # DB name.
-my $Indent = 0; # Data::Dumper indent.
-my $Merge = 1; # Merge databases.
+my $Covering = 1; # Coverage on.
+my $Profiling = 1; # Profiling on.
+
+my $DB = "cover_db"; # DB name.
+my $Indent = 0; # Data::Dumper indent.
+my $Merge = 1; # Merge databases.
my %Packages; # Packages we are interested in.
my @Ignore; # Packages to ignore.
my @Inc; # Original @INC to ignore.
my @Select; # Packages to select.
-my $Pod = $INC{"Pod/Coverage.pm"}; # Do pod coverage.
+my $Pod = $INC{"Pod/Coverage.pm"}; # Do pod coverage.
-my $Summary = 1; # Output coverage summary.
-my $Details = 0; # Output coverage details.
+my $Summary = 1; # Output coverage summary.
+my $Details = 0; # Output coverage details.
my %Cover; # Coverage data.
our $Cv; # Gets localised.
@@ -56,14 +58,16 @@ sub import
while (@_)
{
local $_ = shift;
- /^-db/ && do { $DB = shift; next };
- /^-details/ && do { $Details = shift; next };
- /^-merge/ && do { $Merge = shift; next };
- /^-indent/ && do { $Indent = shift; next };
- /^-summary/ && do { $Summary = shift; next };
- /^-ignore/ && do { push @Ignore, shift while $_[0] !~ /^-/; next };
- /^[-+]inc/ && do { push @Inc, shift while $_[0] !~ /^-/; next };
- /^-select/ && do { push @Select, shift while $_[0] !~ /^-/; next };
+ /^-coverage/ && do { $Covering = shift; next };
+ /^-db/ && do { $DB = shift; next };
+ /^-details/ && do { $Details = shift; next };
+ /^-indent/ && do { $Indent = shift; next };
+ /^-merge/ && do { $Merge = shift; next };
+ /^-profile/ && do { $Profiling = shift; next };
+ /^-summary/ && do { $Summary = shift; next };
+ /^-ignore/ && do { push @Ignore, shift while $_[0] !~ /^-/; next };
+ /^[-+]inc/ && do { push @Inc, shift while $_[0] !~ /^-/; next };
+ /^-select/ && do { push @Select, shift while $_[0] !~ /^-/; next };
warn __PACKAGE__ . ": Unknown option $_ ignored\n";
}
}
@@ -74,6 +78,12 @@ sub cover
set_cover($Covering > 0);
}
+sub profile
+{
+ ($Profiling) = @_;
+ set_profile($Profiling > 0 ? $Profiling : 0);
+}
+
my ($F, $L) = ("", 0);
# my $Level = 0;
@@ -96,8 +106,10 @@ sub get_location
sub report
{
- return unless $Covering > 0;
+ return unless $Covering > 0 || $Profiling > 0;
cover(-1);
+ profile(-1);
+
# print "Processing cover data\n@Inc\n";
$Cv = main_cv;
get_subs("main");
@@ -119,8 +131,7 @@ sub report
$name =~ s/\//::/g;
$Packages{$name} = 1;
# print "pod $name => $file\n";
- $Packages{$name} = [ Pod::Coverage->new(package => $name)->covered ]
- if $Pod;
+ $Packages{$name} = Pod::Coverage->new(package => $name) if $Pod;
push @roots, get_subs($name);
}
walk_sub($Cv, main_start);
@@ -142,10 +153,20 @@ sub report
if ($Pod)
{
my $name = $sub->[1]->SAFENAME;
- # print "$name => $package @{$Packages{$package}}\n";
get_location($sub->[1]->CV->START);
- push @{$Cover{$F}{pod}{$L}[0]},
- scalar grep { $_ eq $name } @{$Packages{$package}};
+ my $covered;
+ for ($Packages{$package}->covered)
+ {
+ $covered = 1, last if $_ eq $name;
+ }
+ unless ($covered)
+ {
+ for ($Packages{$package}->uncovered)
+ {
+ $covered = 0, last if $_ eq $name;
+ }
+ }
+ push @{$Cover{$F}{pod}{$L}[0]}, $covered if defined $covered;
}
}
@@ -170,9 +191,10 @@ sub report
sub walk_topdown
{
- my ($op) = @_;
+ my ($op) = @_;
my $class = class($op);
- my $cover = coverage()->{pack "I*", $$op};
+ my $key = pack "I*", $$op;
+ my $cover = coverage()->{$key};
# $Level++;
@@ -181,7 +203,9 @@ sub walk_topdown
if ($class eq "COP")
{
get_location($op);
- push @{$Cover{$F}{statement}{$L}[0]}, $cover || 0;
+ push @{$Cover{$F}{statement}{$L}}, [ $cover || 0 ];
+ my $p = profiles()->{$key};
+ push @{$Cover{$F}{time}{$L}}, [ $p ] if $p;
}
elsif (!null($op) &&
$op->name eq "null"
@@ -190,11 +214,14 @@ sub walk_topdown
# If the current op is null, but it was nextstate, we can still
# get at the file and line number, but we need to get dirty.
- $cover = coverage()->{pack "I*", ${$op->sibling}};
+ my $key = pack "I*", ${$op->sibling};
+ $cover = coverage()->{$key};
my $o = $op;
bless $o, "B::COP";
get_location($o);
- push @{$Cover{$F}{statement}{$L}[0]}, $cover || 0;
+ push @{$Cover{$F}{statement}{$L}}, [ $cover || 0 ];
+ my $p = profiles()->{$key};
+ push @{$Cover{$F}{time}{$L}}, [ $p ] if $p;
}
# print " " x ($Level * 2), "$F:$L ", $op->name, ":$class\n";
@@ -359,15 +386,17 @@ If you can't guess by the version number this is an alpha release.
Code coverage data are collected using a plugable runops function which
counts how many times each op is executed. These data are then mapped
-back to reality using the B compiler modules.
+back to reality using the B compiler modules. There is also a statement
+profiling facility which needs a better backend to be really useful.
The B<cover> program can be used to generate coverage reports.
-At the moment, only statement coverage and pod coverage information is
-reported. Condition coverage data is available, not accurate at the
-moment, though statement coverage data should be reasonable. Coverage
-data for other metrics are collected, but not reported. Coverage data
-for some metrics are not yet collected.
+At the moment, only statement, pod and time coverage information is
+reported. Condition coverage data is available, though not accurate at
+the moment. Statement coverage data should be reasonable, although
+there may be some statements which are no reported. Pod coverage comes
+from Pod::Coverage. Coverage data for other metrics are collected, but
+not reported. Coverage data for some metrics are not yet collected.
You may find that the results don't match your expectations. I would
imagine that at least one of them is wrong.
@@ -386,6 +415,7 @@ Requirements:
-ignore RE - Ignore files matching RE.
-indent indent - Set indentation level to indent. See Data::Dumper for details.
-merge val - Merge databases, for multiple test benches (default on).
+ -profile val - Turn on profiling iff val is true (default on).
-select RE - Only report on files matching RE.
-summary val - Print summary information iff val is true (default on).
@@ -410,7 +440,7 @@ Huh?
=head1 VERSION
-Version 0.11 - 10th September 2001
+Version 0.12 - 14th October 2001
=head1 LICENCE
View
137 Cover.xs
@@ -8,18 +8,29 @@
*
*/
+#ifdef __cplusplus
+extern "C" {
+#endif
+
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
+#ifdef __cplusplus
+}
+#endif
+
#ifdef PERL_OBJECT
#define CALLOP this->*PL_op
#else
#define CALLOP *PL_op
#endif
-static int covering = 1;
-HV *hv = 0;
+static int covering = 1,
+ profiling = 1;
+
+static HV *cover_hv = 0,
+ *profile_hv = 0;
union address /* Hack, hack, hackety hack. */
{
@@ -27,6 +38,78 @@ union address /* Hack, hack, hackety hack. */
void *plop;
};
+#ifdef HAS_GETTIMEOFDAY
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef WIN32
+#include <time.h>
+#else
+#include <sys/time.h>
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+static int
+elapsed()
+{
+ static struct timeval time;
+ static int sec = 0,
+ usec = 0;
+ int e;
+
+ gettimeofday(&time, NULL);
+ e = (time.tv_sec - sec) * 1e6 + time.tv_usec - usec;
+ sec = time.tv_sec;
+ usec = time.tv_usec;
+
+ /* fprintf(stderr, "[[[%d]]]\n", sec * 1e6 + usec); */
+
+ return e;
+}
+
+#endif /* HAS_GETTIMEOFDAY */
+
+#ifdef HAS_TIMES
+
+#ifndef HZ
+# ifdef CLK_TCK
+# define HZ CLK_TCK
+# else
+# define HZ 60
+# endif
+#endif
+
+static int
+cpu()
+{
+ static struct tms time;
+ static int utime = 0,
+ stime = 0;
+ int e;
+
+#ifndef VMS
+ (void)PerlProc_times(&time);
+#else
+ (void)PerlProc_times((tbuffer_t *)&time);
+#endif
+
+ e = time.tms_utime - utime + time.tms_stime - stime;
+ utime = time.tms_utime;
+ stime = time.tms_stime;
+
+ /* fprintf(stderr, "<<<%d>>>\n", utime + stime); */
+
+ return e / HZ;
+}
+
+#endif /* HAS_TIMES */
+
+
static int
runops_cover(pTHX)
{
@@ -34,7 +117,13 @@ runops_cover(pTHX)
SV **count;
IV c;
- if (!hv) hv = newHV();
+#ifdef HAS_GETTIMEOFDAY
+ static COP *cop = 0;
+ if (!profile_hv) profile_hv = newHV();
+ elapsed();
+#endif
+
+ if (!cover_hv) cover_hv = newHV();
addr.ch[sizeof(PL_op)] = '\0';
// fprintf(stderr, "runops_cover\n");
@@ -43,8 +132,20 @@ runops_cover(pTHX)
if (covering)
{
addr.plop = PL_op;
- count = hv_fetch(hv, addr.ch, sizeof(PL_op), 1);
- c = SvTRUE(*count) ? SvIV(*count) + 1 : 1;
+ count = hv_fetch(cover_hv, addr.ch, sizeof(PL_op), 1);
+ c = SvTRUE(*count) ? SvIV(*count) + 1 : 1;
+ sv_setiv(*count, c);
+ }
+ if (profiling && PL_curcop != cop)
+ {
+ addr.plop = cop;
+ cop = PL_curcop;
+ count = hv_fetch(profile_hv, addr.ch, sizeof(PL_op), 1);
+ c = (SvTRUE(*count) ? SvIV(*count) : 0) + elapsed();
+ /*
+ c = (SvTRUE(*count) ? SvIV(*count) : 0) +
+ profiling == 1 ? cpu() : elapsed();
+ */
sv_setiv(*count, c);
}
PERL_ASYNC_CHECK();
@@ -76,14 +177,34 @@ set_cover(flag)
int flag
PPCODE:
// fprintf(stderr, "Cover set to %d\n", flag);
- PL_runops = (covering = flag) ? runops_cover : runops_orig;
+ PL_runops = ((covering = flag) || profiling)
+ ? runops_cover
+ : runops_orig;
+
+void
+set_profile(flag)
+ int flag
+ PPCODE:
+ // fprintf(stderr, "Cover set to %d\n", flag);
+ PL_runops = ((profiling = flag) || covering)
+ ? runops_cover
+ : runops_orig;
SV *
coverage()
CODE:
ST(0) = sv_newmortal();
- if (hv)
- sv_setsv(ST(0), newRV_inc((SV*) hv));
+ if (cover_hv)
+ sv_setsv(ST(0), newRV_inc((SV*) cover_hv));
+ else
+ ST(0) = &PL_sv_undef;
+
+SV *
+profiles()
+ CODE:
+ ST(0) = sv_newmortal();
+ if (profile_hv)
+ sv_setsv(ST(0), newRV_inc((SV*) profile_hv));
else
ST(0) = &PL_sv_undef;
View
25 Cover/Condition.pm
@@ -12,7 +12,7 @@ use warnings;
use base "Devel::Cover::Criterion";
-our $VERSION = "0.11";
+our $VERSION = "0.12";
sub covered { scalar grep $_, @{$_[0]} }
sub total { scalar @{$_[0]} }
@@ -22,6 +22,27 @@ sub percentage
}
sub error { scalar grep !$_, @{$_[0]} }
+sub calculate_summary
+{
+ my $self = shift;
+ my ($db, $file) = @_;
+
+ my $s = $db->{summary};
+
+ my $t = @$self;
+ my $c = grep { $_ } @$self;
+
+ $s->{$file}{condition}{total} += $t;
+ $s->{$file}{total}{total} += $t;
+ $s->{Total}{condition}{total} += $t;
+ $s->{Total}{total}{total} += $t;
+
+ $s->{$file}{condition}{covered} += $c;
+ $s->{$file}{total}{covered} += $c;
+ $s->{Total}{condition}{covered} += $c;
+ $s->{Total}{total}{covered} += $c;
+}
+
1
__END__
@@ -56,7 +77,7 @@ Huh?
=head1 VERSION
-Version 0.11 - 10th September 2001
+Version 0.12 - 14th October 2001
=head1 LICENCE
View
11 Cover/Criterion.pm
@@ -10,7 +10,7 @@ package Devel::Cover::Criterion;
use strict;
use warnings;
-our $VERSION = "0.11";
+our $VERSION = "0.12";
sub new
{
@@ -25,6 +25,13 @@ sub total { "n/a" }
sub percentage { "n/a" }
sub error { "n/a" }
+sub calculate_percentage
+{
+ my $class = shift;
+ my ($db, $s) = @_;
+ $s->{percentage} = $s->{covered} * 100 / $s->{total};
+}
+
1
__END__
@@ -59,7 +66,7 @@ Huh?
=head1 VERSION
-Version 0.11 - 10th September 2001
+Version 0.12 - 14th October 2001
=head1 LICENCE
View
197 Cover/DB.pm
@@ -10,21 +10,28 @@ package Devel::Cover::DB;
use strict;
use warnings;
+use Devel::Cover::DB::File 0.12;
+use Devel::Cover::Criterion 0.12;
+use Devel::Cover::Statement 0.12;
+use Devel::Cover::Condition 0.12;
+use Devel::Cover::Pod 0.12;
+use Devel::Cover::Time 0.12;
+
use Carp;
use Data::Dumper;
use File::Path;
-our $VERSION = "0.11";
+our $VERSION = "0.12";
-my $DB = "cover.1"; # Version 1 of the database.
+my $DB = "cover.2"; # Version 2 of the database.
sub new
{
my $class = shift;
my $self =
{
- criteria => [ qw( statement branch path condition pod ) ],
- criteria_short => [ qw( stmt branch path cond pod ) ],
+ criteria => [ qw( statement branch path condition pod time ) ],
+ criteria_short => [ qw( stmt branch path cond pod time ) ],
indent => 1,
cover => {},
@_
@@ -156,7 +163,7 @@ sub _merge_hash
else
{
# A scalar (or a blessed scalar). We know there is no into
- # array, or we would just have merged with it.
+ # array, or we would have just merged with it.
$into->{$fkey} = $fval;
}
@@ -185,73 +192,28 @@ sub calculate_summary
{
my $self = shift;
my %options = @_;
+
return if defined $self->{summary} && !$options{force};
my $s = $self->{summary} = {};
- my $cover = $self->{cover};
- my ($t, $c, $lines);
- for my $file (sort keys %$cover)
+ for my $file ($self->cover->items)
{
- if ($options{statement})
- {
- $t = $c = 0;
- $lines = $cover->{$file}{statement};
- for my $line (sort { $a <=> $b } keys %$lines)
- {
- my $l = $lines->{$line};
- $t += @$l;
- $c += grep { $_->[0] } @$l;
- }
- $s->{$file}{statement}{total} = $t;
- $s->{$file}{statement}{covered} = $c;
- $s->{$file}{total}{total} += $t;
- $s->{$file}{total}{covered} += $c;
- $s->{Total}{statement}{total} += $t;
- $s->{Total}{statement}{covered} += $c;
- $s->{Total}{total}{total} += $t;
- $s->{Total}{total}{covered} += $c;
- }
+ $self->cover->get($file)->calculate_summary($self, $file, \%options);
+ }
- if ($options{condition})
- {
- $t = $c = 0;
- $lines = $cover->{$file}{condition};
- for my $line (sort { $a <=> $b } keys %$lines)
- {
- my $l = $lines->{$line};
- $t += @$l;
- $c += grep { !grep { !$_ } @$_ } @$l;
- }
- $s->{$file}{condition}{total} = $t;
- $s->{$file}{condition}{covered} = $c;
- $s->{$file}{total}{total} += $t;
- $s->{$file}{total}{covered} += $c;
- $s->{Total}{condition}{total} += $t;
- $s->{Total}{condition}{covered} += $c;
- $s->{Total}{total}{total} += $t;
- $s->{Total}{total}{covered} += $c;
- }
+ for my $file ($self->cover->items)
+ {
+ $self->cover->get($file)->calculate_percentage($self, $s->{$file});
+ }
- if ($options{pod} && $INC{"Pod/Coverage.pm"})
- {
- $t = $c = 0;
- $lines = $cover->{$file}{pod};
- for my $line (sort { $a <=> $b } keys %$lines)
- {
- my $l = $lines->{$line};
- $t += @$l;
- $c += grep { $_->[0] } @$l;
- }
- $s->{$file}{pod}{total} = $t;
- $s->{$file}{pod}{covered} = $c;
- $s->{$file}{total}{total} += $t;
- $s->{$file}{total}{covered} += $c;
- $s->{Total}{pod}{total} += $t;
- $s->{Total}{pod}{covered} += $c;
- $s->{Total}{total}{total} += $t;
- $s->{Total}{total}{covered} += $c;
- }
+ my $t = $self->{summary}{Total};
+ for my $criterion ($self->criteria)
+ {
+ next unless exists $t->{$criterion};
+ my $c = "Devel::Cover::\u$criterion";
+ $c->calculate_percentage($self, $t->{$criterion});
}
+ Devel::Cover::Criterion->calculate_percentage($self, $t->{total});
}
sub trimmed_file
@@ -264,70 +226,35 @@ sub trimmed_file
sub print_summary
{
my $self = shift;
- my %options = (statement => 1, pod => 1, @_);
+ my %options = (statement => 1, condition => 1, pod => 1, time => 1, @_);
$self->calculate_summary(%options);
my $format = sub
{
- my ($part, $critrion) = @_;
- exists $part->{$critrion}
- ? sprintf "%6.2f", $part->{$critrion}{total}
- ? $part->{$critrion}{covered} * 100 /
- $part->{$critrion}{total}
- : 100
+ my ($part, $criterion) = @_;
+ exists $part->{$criterion}
+ ? sprintf "%5.2f", $part->{$criterion}{percentage}
: "n/a"
};
- my $fmt = "%-35s %6s %6s %6s %6s %6s %6s\n";
- printf $fmt, "-" x 35, ("------") x 6;
+ my $fmt = "%-28s" . " %6s" x 7 . "\n";
+ printf $fmt, "-" x 28, ("------") x 7;
printf $fmt, "File", @{$self->{all_criteria_short}};
- printf $fmt, "-" x 35, ("------") x 6;
+ printf $fmt, "-" x 28, ("------") x 7;
my $s = $self->{summary};
for my $file (grep($_ ne "Total", sort keys %$s), "Total")
{
printf $fmt,
- trimmed_file($file, 35),
+ trimmed_file($file, 28),
map { $format->($s->{$file}, $_) } @{$self->{all_criteria}};
}
- printf $fmt, "-" x 35, ("------") x 6;
+ printf $fmt, "-" x 28, ("------") x 7;
print "\n\n";
}
-sub print_details_hash
-{
- my $self = shift;
- my (@files) = @_;
- @files = sort keys %{$self->{cover}} unless @files;
- for my $file (@files)
- {
- print "$file\n\n";
- my $lines = $self->{cover}{$file}{statement};
- my $fmt = "%-5d: %6s %s\n";
-
- open F, $file or carp("Unable to open $file: $!"), next;
-
- while (<F>)
- {
- if (exists $lines->{$.})
- {
- my @c = @{$lines->{$.}};
- printf "%5d: %6d %s", $., shift(@c)->[0], $_;
- printf " : %6d\n", shift(@c)->[0] while @c;
- }
- else
- {
- printf "%5d: %s", $., $_;
- }
- }
-
- close F or croak "Unable to close $file: $!";
- print "\n\n";
- }
-}
-
sub cover
{
my $self = shift;
@@ -362,6 +289,12 @@ sub cover
keys %$self
};
+ *Devel::Cover::DB::Base::values = sub
+ {
+ my $self = shift;
+ values %$self
+ };
+
*Devel::Cover::DB::Base::get = sub
{
my $self = shift;
@@ -382,7 +315,7 @@ sub cover
my $c = "Devel::Cover::DB::$class";
no strict "refs";
@{"${c}::ISA"} = $base;
- *{"${c}::$functions->[0]"} = \&{"${base}::items"};
+ *{"${c}::$functions->[0]"} = \&{"${base}::values"};
*{"${c}::$functions->[1]"} = \&{"${base}::get"};
}
@@ -407,12 +340,44 @@ sub cover
$self->{cover}
}
+sub print_details_hash
+{
+ my $self = shift;
+ my (@files) = @_;
+ @files = sort keys %{$self->{cover}} unless @files;
+ for my $file (@files)
+ {
+ print "$file\n\n";
+ my $lines = $self->{cover}{$file}{statement};
+ my $fmt = "%-5d: %6s %s\n";
+
+ open F, $file or carp("Unable to open $file: $!"), next;
+
+ while (<F>)
+ {
+ if (exists $lines->{$.})
+ {
+ my @c = @{$lines->{$.}};
+ printf "%5d: %6d %s", $., shift(@c)->[0], $_;
+ printf " : %6d\n", shift(@c)->[0] while @c;
+ }
+ else
+ {
+ printf "%5d: %s", $., $_;
+ }
+ }
+
+ close F or croak "Unable to close $file: $!";
+ print "\n\n";
+ }
+}
+
sub print_details
{
my $self = shift;
my (@files) = @_;
my $cover = $self->cover;
- @files = sort $cover->files unless @files;
+ @files = sort $cover->items unless @files;
for my $file (@files)
{
print "$file\n\n";
@@ -481,15 +446,15 @@ Returns a Devel::Cover::DB::Cover object. From here all the coverage
data may be accessed.
my $cover = $db->cover;
- for my $file ($cover->files)
+ for my $file ($cover->items)
{
print "$file\n";
my $f = $cover->file($file);
- for my $criterion ($f->criteria)
+ for my $criterion ($f->items)
{
print " $criterion\n";
my $c = $f->criterion($criterion);
- for my $location ($c->locations)
+ for my $location ($c->items)
{
my $l = $c->location($location);
print " $location @$l\n";
@@ -501,7 +466,7 @@ Data for different criteria will be in different formats, so that will
need special handling, but I'll deal with that when we have the data for
different criteria.
-If you don't want to remember all the method names, use items() instead
+If you don't want to remember all the method names, use values() instead
of files(), criteria() and locations() and get() instead of file(),
criterion() and location().
@@ -513,7 +478,7 @@ Huh?
=head1 VERSION
-Version 0.11 - 10th September 2001
+Version 0.12 - 14th October 2001
=head1 LICENCE
View
98 Cover/DB/File.pm
@@ -0,0 +1,98 @@
+# Copyright 2001, 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
+
+package Devel::Cover::DB::File;
+
+use strict;
+use warnings;
+
+use Devel::Cover::Criterion 0.12;
+use Devel::Cover::Statement 0.12;
+use Devel::Cover::Condition 0.12;
+use Devel::Cover::Pod 0.12;
+use Devel::Cover::Time 0.12;
+
+our $VERSION = "0.12";
+
+sub calculate_summary
+{
+ my $self = shift;
+ my ($db, $file, $options) = @_;
+
+ my $s = $db->{summary}{$file} ||= {};
+
+ for my $criterion ($self->items)
+ {
+ next unless $options->{$criterion};
+ # use Data::Dumper;
+ # print STDERR $criterion, " ", Dumper $self->$criterion();
+ for my $location ($self->$criterion()->locations)
+ {
+ for my $cover (@$location)
+ {
+ $cover->calculate_summary($db, $file);
+ }
+ }
+ }
+}
+
+sub calculate_percentage
+{
+ my $self = shift;
+ my ($db, $s) = @_;
+
+ # use Data::Dumper;
+ # print STDERR Dumper $s;
+
+ for my $criterion ($self->items)
+ {
+ next unless exists $s->{$criterion};
+ my $c = "Devel::Cover::\u$criterion";
+ # print "$c\n";
+ $c->calculate_percentage($db, $s->{$criterion});
+ }
+ Devel::Cover::Criterion->calculate_percentage($db, $s->{total});
+}
+
+1
+
+__END__
+
+=head1 NAME
+
+Devel::Cover::DB::File - Code coverage metrics for Perl
+
+=head1 SYNOPSIS
+
+ use Devel::Cover::DB::File;
+
+=head1 DESCRIPTION
+
+=head1 SEE ALSO
+
+ Devel::Cover
+
+=head1 METHODS
+
+=head1 BUGS
+
+Huh?
+
+=head1 VERSION
+
+Version 0.12 - 14th October 2001
+
+=head1 LICENCE
+
+Copyright 2001, 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
2  Cover/Op.pm
@@ -10,7 +10,7 @@ package Devel::Cover::Op;
use strict;
use warnings;
-our $VERSION = "0.11";
+our $VERSION = "0.12";
use Devel::Cover qw( -inc B -indent 1 -details 1 );
use B::Concise qw( set_style add_callback );
View
29 Cover/Pod.pm
@@ -12,13 +12,38 @@ use warnings;
use base "Devel::Cover::Criterion";
-our $VERSION = "0.11";
+use Pod::Coverage;
+
+our $VERSION = "0.12";
sub covered { $_[0]->[0] ? 1 : 0 }
sub total { 1 }
sub percentage { $_[0]->[0] ? 100 : 0 }
sub error { !$_[0]->[0] }
+sub calculate_summary
+{
+ my $self = shift;
+ my ($db, $file) = @_;
+
+ return unless $INC{"Pod/Coverage.pm"};
+
+ my $s = $db->{summary};
+
+ $s->{$file}{pod}{total}++;
+ $s->{$file}{total}{total}++;
+ $s->{Total}{pod}{total}++;
+ $s->{Total}{total}{total}++;
+
+ if ($self->[0])
+ {
+ $s->{$file}{pod}{covered}++;
+ $s->{$file}{total}{covered}++;
+ $s->{Total}{pod}{covered}++;
+ $s->{Total}{total}{covered}++;
+ }
+}
+
1
__END__
@@ -53,7 +78,7 @@ Huh?
=head1 VERSION
-Version 0.11 - 10th September 2001
+Version 0.12 - 14th October 2001
=head1 LICENCE
View
25 Cover/Statement.pm
@@ -12,13 +12,34 @@ use warnings;
use base "Devel::Cover::Criterion";
-our $VERSION = "0.11";
+our $VERSION = "0.12";
sub covered { $_[0]->[0] }
sub total { 1 }
sub percentage { $_[0]->[0] ? 100 : 0 }
sub error { !$_[0]->[0] }
+sub calculate_summary
+{
+ my $self = shift;
+ my ($db, $file) = @_;
+
+ my $s = $db->{summary};
+
+ $s->{$file}{statement}{total}++;
+ $s->{$file}{total}{total}++;
+ $s->{Total}{statement}{total}++;
+ $s->{Total}{total}{total}++;
+
+ if ($self->[0])
+ {
+ $s->{$file}{statement}{covered}++;
+ $s->{$file}{total}{covered}++;
+ $s->{Total}{statement}{covered}++;
+ $s->{Total}{total}{covered}++;
+ }
+}
+
1
__END__
@@ -53,7 +74,7 @@ Huh?
=head1 VERSION
-Version 0.11 - 10th September 2001
+Version 0.12 - 14th October 2001
=head1 LICENCE
View
83 Cover/Time.pm
@@ -0,0 +1,83 @@
+# Copyright 2001, 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
+
+package Devel::Cover::Time;
+
+use strict;
+use warnings;
+
+use base "Devel::Cover::Criterion";
+
+our $VERSION = "0.12";
+
+sub covered { $_[0]->[0] }
+sub total { 1 }
+sub percentage { $_[0]->[0] ? 100 : 0 }
+sub error { !$_[0]->[0] }
+
+sub calculate_summary
+{
+ my $self = shift;
+ my ($db, $file) = @_;
+
+ $db->{summary}{$file}{time}{total} += $self->[0];
+ $db->{summary}{Total}{time}{total} += $self->[0];
+}
+
+sub calculate_percentage
+{
+ my $class = shift;
+ my ($db, $s) = @_;
+ $s->{percentage} = $s->{total} * 100 / $db->{summary}{Total}{time}{total};
+}
+
+1
+
+__END__
+
+=head1 NAME
+
+Devel::Cover::Time - Code coverage metrics for Perl
+
+=head1 SYNOPSIS
+
+ use Devel::Cover::Time;
+
+=head1 DESCRIPTION
+
+This module provides ...
+
+=head1 SEE ALSO
+
+ Devel::Cover
+
+=head1 METHODS
+
+=head2 new
+
+ my $db = Devel::Cover::DB->new(db => "my_coverage_db");
+
+Contructs the DB from the specified database.
+
+=head1 BUGS
+
+Huh?
+
+=head1 VERSION
+
+Version 0.12 - 14th October 2001
+
+=head1 LICENCE
+
+Copyright 2001, 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
2  Cover/Tutorial.pod
@@ -163,7 +163,7 @@ basis for future research.
=head1 VERSION
-Version 0.11 - 10th September 2001
+Version 0.12 - 14th October 2001
=head1 LICENCE
View
2  MANIFEST
@@ -12,6 +12,8 @@ Cover/Criterion.pm
Cover/Statement.pm
Cover/Condition.pm
Cover/Pod.pm
+Cover/Time.pm
+Cover/DB/File.pm
t/Compare.pm
t/t1.t
t/T1.pm
View
27 Makefile.PL
@@ -16,8 +16,8 @@ use ExtUtils::MakeMaker;
$| = 1;
-my $Version = "0.11";
-my $Date = "10th September 2001";
+my $Version = "0.12";
+my $Date = "14th October 2001";
my $Author = 'pjcj@cpan.org';
my @perlbug = ("perlbug", "-a", $Author,
@@ -71,24 +71,25 @@ WriteMakefile
);
print "\n";
-print "checking for Pod::Coverage.pm........ ";
+print "checking for Pod::Coverage.pm version 0.06 ........ ";
+
+my $e = <<EOM;
+
+Pod::Coverage.pm 0.06 is required to do pod coverage. This will tell
+you how well you have documented your modules. Pod coverage will be
+unavailable until you install this module, available from CPAN. In the
+meantime, you may continue to use the rest of Devel::Cover.pm.
+EOM
eval "use Pod::Coverage";
if (my $m = $INC{"Pod/Coverage.pm"})
{
- print "$m\n";
+ my $v = eval { no warnings; $Pod::Coverage::VERSION };
+ print $v < 0.06 ? "$v\n\n$e\n" : "$v $m\n";
}
else
{
- print <<EOM;
-not found
-
-Pod::Coverage.pm is required to do pod coverage. This will tell you how well
-you have documented your modules. Pod coverage will be unavailable until you
-install this module, available from CPAN. In the meantime, you may continue to
-use the rest of Devel::Cover.pm.
-
-EOM
+ print "not found\n\n$e\n";
}
print <<EOM if 0;
View
14 README
@@ -8,15 +8,17 @@ DESCRIPTION
Code coverage data are collected using a plugable runops function which
counts how many times each op is executed. These data are then mapped
- back to reality using the B compiler modules.
+ back to reality using the B compiler modules. There is also a statement
+ profiling facility which needs a better backend to be really useful.
The cover program can be used to generate coverage reports.
- At the moment, only statement coverage and pod coverage information is
- reported. Condition coverage data is available, not accurate at the
- moment, though statement coverage data should be reasonable. Coverage
- data for other metrics are collected, but not reported. Coverage data
- for some metrics are not yet collected.
+ At the moment, only statement, pod and time coverage information is
+ reported. Condition coverage data is available, though not accurate at
+ the moment. Statement coverage data should be reasonable, although there
+ may be some statements which are no reported. Pod coverage comes from
+ Pod::Coverage. Coverage data for other metrics are collected, but not
+ reported. Coverage data for some metrics are not yet collected.
You may find that the results don't match your expectations. I would
imagine that at least one of them is wrong.
View
53 cover
@@ -12,12 +12,13 @@ require 5.6.1;
use strict;
use warnings;
-our $VERSION = "0.11";
+our $VERSION = "0.12";
-use Devel::Cover::DB 0.11;
-use Devel::Cover::Statement 0.11;
-use Devel::Cover::Condition 0.11;
-use Devel::Cover::Pod 0.11;
+use Devel::Cover::DB 0.12;
+use Devel::Cover::Statement 0.12;
+use Devel::Cover::Condition 0.12;
+use Devel::Cover::Pod 0.12;
+use Devel::Cover::Time 0.12;
use Getopt::Long;
BEGIN { eval "use Pod::Coverage" } # We'll use this if it is available.
@@ -33,20 +34,10 @@ my $Options =
single_file => 0,
statement => 1,
summary => 1,
+ time => 1,
total => 1,
};
-sub pc
-{
- my ($part, $critrion) = @_;
- exists $part->{$critrion}
- ? sprintf "%6.2f", $part->{$critrion}{total}
- ? $part->{$critrion}{covered} * 100 /
- $part->{$critrion}{total}
- : 100
- : "n/a"
-};
-
sub print_html_top
{
my ($FH, $title) = @_;
@@ -107,14 +98,25 @@ EOH
print $FH -e $file
? qq( <td align="LEFT"> <a href="$fn#$file">$file</a> </td>\n)
: qq( <td align="LEFT"> $file </td>\n);
- for ($db->all_criteria)
+
+ my $part = $db->{summary}{$file};
+ for my $criterion ($db->all_criteria)
{
- my $pc = $Options->{$_} ? pc($db->{summary}{$file}, $_) : "n/a";
+ my $pc = ($Options->{$criterion} && exists $part->{$criterion})
+ ? sprintf "%6.2f", $part->{$criterion}{percentage}
+ : "n/a";
+
my $bg = "";
if ($pc ne "n/a")
{
- my $c = $pc * 2.55;
+ my $c;
+ $c = $pc * 2.55;
$c = 255 if $c > 255;
+ if ($criterion eq "time")
+ {
+ $c = 255 - $c;
+ $c = 255 if $file eq "Total";
+ }
$bg = sprintf ' bgcolor="#ff%02x00"', $c;
}
print $FH " <td$bg> $pc </td>\n";
@@ -129,7 +131,7 @@ EOH
# $Data::Dumper::Indent = 1;
# print Dumper $cover;
- @files = sort $cover->files unless @files;
+ @files = sort $cover->items unless @files;
for my $file (@files)
{
@@ -193,8 +195,10 @@ EOH
next unless $Options->{$c};
my $o = shift @{$criteria{$c}};
$more ||= @{$criteria{$c}};
- my $value = $o
- ? ($c =~ /statement|pod/) ? $o->covered : $o->percentage
+ my $value = $o
+ ? ($c =~ /statement|pod|time/)
+ ? $o->covered
+ : $o->percentage
: "&nbsp";
my $bg = $o
? ' bgcolor="#' . ($o->error ? 'ff0000"' : '00ff00"')
@@ -247,6 +251,7 @@ sub get_options
single_file!
statement!
summary!
+ time!
total!
version|v!
));
@@ -279,7 +284,7 @@ cover - report coverage statistics
=head1 SYNOPSIS
- rideaudit [-hiv] -summary -details -html coverage_database
+ cover [-hiv] -summary -details -html coverage_database
=head1 DESCRIPTION
@@ -324,7 +329,7 @@ Huh?
=head1 VERSION
-Version 0.11 - 10th September 2001
+Version 0.12 - 14th October 2001
=head1 LICENCE
View
1  session.vim
@@ -3,6 +3,7 @@ e Makefile.PL
e Cover.pm
e Cover/DB.pm
e Cover/Op.pm
+e Cover.xs
e cover
e CHANGES
e TODO
View
2  t/Compare.pm
@@ -10,7 +10,7 @@ package Compare;
use strict;
use warnings;
-our $VERSION = "0.11";
+our $VERSION = "0.12";
sub compare
{
View
5 t/T1.pm
@@ -10,6 +10,11 @@ package T1;
my $y = 7;
$y++;
+sub _xx
+{
+ $y++;
+}
+
sub yy
{
$y++;
View
96 t/t1.t
@@ -10,8 +10,8 @@
use strict;
use warnings;
-use Devel::Cover::DB 0.11;
-use Devel::Cover 0.11 qw( -db t1 -select T1 -indent 1 -merge 0 );
+use Devel::Cover::DB 0.12;
+use Devel::Cover 0.12 qw( -db t1 -select T1 -indent 1 -merge 0 );
use Test;
@@ -65,33 +65,50 @@ __DATA__
$cover = {
't/T1.pm' => {
'pod' => {
- '20' => [
+ '25' => [
[
0
]
],
- '15' => [
+ '20' => [
[
1
]
]
},
'statement' => {
- '21' => [
+ '25' => [
[
1001
]
],
- '20' => [
+ '26' => [
[
1001
]
],
+ '20' => [
+ [
+ 0
+ ]
+ ],
'15' => [
[
0
]
]
+ },
+ 'time' => {
+ '25' => [
+ [
+ 12879
+ ]
+ ],
+ '26' => [
+ [
+ 9550
+ ]
+ ]
}
},
't/t1.t' => {
@@ -103,13 +120,17 @@ $cover = {
],
'32' => [
[
- 1,
+ 1
+ ],
+ [
1001
]
],
'40' => [
[
- 1001,
+ 1001
+ ],
+ [
3003
]
],
@@ -130,7 +151,7 @@ $cover = {
],
'24' => [
[
- 1
+ 2
]
],
'37' => [
@@ -149,6 +170,59 @@ $cover = {
]
]
},
+ 'time' => {
+ '35' => [
+ [
+ 15497
+ ]
+ ],
+ '32' => [
+ [
+ 62
+ ],
+ [
+ 6961
+ ]
+ ],
+ '40' => [
+ [
+ 25275
+ ],
+ [
+ 30620
+ ]
+ ],
+ '47' => [
+ [
+ 17303
+ ]
+ ],
+ '42' => [
+ [
+ 35395
+ ]
+ ],
+ '24' => [
+ [
+ 1232
+ ]
+ ],
+ '37' => [
+ [
+ 18324
+ ]
+ ],
+ '45' => [
+ [
+ 15205
+ ]
+ ],
+ '55' => [
+ [
+ 27
+ ]
+ ]
+ },
'condition' => {
'35' => [
[
@@ -158,7 +232,7 @@ $cover = {
],
'32' => [
[
- 1002,
+ 1003,
0
]
],
@@ -170,7 +244,7 @@ $cover = {
],
'37' => [
[
- 1002,
+ 1001,
1001
]
],
View
22 t/t2.t
@@ -10,8 +10,8 @@
use strict;
use warnings;
-use Devel::Cover::DB 0.11;
-use Devel::Cover 0.11 qw( -db t2 +inc blib -indent 1 -merge 0 );
+use Devel::Cover::DB 0.12;
+use Devel::Cover 0.12 qw( -db t2 +inc blib -indent 1 -merge 0 );
use Test;
@@ -42,7 +42,6 @@ $cover = {
'statement' => {
'22' => [
[
- 2,
1
]
],
@@ -56,6 +55,23 @@ $cover = {
1
]
]
+ },
+ 'time' => {
+ '22' => [
+ [
+ 266
+ ]
+ ],
+ '28' => [
+ [
+ 32
+ ]
+ ],
+ '30' => [
+ [
+ 23
+ ]
+ ]
}
}
};
Please sign in to comment.
Something went wrong with that request. Please try again.