Permalink
Browse files

import Devel::Cover 0.04

  • Loading branch information...
1 parent a72ad45 commit a9f2eeecdaa62ce043eaeec33d88cc247d06b001 @pjcj committed Nov 3, 2004
Showing with 291 additions and 112 deletions.
  1. +4 −0 CHANGES
  2. +57 −24 Cover.pm
  3. +68 −0 Cover/Op.pm
  4. +41 −23 Cover/Process.pm
  5. +1 −0 MANIFEST
  6. +2 −2 Makefile.PL
  7. +10 −7 README
  8. +108 −56 t/t1.t
View
@@ -10,3 +10,7 @@ Release 0.02 - 10th April 2001
Release 0.03 - 10th April 2001
- Add detailed output.
- Add -d option to turn it on.
+
+Release 0.04 - 12th April 2001
+ - Include Devel::Cover::Op
+ - Add condition coverage (sort of).
View
@@ -12,10 +12,10 @@ use warnings;
use DynaLoader ();
-use Devel::Cover::Process 0.03;
+use Devel::Cover::Process 0.04;
our @ISA = qw( DynaLoader );
-our $VERSION = "0.03";
+our $VERSION = "0.04";
use B qw( class main_root main_start main_cv svref_2object OPf_KIDS );
use Data::Dumper;
@@ -43,10 +43,11 @@ sub import
while (@_)
{
local $_ = shift;
- /^-i/ && do { $Indent = shift; next };
- /^-o/ && do { $Output = shift; next };
- /^-S/ && do { $Summary = 0; next };
- /^-d/ && do { $Details = 1; next };
+ /^-indent/ && do { $Indent = shift; next };
+ /^-output/ && do { $Output = shift; next };
+ /^-inc/ && do { push @Inc, shift; next };
+ /^-summary/ && do { $Summary = shift; next };
+ /^-details/ && do { $Details = shift; next };
warn __PACKAGE__ . ": Unknown option $_ ignored\n";
}
}
@@ -61,13 +62,13 @@ sub report
{
return unless $Covering > 0;
cover(-1);
- # print "Processing cover data\n";
+ # print "Processing cover data\n@Inc\n";
get_subs("main");
INC:
while (my ($name, $file) = each %INC)
{
- # print "$name => $file\n";
for (@Inc) { next INC if $file =~ /^\Q$_/ }
+ # print "$name => $file\n";
$name =~ s/\.pm$//;
$name =~ s/\//::/g;
get_subs($name);
@@ -102,22 +103,50 @@ sub report
$cover->print_details if $Details;
}
+my ($F, $L);
+
sub walk_topdown
{
my ($op) = @_;
- push @{$Cover{$op->file}{$op->line}}, coverage()->{pack "I*", $$op} || 0
- if class($op) eq "COP";
+ my $class = class($op);
+ my $coverage = coverage()->{pack "I*", $$op};
+
+ push @{$Cover{$F = $op->file}{statement}{$L = $op->line}}, $coverage || 0
+ if $class eq "COP";
+
if ($op->can("flags") && ($op->flags & OPf_KIDS))
{
+ my $c;
for (my $kid = $op->first; $$kid; $kid = $kid->sibling)
{
- walk_topdown($kid);
+ my $cov = walk_topdown($kid);
+ push @$c, $cov || 0 if $class eq "LOGOP";
}
+ push @{$Cover{$F}{condition}{$L}}, $c if $c;
}
- if (class($op) eq "PMOP" && ${$op->pmreplroot})
+
+ if ($class eq "PMOP" && ${$op->pmreplroot})
{
walk_topdown($op->pmreplroot);
}
+
+ $class eq "LISTOP" ? undef : $coverage
+}
+
+sub find_first
+{
+ my ($op) = @_;
+ my $c = coverage()->{pack "I*", $$op};
+ return $c if defined $c;
+ for (my $kid = $op->first; $$kid; $kid = $kid->sibling)
+ {
+ if ($op->can("flags") && ($op->flags & OPf_KIDS))
+ {
+ my $c = find_first($kid);
+ return $c if defined $c;
+ }
+ }
+ undef
}
sub get_subs
@@ -205,12 +234,12 @@ __END__
Devel::Cover - a module to provide code coverage for Perl
-Version 0.03 - 10th May 2001
+Version 0.04 - 12th May 2001
=head1 SYNOPSIS
perl -MDevel::Cover prog args
- perl -MDevel::Cover=-o,prog.cov,-i,1 prog args
+ perl -MDevel::Cover=-output,prog.cov,-indent,1,-details,1 prog args
=head1 DESCRIPTION
@@ -225,24 +254,28 @@ This module provides code coverage for Perl.
If you can't guess by the version number this is an alpha release.
-Code coverage data are collected using a plugable runops subroutine
-which counts how many times each op is executed. These data are then
-mapped back to reality using the B compiler modules.
+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.
+
+At the moment, only statement coverage and condition coverage
+information is reported. Coverage data for other metrics are collected,
+but not reported. Coverage data for some metrics are not yet collected.
-At the moment, only statement coverage information is reported.
-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.
Requirements:
Perl 5.6.1 or 5.7.1.
The ability to compile XS extensions.
=head1 OPTIONS
- -o file - Send output to file (default default.cov).
- -i indent - Set indentation level to indent. See Data::Dumper for details.
- -S - Don't print summary information.
- -d - Print detailed information.
+ -indent indent - Set indentation level to indent. See Data::Dumper for details.
+ -output file - Send output to file (default default.cov).
+ -inc path - Prefix of files to ignore (default @INC).
+ -summary val - Print summary information iff val is true (default on).
+ -details val - Print detailed information iff val is true (default off).
=head1 TUTORIAL
View
@@ -0,0 +1,68 @@
+# 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::Op;
+
+use strict;
+use warnings;
+
+our $VERSION = "0.04";
+
+use Devel::Cover qw(-inc B -indent 1 -details 1);
+
+my @Options;
+
+my %style =
+ ("terse" =>
+ ["(?(#label =>\n)?)(*( )*)#class (#addr) #name <#cover> (?([#targ])?) "
+ . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
+ "(*( )*)goto #class (#addr)\n",
+ "#class pp_#name"],
+ "concise" =>
+ ["#hyphseq2 #cover6 (*( (x( ;)x))*)<#classsym> "
+ . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n",
+ " (*( )*) goto #seq\n",
+ "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
+ "debug" =>
+ ["#class (#addr)\n\tcover\t\t#cover\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
+ . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n\top_seq\t\t"
+ . "#seqnum\n\top_flags\t#flagval\n\top_private\t#privval\n"
+ . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
+ . "(?(\top_sv\t\t#svaddr\n)?)",
+ " GOTO #addr\n",
+ "#addr"],
+ );
+
+sub set_style
+{
+ my ($style) = @_;
+ @ENV{qw(B_CONCISE_FORMAT B_CONCISE_GOTO_FORMAT B_CONCISE_TREE_FORMAT)} =
+ @{$style{$style}};
+}
+
+sub import
+{
+ my $class = shift;
+ @Options = ("-env");
+ set_style("concise");
+ for (@_)
+ {
+ /-(.*)/ && exists $style{$1}
+ ? set_style($1)
+ : push @Options, $_;
+ }
+ $ENV{B_CONCISE_SUB} = "Devel::Cover::Op::concise_op";
+}
+
+END { require B::Concise; B::Concise::compile(@Options)->() }
+
+sub concise_op
+{
+ my ($h, $op, $level, $format) = @_;
+ $h->{cover} = Devel::Cover::coverage()->{pack "I*", $$op} ||
+ ($h->{seq} ? "-" : "");
+}
View
@@ -12,7 +12,7 @@ use warnings;
use Carp;
-our $VERSION = "0.03";
+our $VERSION = "0.04";
sub new
{
@@ -74,26 +74,45 @@ sub calculate_summary
my $self = shift;
my ($force) = @_;
return if defined $self->{summary} && !$force;
- $self->{summary} = {};
- my $statements = 0;
- my $statements_covered = 0;
- for my $file (sort keys %{$self->{cover}})
+ my $s = $self->{summary} = {};
+
+ my $cover = $self->{cover};
+ my ($t, $c, $lines);
+ for my $file (sort keys %$cover)
{
- my $lines = $self->{cover}{$file};
+ $t = $c = 0;
+ $lines = $cover->{$file}{statement};
+ for my $line (sort { $a <=> $b } keys %$lines)
+ {
+ my $l = $lines->{$line};
+ $t += @$l;
+ $c += grep { $_ } @$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;
+
+ $t = $c = 0;
+ $lines = $cover->{$file}{condition};
for my $line (sort { $a <=> $b } keys %$lines)
{
my $l = $lines->{$line};
- $statements += @$l;
- $statements_covered += map { $_ || () } @$l;
+ $t += @$l;
+ $c += grep { !grep { !$_ } @$_ } @$l;
}
- $self->{summary}{$file}{statement}{total} = $statements;
- $self->{summary}{$file}{statement}{covered} = $statements_covered;
- $self->{summary}{$file}{total}{total} += $statements;
- $self->{summary}{$file}{total}{covered} += $statements_covered;
- $self->{summary}{Total}{statement}{total} += $statements;
- $self->{summary}{Total}{statement}{covered} += $statements_covered;
- $self->{summary}{Total}{total}{total} += $statements;
- $self->{summary}{Total}{total}{covered} += $statements_covered;
+ $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;
}
}
@@ -106,12 +125,11 @@ sub print_summary
{
my ($part, $critrion) = @_;
exists $part->{$critrion}
- ? $part->{$critrion}{total}
- ? sprintf "%6.2f", $part->{$critrion}{covered} * 100 /
- $part->{$critrion}{total}
- : "-"
+ ? sprintf "%6.2f", $part->{$critrion}{total}
+ ? $part->{$critrion}{covered} * 100 /
+ $part->{$critrion}{total}
+ : 100
: "n/a"
-
};
my $fmt = "%-42s %6s %6s %6s %6s %6s\n";
@@ -140,7 +158,7 @@ sub print_details
for my $file (@files)
{
print "$file\n\n";
- my $lines = $self->{cover}{$file};
+ my $lines = $self->{cover}{$file}{statement};
my $fmt = "%-5d: %6s %s\n";
open F, $file or croak "Unable to open $file: $!";
@@ -151,7 +169,7 @@ sub print_details
{
my @c = @{$lines->{$.}};
printf "%5d: %6d %s", $., shift @c, $_;
- printf " : %6d\n", $., shift @c while @c;
+ printf " : %6d\n", shift @c while @c;
}
else
{
View
@@ -7,5 +7,6 @@ Makefile.PL
Cover.pm
Cover.xs
Cover/Process.pm
+Cover/Op.pm
t/t1.t
t/T1.pm
View
@@ -16,8 +16,8 @@ use ExtUtils::MakeMaker;
$| = 1;
-my $Version = "0.03";
-my $Date = "10th May 2001";
+my $Version = "0.04";
+my $Date = "12th May 2001";
my $Author = 'pjcj@cpan.org';
my @perlbug = ("perlbug", "-a", $Author,
View
17 README
@@ -1,7 +1,7 @@
NAME
Devel::Cover - a module to provide code coverage for Perl
- Version 0.03 - 10th May 2001
+ Version 0.04 - 12th May 2001
DESCRIPTION
Copyright 2001, Paul Johnson (pjcj@cpan.org)
@@ -16,13 +16,16 @@ DESCRIPTION
If you can't guess by the version number this is an alpha release.
- Code coverage data are collected using a plugable runops subroutine
- which counts how many times each op is executed. These data are then
- mapped back to reality using the B compiler modules.
+ 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.
- At the moment, only statement coverage information is reported. Coverage
- data for other metrics are collected, but not reported. Coverage data
- for some metrics are not yet collected.
+ At the moment, only statement coverage and condition coverage
+ information is reported. 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.
Requirements: Perl 5.6.1 or 5.7.1. The ability to compile XS extensions.
Oops, something went wrong.

0 comments on commit a9f2eee

Please sign in to comment.