Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

417 lines (366 sloc) 11.502 kB
# Copyright 2004-2011, 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::Structure;
use strict;
use warnings;
use Carp;
use Digest::MD5;
use Devel::Cover::DB;
use Devel::Cover::DB::IO 0.77;
use Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1;
# For comprehensive debug logging.
use constant DEBUG => 0;
our $VERSION = "0.77";
our $AUTOLOAD;
sub new
{
my $class = shift;
my $self =
{
@_
};
bless $self, $class
}
sub DESTROY {}
sub AUTOLOAD
{
my $self = $_[0];
my $func = $AUTOLOAD;
$func =~ s/.*:://;
my ($function, $criterion) = $func =~ /^(add|get)_(.*)/;
croak "Undefined subroutine $func called"
unless $criterion &&
grep $_ eq $criterion, @Devel::Cover::DB::Criteria,
qw( sub_name file line );
no strict "refs";
if ($function eq "get")
{
my $c = $criterion eq "time" ? "statement" : $criterion;
if (grep $_ eq $c, qw( sub_name file line ))
{
*$func = sub
{
my $self = shift;
$self->{$c}
}
}
else
{
*$func = sub
{
my $self = shift;
my $digest = shift;
# print STDERR "file: $digest, condition: $c\n";
for my $fval (values %{$self->{f}})
{
return $fval->{$c} if $fval->{digest} eq $digest;
}
return
}
};
}
else
{
*$func = sub
{
my $self = shift;
my $file = shift;
push @{$self->{f}{$file}{$criterion}}, @_;
};
}
goto &$func
}
sub debuglog {
my $self = shift;
my $dir = "$self->{base}/debuglog";
unless (-d $dir)
{
mkdir $dir, 0700 or confess "Can't mkdir $dir: $!";
}
local $\;
# One log file per process, as we're potentially dumping out large amounts,
# and might excede the atomic write size of the OS.
open my $fh, '>>', "$dir/$$" or confess "Can't open $dir/$$: $!";
print $fh "----------------" . gmtime() . "----------------\n";
print $fh ref $_ ? Dumper($_) : $_;
print $fh "\n";
close $fh or confess "Can't close $dir/$$: $!";
}
sub add_criteria
{
my $self = shift;
@{$self->{criteria}}{@_} = ();
$self
}
sub criteria
{
my $self = shift;
keys %{$self->{criteria}}
}
sub set_subroutine
{
my $self = shift;
my ($sub_name, $file, $line, $scount) =
@{$self}{qw( sub_name file line scount )} = @_;
# When new code is added at runtime, via a string eval in some guise, we
# need information about where structure information for the subroutine
# is. This information is stored in $self->{f}{$file}{start} keyed on the
# filename, line number, subroutine name and the count, the count being
# for when there are multiple subroutines of the same name on the same
# line (such subroutines generally being called BEGIN).
# print STDERR "set_subroutine start $file:$line $sub_name($scount) ",
# Dumper $self->{f}{$file}{start};
$self->{additional} = 0;
if ($self->reuse($file))
{
# reusing a structure
if (exists $self->{f}{$file}{start}{$line}{$sub_name}[$scount])
{
# sub already exists - normal case
# print STDERR "reuse $file:$line:$sub_name\n";
$self->{count}{$_}{$file} =
$self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_}
for $self->criteria;
}
else
{
# sub doesn't exist, for example a conditional C<eval "use M">
$self->{additional} = 1;
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";
$self->{count}{$_}{$file} =
$self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} =
($self->add_count($_))[0]
for $self->criteria;
}
else
{
# first such a sub in module
# print STDERR "reuse first $file:$line:$sub_name\n";
$self->{count}{$_}{$file} =
$self->{additional_count}{$_}{$file} =
$self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} =
$self->{f}{$file}{start}{-1}{"__COVER__"}[$scount]{$_}
for $self->criteria;
}
}
}
else
{
# first time sub seen in new structure
# print STDERR "new $file:$line:$sub_name\n";
$self->{count}{$_}{$file} =
$self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} =
$self->get_count($_)
for $self->criteria;
}
# print STDERR "set_subroutine start $file:$line $sub_name($scount) ",
# Dumper $self->{f}{$file}{start};
}
sub store_counts
{
my $self = shift;
my ($file) = @_;
$self->{count}{$_}{$file} =
$self->{f}{$file}{start}{-1}{__COVER__}[0]{$_} =
$self->get_count($_)
for $self->criteria;
# print STDERR Dumper $self->{f}{$file}{start};
}
sub reuse
{
my $self = shift;
my ($file) = @_;
exists $self->{f}{$file}{start}{-1}{"__COVER__"}
# TODO - exists $self->{f}{$file}{start}{-1}
}
sub set_file
{
my $self = shift;
my ($file) = @_;
$self->{file} = $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
{
my $self = shift;
my ($file) = @_;
# warn "Opening $file for MD5 digest\n";
my $digest;
if (open my $fh, "<", $file)
{
binmode $fh;
$digest = Digest::MD5->new->addfile($fh)->hexdigest;
}
else
{
warn "Devel::Cover: Can't open $file for MD5 digest: $!\n"
unless lc $file eq "-e";
# require "Cwd"; warn Carp::longmess("in " . Cwd::cwd());
}
$digest
}
sub get_count
{
my $self = shift;
my ($criterion) = @_;
return 0 unless $self->{file}; # TODO - how does this get unset?
$self->{count}{$criterion}{$self->{file}}
}
sub add_count
{
my $self = shift;
# warn Carp::longmess("undefined file") unless defined $self->{file};
return unless defined $self->{file}; # can happen during self_cover
my ($criterion) = @_;
$self->{additional_count}{$criterion}{$self->{file}}++
if $self->{additional};
($self->{count}{$criterion}{$self->{file}}++,
!$self->reuse($self->{file}) || $self->{additional})
}
sub delete_file
{
my $self = shift;
my ($file) = @_;
delete $self->{f}{$file};
}
sub write
{
my $self = shift;
my ($dir) = @_;
# print STDERR Dumper $self;
$dir .= "/structure";
unless (-d $dir)
{
mkdir $dir, 0700 or croak "Can't mkdir $dir: $!\n";
}
for my $file (sort keys %{$self->{f}})
{
$self->{f}{$file}{file} = $file;
unless ($self->{f}{$file}{digest})
{
warn "Can't find digest for $file" unless $Devel::Cover::Silent;
next;
}
my $df_final = "$dir/$self->{f}{$file}{digest}";
my $df_temp = "$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 STDERR "Writing [$file] to [$df]\n";
my $io = Devel::Cover::DB::IO->new;
$io->write($self->{f}{$file}, $df_temp); # unless -e $df;
unless (rename $df_temp, $df_final) {
unless ($Devel::Cover::Silent) {
if(-e $df_final) {
warn "Can't rename $df_temp to $df_final (which exists): $!";
$self->debuglog("Can't rename $df_temp to $df_final "
. "(which exists): $!")
if DEBUG;
} else {
warn "Can't rename $df_temp to $df_final: $!";
$self->debuglog("Can't rename $df_temp to $df_final: $!")
if DEBUG;
}
}
unless (unlink $df_temp) {
warn "Can't remove $df_temp after failed rename: $!"
unless $Devel::Cover::Silent;
$self->debuglog("Can't remove $df_temp after failed rename: $!")
if DEBUG;
}
}
}
}
sub read
{
my $self = shift;
my ($digest) = @_;
my $file = "$self->{base}/structure/$digest";
my $io = Devel::Cover::DB::IO->new;
my $s = eval { $io->read($file) };
if ($@ or !$s) {
$self->debuglog("read retrieve $file failed: $@") if DEBUG;
die $@;
}
if (DEBUG) {
foreach my $key (qw(file digest)) {
if (!defined $s->{$key}) {
$self->debuglog("retrieve $file had no $key entry. Got:\n", $s);
}
}
}
my $d = $self->digest($s->{file});
# print STDERR "reading $digest from $file: ", Dumper $s;
if (!$d) {
# No digest implies that we can't read the file. Likely this is because
# it's stored with a relative path. In which case, it's not valid to
# assume that the file has been changed, and hence that we need to
# "update" the structure database on disk.
}
elsif ($d eq $s->{digest})
{
$self->{f}{$s->{file}} = $s;
}
else
{
warn "Devel::Cover: Deleting old coverage ",
"for changed file $s->{file}\n";
if (unlink $file) {
$self->debuglog("Deleting old coverage $file for changed "
. "$s->{file} $s->{digest} vs $d. Got:\n", $s,
"Have:\n", $self->{f}{$file})
if DEBUG;
} else {
warn "Devel::Cover: can't delete $file: $!\n";
$self->debuglog("Failed to delete coverage $file for changed "
. "$s->{file} ($!) $s->{digest} vs $d. Got:\n", $s,
"Have:\n", $self->{f}{$file})
if DEBUG;
}
}
$self
}
sub read_all
{
my ($self) = @_;
my $dir = $self->{base};
$dir .= "/structure";
opendir D, $dir or return;
for my $d (sort grep $_ !~ /\./, readdir D)
{
$self->read($d);
}
closedir D or die "Can't closedir $dir: $!";
$self
}
1
__END__
=head1 NAME
Devel::Cover::DB::Structure - Code coverage metrics for Perl
=head1 SYNOPSIS
use Devel::Cover::DB::Structure;
=head1 DESCRIPTION
=head1 SEE ALSO
Devel::Cover
=head1 METHODS
=head1 BUGS
Huh?
=head1 VERSION
Version 0.77 - 15th May 2011
=head1 LICENCE
Copyright 2004-2011, 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
Jump to Line
Something went wrong with that request. Please try again.