Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

import Devel::Cover 0.06

  • Loading branch information...
commit 2202197223419815a39319011d462a2b2911fe91 1 parent 310cdad
@pjcj authored
View
9 CHANGES
@@ -15,6 +15,13 @@ Release 0.04 - 12th April 2001
- Include Devel::Cover::Op
- Add condition coverage (sort of).
-Release 0.05 -
+Release 0.05 - 9th August 2001
- Make line numbers more accurate when nextstate has been optimised away.
- Get things working with ithreads.
+
+Release 0.06 - 10th August 2001
+ - Rename Devel::Cover::Process to Devel::Cover::DB
+ - Make the database a directory.
+ - Add fix for eval in filename. (Arthur Bergman <arthur@contiller.se>)
+ - Add more tests and abstract away comparison subroutine.
+ - Clear @Inc if it is set explicitly.
View
73 Cover.pm
@@ -12,42 +12,46 @@ use warnings;
use DynaLoader ();
-use Devel::Cover::Process 0.05;
+use Devel::Cover::DB 0.06;
our @ISA = qw( DynaLoader );
-our $VERSION = "0.05";
+our $VERSION = "0.06";
use B qw( class ppname main_root main_start main_cv svref_2object OPf_KIDS );
-use Data::Dumper;
my $Covering = 1;
+my $DB = "cover_db";
+my $Details = 0;
+my $Merge = 1;
+my @Inc;
my $Indent = 0;
-my $Output = "default.cov";
my $Summary = 1;
-my $Details = 0;
my %Cover;
our $Cv; # gets localised
my @Todo;
my %Done;
-my @Inc;
BEGIN { @Inc = @INC }
+# BEGIN { $^P = 0x02 | 0x04 | 0x100 }
+BEGIN { $^P = 0x04 | 0x100 }
END { report() }
sub import
{
my $class = shift;
+ @Inc = () if "@_" =~ /-inc /;
while (@_)
{
local $_ = shift;
- /^-indent/ && do { $Indent = shift; next };
- /^-output/ && do { $Output = shift; next };
+ /^-db/ && do { $DB = shift; next };
+ /^-details/ && do { $Details = shift; next };
+ /^-merge/ && do { $Merge = shift; next };
/^-inc/ && do { push @Inc, shift; next };
+ /^-indent/ && do { $Indent = shift; next };
/^-summary/ && do { $Summary = shift; next };
- /^-details/ && do { $Details = shift; next };
warn __PACKAGE__ . ": Unknown option $_ ignored\n";
}
}
@@ -68,8 +72,8 @@ sub report
INC:
while (my ($name, $file) = each %INC)
{
- for (@Inc) { next INC if $file =~ /^\Q$_/ }
# print "$name => $file\n";
+ for (@Inc) { next INC if $file =~ /^\Q$_/ }
$name =~ s/\.pm$//;
$name =~ s/\//::/g;
get_subs($name);
@@ -91,20 +95,30 @@ sub report
for (@Inc) { delete $Cover{$file}, last if $file =~ /^\Q$_/ }
}
- {
- local $Data::Dumper::Indent = $Indent;
- open OUT, ">$Output" or die "Cannot open $Output\n";
- print OUT Data::Dumper->Dump([\%Cover], ["cover"]);
- close OUT or die "Cannot close $Output\n";
- }
-
- my $cover = Devel::Cover::Process->new(cover => \%Cover);
+ my $cover = Devel::Cover::DB->new(cover => \%Cover);
+ my $existing;
+ eval { $existing = Devel::Cover::DB->new(db => $DB) if $Merge };
+ $cover->merge($existing) if $existing;
+ $cover->indent($Indent);
+ $cover->write($DB);
$cover->print_summary if $Summary;
$cover->print_details if $Details;
}
my ($F, $L) = ("", 0);
-my $Level = 0;
+# my $Level = 0;
+
+sub get_location
+{
+ my ($op) = @_;
+
+ $F = $op->file;
+ $L = $op->line;
+
+ # If there's an eval, get the real filename. Enabled from $^P & 0x100.
+
+ ($F, $L) = ($1, $2) if $F =~/^\(eval \d+\)\[(.*):(\d+)\]/;
+}
sub walk_topdown
{
@@ -112,13 +126,14 @@ sub walk_topdown
my $class = class($op);
my $cover = coverage()->{pack "I*", $$op};
- $Level++;
+ # $Level++;
# Statement coverage.
if ($class eq "COP")
{
- push @{$Cover{$F = $op->file}{statement}{$L = $op->line}}, $cover || 0
+ get_location($op);
+ push @{$Cover{$F}{statement}{$L}}, $cover || 0;
}
elsif (!null($op) &&
$op->name eq "null"
@@ -130,7 +145,8 @@ sub walk_topdown
$cover = coverage()->{pack "I*", ${$op->sibling}};
my $o = $op;
bless $o, "B::COP";
- push @{$Cover{$F = $o->file}{statement}{$L = $o->line}}, $cover || 0
+ get_location($o);
+ push @{$Cover{$F}{statement}{$L}}, $cover || 0;
}
# print " " x ($Level * 2), "$F:$L ", $op->name, ":$class\n";
@@ -153,7 +169,7 @@ sub walk_topdown
walk_topdown($op->pmreplroot);
}
- $Level--;
+ # $Level--;
$class eq "LISTOP" ? undef : $cover
}
@@ -263,7 +279,7 @@ Devel::Cover - Code coverage metrics for Perl
=head1 SYNOPSIS
perl -MDevel::Cover prog args
- perl -MDevel::Cover=-output,prog.cov,-indent,1,-details,1 prog args
+ perl -MDevel::Cover=-db,cover_db,-indent,1,-details,1 prog args
=head1 DESCRIPTION
@@ -288,11 +304,12 @@ Requirements:
=head1 OPTIONS
- -indent indent - Set indentation level to indent. See Data::Dumper for details.
- -output file - Send output to file (default default.cov).
+ -db cover_db - Store results in coverage db (default cover_db).
+ -details val - Print detailed information iff val is true (default off).
-inc path - Prefix of files to ignore (default @INC).
+ -indent indent - Set indentation level to indent. See Data::Dumper for details.
+ -merge val - Merge databases, for multiple test benches (default on).
-summary val - Print summary information iff val is true (default on).
- -details val - Print detailed information iff val is true (default off).
=head1 TUTORIAL
@@ -476,7 +493,7 @@ Huh?
=head1 VERSION
-Version 0.05 - 9th May 2001
+Version 0.06 - 10th May 2001
=head1 LICENCE
View
134 Cover/Process.pm → Cover/DB.pm
@@ -5,14 +5,18 @@
# The latest version of this software should be available from my homepage:
# http://www.pjcj.net
-package Devel::Cover::Process;
+package Devel::Cover::DB;
use strict;
use warnings;
use Carp;
+use Data::Dumper;
+use File::Path;
-our $VERSION = "0.05";
+our $VERSION = "0.06";
+
+my $DB = "cover.1"; # Version 1 of the database.
sub new
{
@@ -22,6 +26,8 @@ sub new
{
criteria => [ qw( statement branch path condition ) ],
criteria_short => [ qw( stmt branch path cond ) ],
+ indent => 1,
+ cover => {},
@_
};
$self->{all_criteria} = [ @{$self->{criteria}}, "total" ];
@@ -29,25 +35,27 @@ sub new
bless $self, $class;
- if (defined $self->{file})
+ my $file;
+ if (defined $self->{db})
{
- open F, "<$self->{file}" or croak "Unable to open $self->{file}: $!";
+ $self->validate_db;
+ $file = "$self->{db}/$DB";
+ open F, "<$file" or croak "Unable to open $file: $!";
$self->{filehandle} = *F{IO};
}
$self->read if defined $self->{filehandle};
- if (defined $self->{file})
+ if (defined $file)
{
- close F or croak "Unable to close $self->{file}: $!";
+ close F or croak "Unable to close $file: $!";
}
- croak "No input file, filehandle or cover" unless defined $self->{cover};
+ croak "No input db, filehandle or cover" unless defined $self->{cover};
$self
}
-
sub read
{
my $self = shift;
@@ -56,9 +64,32 @@ sub read
my $fh = $self->{filehandle};
eval <$fh>;
croak $@ if $@;
- $self->{cover} = $cover
+ $self->{cover} = $cover;
+ $self
}
+sub write
+{
+ my $self = shift;
+ $self->{db} = shift if @_;
+ croak "No db specified" unless length $self->{db};
+ $self->validate_db;
+ local $Data::Dumper::Indent = $self->indent;
+ my $file = "$self->{db}/$DB";
+ open OUT, ">$file" or croak "Cannot open $file\n";
+ print OUT Data::Dumper->Dump([$self->{cover}], ["cover"]);
+ close OUT or croak "Cannot close $file\n";
+ $self
+}
+
+sub delete
+{
+ my $self = shift;
+ $self->{db} = shift if @_;
+ croak "No db specified" unless length $self->{db};
+ rmtree($self->{db});
+ $self
+}
sub cover
{
@@ -66,6 +97,82 @@ sub cover
$self->{cover}
}
+sub validate_db
+{
+ my $self = shift;
+ unless (-d $self->{db})
+ {
+ mkdir $self->{db}, 0777 or croak "Cannot mkdir $self->{db}: $!\n";
+ }
+ $self
+}
+
+sub indent
+{
+ my $self = shift;
+ $self->{indent} = shift if @_;
+ $self->{indent}
+}
+
+sub merge
+{
+ my ($self, $from) = @_;
+ _merge_hash($self->cover, $from->cover);
+ $self
+}
+
+sub _merge_hash
+{
+ my ($into, $from) = @_;
+ for my $fkey (keys %{$from})
+ {
+ my $fval = $from->{$fkey};
+ my $fval_ref = ref $fval;
+
+ if (defined $into->{$fkey} and UNIVERSAL::isa($into->{$fkey}, "ARRAY"))
+ {
+ _merge_array($into->{$fkey}, $fval);
+ }
+ elsif (defined $fval && UNIVERSAL::isa($fval, "HASH"))
+ {
+ if (defined $into->{$fkey} and
+ UNIVERSAL::isa($into->{$fkey}, "HASH"))
+ {
+ _merge_hash($into->{$fkey}, $fval);
+ }
+ else
+ {
+ $into->{$fkey} = $fval;
+ }
+ }
+ else
+ {
+ # A scalar (or a blessed scalar). We know there is no into
+ # array, or we would just have merged with it.
+
+ $into->{$fkey} = $fval;
+ }
+ }
+}
+
+sub _merge_array
+{
+ my ($into, $from) = @_;
+ for my $i (@$into)
+ {
+ my $f = shift @$from;
+ if (UNIVERSAL::isa($i, "ARRAY"))
+ {
+ _merge_array($i, $f);
+ }
+ else
+ {
+ $i += $f;
+ }
+ }
+ push @$into, @$from;
+}
+
sub calculate_summary
{
my $self = shift;
@@ -113,6 +220,13 @@ sub calculate_summary
}
}
+sub trimmed_file
+{
+ my ($f, $len) = @_;
+ substr $f, 0, 3 - $len, "..." if length $f > $len;
+ $f
+}
+
sub print_summary
{
my $self = shift;
@@ -138,7 +252,7 @@ sub print_summary
for my $file (grep($_ ne "Total", sort keys %$s), "Total")
{
printf $fmt,
- $file,
+ trimmed_file($file, 42),
map { $format->($s->{$file}, $_) } @{$self->{all_criteria}};
}
View
2  Cover/Op.pm
@@ -10,7 +10,7 @@ package Devel::Cover::Op;
use strict;
use warnings;
-our $VERSION = "0.05";
+our $VERSION = "0.06";
use Devel::Cover qw( -inc B -indent 1 -details 1 );
use B::Concise qw( set_style add_callback );
View
4 MANIFEST
@@ -6,7 +6,9 @@ BUGS
Makefile.PL
Cover.pm
Cover.xs
-Cover/Process.pm
+Cover/DB.pm
Cover/Op.pm
+t/Compare.pm
t/t1.t
t/T1.pm
+t/t2.t
View
4 Makefile.PL
@@ -16,8 +16,8 @@ use ExtUtils::MakeMaker;
$| = 1;
-my $Version = "0.05";
-my $Date = "9th May 2001";
+my $Version = "0.06";
+my $Date = "10th May 2001";
my $Author = 'pjcj@cpan.org';
my @perlbug = ("perlbug", "-a", $Author,
View
2  TODO
@@ -4,3 +4,5 @@
- Documentation.
- Generic output routines/gui, suitable for other languages too.
- BEGIN and END blocks.
+- Sort out @Inc.
+- Work with memoize.
View
60 t/Compare.pm
@@ -0,0 +1,60 @@
+# 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 Compare;
+
+use strict;
+use warnings;
+
+our $VERSION = "0.06";
+
+sub compare
+{
+ my ($results, $golden) = @_;
+ my $t1 = Devel::Cover::DB->new(db => $results )->cover;
+ my $t2 = Devel::Cover::DB->new(filehandle => $golden )->cover;
+ my $error = "files";
+ my $ok = keys %$t1 == keys %$t2;
+ FILE:
+ for my $file (sort keys %$t1)
+ {
+ $error = "$file";
+ my $f1 = $t1->{$file};
+ my $f2 = delete $t2->{$file};
+ last FILE unless $ok &&= $f2;
+ $ok &&= keys %$f1 == keys %$f2;
+ for my $criterion (sort keys %$f1)
+ {
+ $error = "$file $criterion";
+ my $c1 = $f1->{$criterion};
+ my $c2 = delete $f2->{$criterion};
+ last FILE unless $ok &&= $c2;
+ for my $line (sort keys %$c1)
+ {
+ $error = "$file $criterion $line";
+ my $l1 = $c1->{$line};
+ my $l2 = delete $c2->{$line};
+ last FILE unless $ok &&= $l2;
+ $ok &&= @$l1 == @$l2;
+ for my $v1 (@$l1)
+ {
+ my $v2 = shift @$l2;
+ $error = "$file $criterion $line $v1 != $v2";
+ last FILE unless $ok &&= !($v1 xor $v2);
+ }
+ $error = "$file $criterion $line extra";
+ last FILE unless $ok &&= !@$l2;
+ }
+ $error = "$file $criterion extra";
+ last FILE unless $ok &&= !keys %$c2;
+ }
+ $error = "$file extra";
+ last FILE unless $ok &&= !keys %$f2;
+ }
+ $error = "extra" unless $ok &&= !keys %$t2;
+ $ok ? "done" : "mismatch: $error"
+}
View
48 t/t1.t
@@ -7,8 +7,8 @@
# The latest version of this software should be available from my homepage:
# http://www.pjcj.net
-use Devel::Cover::Process 0.05 qw( cover_read );
-use Devel::Cover 0.05 qw( -indent 1 -output t1.cov );
+use Devel::Cover::DB 0.06 qw( cover_read );
+use Devel::Cover 0.06 qw( -db t1 -indent 1 -merge 0 );
use strict;
use warnings;
@@ -56,48 +56,8 @@ Devel::Cover::report();
END
{
- my $t1 = Devel::Cover::Process->new(file => "t1.cov" )->cover;
- my $t2 = Devel::Cover::Process->new(filehandle => *DATA{IO})->cover;
- my $error = "files";
- my $ok = keys %$t1 == keys %$t2;
- FILE:
- for my $file (sort keys %$t1)
- {
- $error = "$file";
- my $f1 = $t1->{$file};
- my $f2 = delete $t2->{$file};
- last FILE unless $ok &&= $f2;
- $ok &&= keys %$f1 == keys %$f2;
- for my $criterion (sort keys %$f1)
- {
- $error = "$file $criterion";
- my $c1 = $f1->{$criterion};
- my $c2 = delete $f2->{$criterion};
- last FILE unless $ok &&= $c2;
- for my $line (sort keys %$c1)
- {
- $error = "$file $criterion $line";
- my $l1 = $c1->{$line};
- my $l2 = delete $c2->{$line};
- last FILE unless $ok &&= $l2;
- $ok &&= @$l1 == @$l2;
- for my $v1 (@$l1)
- {
- my $v2 = shift @$l2;
- $error = "$file $criterion $line $v1 != $v2";
- last FILE unless $ok &&= !($v1 xor $v2);
- }
- $error = "$file $criterion $line extra";
- last FILE unless $ok &&= !@$l2;
- }
- $error = "$file $criterion extra";
- last FILE unless $ok &&= !keys %$c2;
- }
- $error = "$file extra";
- last FILE unless $ok &&= !keys %$f2;
- }
- $error = "extra" unless $ok &&= !keys %$t2;
- ok $ok ? "done" : "mismatch: $error", "done";
+ require Compare;
+ ok Compare::compare("t1", *DATA{IO}), "done";
}
__DATA__
View
55 t/t2.t
@@ -0,0 +1,55 @@
+#!/usr/local/bin/perl
+
+# 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
+
+use Devel::Cover::DB 0.06 qw( cover_read );
+use Devel::Cover 0.06 qw( -db t2 -indent 1 -merge 0 );
+
+use strict;
+use warnings;
+
+use Test;
+
+BEGIN { plan tests => 1 }
+
+use lib -d "t" ? "t" : "..";
+
+eval <<EOS;
+sub e
+{
+ 1
+}
+EOS
+e();
+
+Devel::Cover::report();
+
+END
+{
+ require Compare;
+ ok Compare::compare("t2", *DATA{IO}), "done";
+}
+
+__DATA__
+
+$cover = {
+ 't/t2.t' => {
+ 'statement' => {
+ '22' => [
+ 3,
+ 1
+ ],
+ '28' => [
+ 1
+ ],
+ '30' => [
+ 1
+ ]
+ }
+ }
+};
Please sign in to comment.
Something went wrong with that request. Please try again.