. I wanted to see how the coverage of my tests changes in time for each coverage type: that's something you can't get from the mentioned module and services easily.
shows it for released versions, but I wanted a more granular report.
I've written a program that does it. At the end, it creates a PNG graph that shows how each coverage type changed with each commit. It also modifies the HTML pages generated by cover so you can navigate between commits by clicking on the arrows.
Comments welcome. If you want to modify the code to handle SVN or CVS, use other tools to create the graph or track changes in different directories, we should probably start a GitHub project.
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use HTML::TableExtract;
use Time::Piece;
use XML::XSH2;
sub startup_check {
die 'Not a git repository' unless -d '.git';
die 'Devel::Cover not installed properly' unless qx{ which cover }
+;
die 'gnuplot not found' unless qx{ which gnuplot };
die "Repository not clean. Maybe stash the changes?" unless git_re
+ady();
}
sub shell {
my $status = system @_;
die "@_: $status" if $status;
}
sub git_ready {
open my $GIT, '-|', qw{ git status --porcelain } or die $!;
my $ready = 1;
while (<$GIT>) {
$ready = 0;
}
return $ready
}
sub git_branch {
open my $GIT, '-|', qw{ git branch } or die $!;
my $branch;
while (<$GIT>) {
$branch = "$1", last if /^\* (.*)/
}
close $GIT or die $!;
return $branch
}
my @columns = qw( file stmt bran cond sub pod time total );
sub extract_coverage {
my ($commit, $n, $total) = @_;
open my $HTML, '<', "cover_db.$n/coverage.html" or die $!;
my $te = 'HTML::TableExtract'
->new(headers => [ @columns ]);
my $html = do { local $/ ; <$HTML> };
my $tables = $te->parse($html);
for my $row ($tables->rows) {
next unless 'Total' eq $row->[0];
$total->{ $commit->{id} }
= { date => $commit->{date},
map { $columns[$_] => $row->[$_] } 1 .. $#columns
};
}
}
sub add_navigation {
my ($n, $max, $commit) = @_;
{ package XML::XSH2::Map;
our $n = $n;
our $date = $commit->{date};
our $max = $max;
}
xsh << '__XSH__';
open { "cover_db.$n/coverage.html" } ;
register-namespace h http://www.w3.org/1999/xhtml ;
rm //h:a[@id = 'coverage-history-previous'
or @id = 'coverage-history-next'] ;
$date_header = //h:td[text() = 'Report Date:'] ;
if ($date_header) {
set $date_header/text() 'Commit Date:' ;
set $date_header/following-sibling::h:td[1]/text() $date ;
}
if (0 != $n) {
$prev := insert element a append //h:body ;
set $prev/@id 'coverage-history-previous' ;
set $prev/text() { "\x{2190}" } ;
set $prev/@href concat('../cover_db.', $n - 1, '/coverage.
+html') ;
insert text ' ' after $prev ;
}
if ($max != $n) {
$next := insert element a append //h:body ;
set $next/@id 'coverage-history-next' ;
set $next/text() { "\x{2192}" } ;
set $next/@href concat('../cover_db.', $n + 1, '/coverage.
+html');
}
save :f { "cover_db.$n/coverage.new" } ;
__XSH__
rename "cover_db.$n/coverage.new", "cover_db.$n/coverage.html" or
+die $!;
}
sub graph_data {
my ($total) = @_;
for my $id (keys %$total) {
my $date = $total->{$id}{date};
my $tz = substr $date, -5, 5, q();
my $tp = 'Time::Piece'->strptime($date, '%a %b %d %H:%M:%S %Y
+');
my ($sign, $hours, $minutes) = $tz =~ /([-+])(\d\d)(\d\d)/;
$tp -= "${sign}1" * $minutes * 60 + $hours * 60 * 60;
$total->{$id}{UTC} = $tp->datetime;
}
open my $OUT, '>', 'coverages.data' or die $!;
for my $id ( sort { $total->{$a}{UTC} cmp $total->{$b}{UTC} }
keys %$total
){
my $commit = $total->{$id};
say {$OUT} join "\t", map 'n/a' eq $_ ? q() : $_,
@$commit{qw{ UTC sub stmt cond bran
+}};
}
close $OUT or die $!;
}
sub draw {
my ($output) = @_;
open my $GP, '|-', 'gnuplot' or die $!;
print {$GP} << '__GNUPLOT__';
set term png tiny
set output "coverages.png"
set key outside
set xdata time
set timefmt '%Y-%m-%dT%H:%M:%S'
plot "coverages.data" u 1:2 w lines t "subs", \
"" u 1:3 w lines t "statements", \
"" u 1:4 w lines t "conditions", \
"" u 1:5 w lines t "branches"
__GNUPLOT__
close $GP or die $!;
}
sub get_commits {
my (@commits, %current);
open my $LOG, '-|', qw{ git log --stat } or die $!;
while (<$LOG>) {
if (/^commit (.*)/) {
if (delete $current{keep}) {
unshift @commits, { %current };
}
%current = ( id => "$1" );
} elsif (/^Date:\s+(.*)/) {
$current{date} = "$1";
} elsif (m=^ (?:lib|t)/=) {
$current{keep} = 1;
}
}
close $LOG or die $!;
return \@commits
}
sub make_or_build {
my ($makefile) = grep -f, qw( Makefile.PL Build.PL );
shell('perl', $makefile);
}
sub get_total {
my ($commits) = @_;
my %total;
for my $idx (reverse 0 .. $#$commits) {
my $commit = $commits->[$idx];
my $id = $commit->{id};
say STDERR @$commits - $idx, '/', scalar @$commits;
if (! -d "cover_db.$idx") {
shell(qw{ git checkout }, $id);
make_or_build();
system qw{ cover -test };
rename 'cover_db', "cover_db.$idx" or die $!;
}
add_navigation($idx, $#$commits, $commit);
extract_coverage($commit, $idx, \%total);
}
return \%total
}
sub good_bye {
print << "__EOF__"
Done.
coverage.png created.
file://$ENV{PWD}/cover_db.0/coverage.html
__EOF__
}
sub main {
startup_check();
my $commits = get_commits();
my $branch = git_branch();
my $total = get_total($commits);
shell(qw{ git checkout }, $branch);
graph_data($total);
draw();
good_bye();
}
main();
If you have lots of commits, the first run can take some time. The next run will only process the commits that haven't been processed, yet, if you don't delete the created directories.