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