NAME
Devel::CoverReport - Advanced Perl code coverage report generator
SYNOPSIS
To get coverage report, from existing *cover_db* database, use:
cover_report
DESCRIPTION
This module provides advanced reports based on Devel::Cover database.
WARNING
Consider this module to be an early ALPHA. It does the job for me, so
it's here.
This is my first CPAN module, so I expect that some things may be a bit
rough around edges.
The plan is, to fix both those issues, and remove this warning in next
immediate release.
API
new Constructur for "Devel::CoverReport".
make_report
Make the report, as it was specified during object construction.
Most probably, this is the only method, that most users will have to
call, if they want to use this module directly.
The rest will either run prove_cover (it's still the recomended way)
or hack deeper - if, for some reason, You just need parts of this
module.
validate_digest
Check if there are some issues, that would not allow a digest to be
edded to the report. In case such issues exist, digest has to be
re-classified, and it's analise abandoned.
Parameters: (ARRAY) $self $structure_data : digest's structure data.
Returns: $new_classification : string (like: MISSING, CHANGED) or
undef (if no issues ware detected). =cut sub validate_digest { # {{{
my ($self, $structure_data) = @_;
my $actual_path = $self->_actual_file_path($structure_data->{'file'});
if (not $actual_path) {
$self->{'feedback'}->error_at_file("File not reachable!");
return 'MISSING';
}
if ($self->{'db'}->make_file_digest($actual_path) ne $structure_data->{'digest'}) {
# Check if file was modified since it was covered, as coverage report for changed files will not be reliable!
$self->{'feedback'}->warning_at_file("File has changed.");
return 'CHANGED';
}
# No issues detected, it's OK to analize this digest :)
return;
} # }}}
classify_file
Determine, if file (identified by it's path) should be INCLUDE-d,
MENTION-ed or EXCLUDE-d.
Parameters: (ARRAY) $self $file_path
Returns: $classification_string - one of the: "INCLUDE", "MENTION",
"EXCLUDE".
classify_file
Internal function.
Backend for "classify_file", iterate over every possible
classification method.
Parameters: (ARRAY) $self $file_path
Returns: $classification_string - one of the: "INCLUDE", "MENTION",
"EXCLUDE".
analyse_digest
Prepare detailed reports related to coverage or single module, and
return some metadata, used later to make a report-wide summary.
Parameters: (ARRAY) $self $runs - array of run IDs, that are related
to this file (runs, that cover this file) $digest - file's ID,
assigned to it by Devel::Cover
Returns: (ARRAY) \%summary_metadata,
make_runs_details
Parameters: ($self + HASH) digest - digest of the file, for which to
prepare run details report structure_data run_hits - per-run part of
the %hits hash per_run_info source_lines - array ref, containing
covereg file's contents - line by line. item_summary - data for the
summary row
make_coverage_summary
Make coverage information report for single structure entiry (Perl
script or module).
Parameters: ($self + HASH) structure_data hits report_id - string:
'namified' file path with run ID (if per-run coverages are turned
ON) source_lines - array ref, containing covereg file's contents -
line by line. item_summary - data for the summary row
_make_per_line_criterions
Internal function.
Distribute criterions from DB into each of the phisical source
lines.
Parameters: (ARRAY) $self $structure_data $hits
Returns: Hash =cut sub _make_per_line_criterions { # {{{ my ( $self,
$structure_data, $hits ) = @_; validate_pos( @_, { type=>OBJECT }, {
type=>HASHREF }, { type=>HASHREF }, );
my %per_line_criterions;
# Process statement and time criterions.
foreach my $criterion (qw( statement time )) {
my $i = 0;
foreach my $hit_count (@{ $hits->{$criterion} }) {
my $line_hit = $structure_data->{$criterion}->[$i];
if(defined $line_hit) {
push @{ $per_line_criterions{$criterion}->[$line_hit] }, $hit_count;
}
$i++;
}
}
# Process subroutine and pod.
foreach my $criterion (qw( subroutine pod )) {
my $i = 0;
foreach my $hit_count (@{ $hits->{$criterion} }) {
my $line_hit = $structure_data->{$criterion}->[$i];
if ($line_hit and $line_hit->[0]) {
# FIXME:
# it DOES happen, that structure file has no information related to some function.
# I have observed it while running under --jobs, maybe it's some race condition...
push @{ $per_line_criterions{$criterion}->[ $line_hit->[0] ] }, $hit_count;
}
else {
# Fixme: if we have a hit, in one of the runs, but have no 'structure' information related to it - it's a bug in Devel::Cover!
}
$i++;
}
}
# Process branch criterions.
foreach my $criterion (qw( branch condition )) {
my $i = 0;
foreach my $hits_array (@{ $hits->{$criterion} }) {
my $line_hit = $structure_data->{$criterion}->[$i]->[0];
assert_defined($line_hit, "Unknown line number? ". $i);
my $hits_count = 0;
foreach my $part (@{ $hits_array }) {
if ($part) {
$hits_count++;
}
}
$hits_count = 100 * $hits_count / $_ASIZE{$criterion};
push @{ $per_line_criterions{$criterion}->[$line_hit] }, int $hits_count;
$i++;
}
}
return %per_line_criterions;
} # }}}
make_branch_details
Make detailed branch coverage report.
Parameters: $self $basename $structure_data $hits =cut sub
make_branch_details { # {{{ my ($self, $basename, $structure_data,
$hits) = @_;
# if ($structure_data->{'file'} =~ m{L10N}) { # use Data::Dumper;
warn Dumper $structure_data->{'branch'}; # use Data::Dumper; warn
Dumper $hits; # }
my %lines;
my $i = 0;
foreach my $hits_array (@{ $hits }) {
my $line_no = $structure_data->{'branch'}->[$i]->[0];
my %line = (
'_coverage' => 0,
'c_true' => q{?},
'c_false' => q{?},
'line' => $line_no,
);
if ($hits_array->[0]) {
$line{'_coverage'} += 50;
$line{'c_true'} = { class=>q{c4}, v=>'T' };
}
else {
$line{'c_true'} = { class=>q{c0}, v=>'T' };
}
if ($hits_array->[1]) {
$line{'_coverage'} += 50;
$line{'c_false'} = { class=>q{c4}, v=>'F' };
}
else {
$line{'c_false'} = { class=>q{c0}, v=>'F' };
}
$lines{$line_no} = \%line;
$i++;
}
$self->{'formatter'}->add_report(
code => $basename,
basename => $basename,
title => 'Branch coverage: ' . $structure_data->{'file'},
);
my $coverage_table = $self->{'formatter'}->add_table(
$basename,
'Coverage',
{
label => 'Branch coverage',
headers => {
'line' => { caption=>'Line', f=>q{%d}, fs=>q{%d}, class=>'head' },
'percent' => { caption=>q{%}, f=>q{%d}, fs=>q{%.1f} },
'c_true' => { caption=>'True', f=>q{%s}, fs=>q{%.1f} },
'c_false' => { caption=>'False', f=>q{%s}, fs=>q{%.1f} },
'branch' => { caption=>'Branch', f=>q{%s}, fs=>q{%s}, class=>'src' },
},
headers_order => [qw( line percent c_true c_false branch )],
}
);
foreach my $hit (@{ $structure_data->{'branch'} }) {
my $line_no = $hit->[0];
my $line = $lines{ $line_no };
$line->{'percent'} = {
class => c_class($line->{'_coverage'}),
v => $line->{'_coverage'},
};
$line->{'branch'} = $hit->[1]->{'text'};
# warn $line->{'_coverage'} .q{ -> }. c_class($line->{'_coverage'});
$coverage_table->add_row($line);
}
$self->{'formatter'}->close_report($basename);
return;
} # }}}
make_subroutine_details
Make detailed subroutine coverage report.
Parameters: $self $basename $structure_data $hits =cut sub
make_subroutine_details { # {{{ my ($self, $basename,
$structure_data, $hits) = @_;
# if ($structure_data->{'file'} =~ m{L10N}) { # use Data::Dumper;
warn Dumper $structure_data->{'subroutine'}; # use Data::Dumper;
warn Dumper $hits; # }
my %lines;
my $i = 0;
foreach my $hits_count (@{ $hits }) {
my $line_no = $structure_data->{'subroutine'}->[$i]->[0];
if ($line_no) {
my %line = (
'line' => $line_no,
'hits' => { v=>$hits_count, class=>'c0' },
'subroutine' => q{?},
);
if ($hits_count) {
$line{'hits'}->{'class'} = 'c4';
}
$lines{$line_no} = \%line;
}
else {
# Fixme: if we have a hit, in one of the runs, but have no 'structure' information related to it - it's a bug in Devel::Cover!
}
$i++;
}
$self->{'formatter'}->add_report(
code => $basename,
basename => $basename,
title => 'Subroutine coverage: ' . $structure_data->{'file'},
);
my $coverage_table = $self->{'formatter'}->add_table(
$basename,
'Coverage',
{
label => 'Subroutine coverage',
headers => {
'line' => { caption=>'Line', f=>q{%d}, fs=>q{%d}, class=>'head' },
'hits' => { caption=>'Hits', f=>q{%d}, fs=>q{%d} },
'subroutine' => { caption=>'Subroutine', f=>q{%s}, fs=>q{%s}, class=>'src' },
},
headers_order => [qw( line hits subroutine )],
}
);
foreach my $hit (@{ $structure_data->{'subroutine'} }) {
if ($hit->[0]) {
my $line_no = $hit->[0];
my $line = $lines{ $line_no };
$line->{'subroutine'} = $hit->[1];
$coverage_table->add_row($line);
}
else {
# Fixme: if we have a hit, in one of the runs, but have no 'structure' information related to it - it's a bug in Devel::Cover!
}
}
$self->{'formatter'}->close_report($basename);
return;
} # }}}
make_condition_details
Make detailed branch coverage report.
Parameters: $self $basename $structure_data $hits =cut sub
make_condition_details { # {{{ my ($self, $basename,
$structure_data, $hits) = @_;
# if ($structure_data->{'file'} =~ m{L10N}) { # use Data::Dumper;
warn Dumper $structure_data->{'condition'}; # use Data::Dumper; warn
Dumper $hits; # }
# Fixme! There is probably a bug in this subroutine, due to my poor understanding of those data structures!!.
my %lines;
my $i = 0;
foreach my $hits_count (@{ $hits }) {
my $line_no = $structure_data->{'condition'}->[$i]->[0];
my $hits_count = 0;
my $cover = 0;
my $code = sprintf q{%s %s %s}, $structure_data->{'condition'}->[$i]->[1]->{'left'}, $structure_data->{'condition'}->[$i]->[1]->{'op'}, $structure_data->{'condition'}->[$i]->[1]->{'right'};
my %line = (
'line' => $line_no,
'cover' => { v=>$hits_count, class=>c_class($cover) },
'code' => $code,
);
if ($hits_count) {
$line{'hits'}->{'class'} = 'c4';
}
$lines{$line_no} = \%line;
$i++;
}
$self->{'formatter'}->add_report(
code => $basename,
basename => $basename,
title => 'Condition coverage: ' . $structure_data->{'file'},
);
my $coverage_table = $self->{'formatter'}->add_table(
$basename,
'Coverage',
{
label => 'Condition coverage',
headers => {
'line' => { caption=>'Line', f=>q{%d}, fs=>q{%d}, class=>'head' },
'cover' => { caption=>q{%}, f=>q{%d}, fs=>q{%d} },
'code' => { caption=>'Condition', f=>q{%s}, fs=>q{%s}, class=>'src' },
},
headers_order => [qw( line cover code )],
}
);
foreach my $line (sort {$a->{'line'} <=> $b->{'line'}} values %lines) {
$coverage_table->add_row($line);
}
$self->{'formatter'}->close_report($basename);
return;
} # }}}
make_summary_report
Make file index, with coverage summary for each.
Parameters: $self $total_summary - total (all files/runs average)
summary =cut sub make_summary_report { # {{{ my ( $self,
$total_summary ) = @_;
my $summary_report = $self->{'formatter'}->add_report(
code => 'Summary',
basename => 'cover_report',
title => 'Coverage summary'
);
my $covered_table = $self->{'formatter'}->add_table(
'Summary',
'Files',
{
label => 'Covered files:',
headers => {
file => { caption => 'File', f=>q{%s}, class => 'file' },
'statement' => { caption=>'St.', f=>q{%d%%}, fs=>q{%.1f%%} },
'branch' => { caption=>'Br.', f=>q{%d%%}, fs=>q{%.1f%%} },
'condition' => { caption=>'Cond.', f=>q{%d%%}, fs=>q{%.1f%%} },
'subroutine' => { caption=>'Sub.', f=>q{%d%%}, fs=>q{%.1f%%} },
'pod' => { caption=>'POD', f=>q{%d%%}, fs=>q{%.1f%%} },
'time' => { caption=>'Time', f=>q{%.3fs}, fs=>q{%.3fs} },
'runs' => { caption=>'Runs', f=>q{%d}, fs=>q{%d} },
},
headers_order => [ 'file', @{ $self->{'criterion-order'} }, 'runs' ],
}
);
# Add rows for every single covered file:
foreach my $file_summary (sort { $a->{'file'}->{'v'} cmp $b->{'file'}->{'v'} } values %{ $self->{'summary'}->{'files'} }) {
$covered_table->add_row($file_summary);
}
# Add total summary as well:
$covered_table->add_summary($total_summary);
return $self->{'formatter'}->close_report('Summary');
} # }}}
compute_summary
Utility routine, compute summary for each criterion.
c_class
Compute proper c-class, used for color-coding coverage information:
c0 : not covered or coverage < 50% c1 : coverage >= 50% c2 :
coverage >= 75% c3 : coverage >= 90% c4 : covered or coverage = 100%
Static function.
namify_path
If image is worth a thousand words, then example should cound as
about 750... Turn something like this:
/home/natanael/Perl/Foo/Bar/Baz.pm
into this: -home-natanael-Perl-Foo-Bar-Baz-pm
Additionally, remove any characters, that could confuse shell.
Effectivelly, the resulting string should be safe for use in shell,
web and by childrens under 3 years old :)
Static function.
LICENCE
Copyright 2009, Bartłomiej Syguła (natanael@natanael.krakow.pl)
# This is free software. It is licensed, and can be distributed under
the same terms as Perl itself.
For more, see by website: http://natanael.krakow.pl