Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?

Coverage History

by choroba (Bishop)
on Feb 17, 2016 at 15:07 UTC ( #1155474=CUFP: print w/replies, xml ) Need Help??

You probably know how to use Devel::Cover, or even Coveralls as part of your Travis CI. 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. CPANCover 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.

If you use git as your version control system, your distribution stores code in the lib/ directory, and tests are located in `t/`, you can try the following code without modification (tested on Linux only). It checks for its dependencies, but if you want to be prepared, here's the list:

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 ; 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/" } ; __XSH__ rename "cover_db.$n/", "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, '>', '' 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 "" 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.

Update: Added CPANCover.

($q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord }map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+$1,++print+eval$q,q,a,

Replies are listed 'Best First'.
Re: Coverage History
by pjcj (Novice) on Feb 19, 2016 at 19:54 UTC
    Nice! I've not run the code, but I have one observation and request. You are getting the coverage data by parsing the html. The html is almost certain to change and break your code. Instead, please use the API. This will also allow you to speed things up somewhat and also save space by not generating the html. The details are in the Devel::Cover::DB module.
      Thanks for the tip. I might try to do it, but I'm not sure about "saving space"—one of the features of the program is that it interlinks the HTML files so you can browse the history.
      ($q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord }map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+$1,++print+eval$q,q,a,
Re: Coverage History
by 1nickt (Prior) on Feb 18, 2016 at 01:23 UTC

    Hi choroba,

    Great idea!

    I installed the dependencies and launched the program. Unfortunately it appears to hang on the first commit it reads:

    $ perl ./ 1/187 Note: checking out '87b89525e1f99c0070e6e62d86a3c30a77b3f631'. You are in 'detached HEAD' state. You can look around, make experiment +al changes and commit them, and you can discard any commits you make in t +his state without impacting any branches by performing another checkout. If you want to create a new branch to retain commits you create, you m +ay do so (now or later) by using -b with the checkout command again. Exam +ple: git checkout -b new_branch_name HEAD is now at 87b8952... Add rule to Utils::Location::ParseInput for +afb/Air Force Base Use of uninitialized value $_[1] in system at ./ line 21.
    Nothing after that ...


    The way forward always starts with a minimal test.
      Does it really hang, or do you get the prompt back? Is there any Makefile.PL or Build.PL present? If you use something like Dist::Zilla, you'll have to add support for it to make_or_build .
      ($q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord }map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+$1,++print+eval$q,q,a,

        • It was really hanging.
        • However there was no Makefile.PL present. I created one, and the program ran to completion.
        • However, I think it doesn't recursively descend into subdirs of /t:
          PERL_DL_NONLAZY=1 "/home/vagrant/perl5/perlbrew/perls/perl-5.16.3/bin/ +perl" "-MExtUtils::Command::MM" "-MTest::Harness" "-e" "undef *Test:: +Harness::Switches; test_harness(0, 'blib/lib', 'blib/arch')" t/*.t Files=0, Tests=0, 0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU +) Result: NOTESTS
          $ ls -la t total 28 drwxrwxr-x 7 vagrant vagrant 4096 Jan 11 21:33 . drwxrwxr-x 13 vagrant vagrant 4096 Feb 18 12:39 .. drwxrwxr-x 2 vagrant vagrant 4096 Jan 21 09:27 00-general drwxrwxr-x 5 vagrant vagrant 4096 Feb 5 20:25 10-job drwxrwxr-x 2 vagrant vagrant 4096 Jan 19 20:57 20-site drwxrwxr-x 2 vagrant vagrant 4096 Feb 5 20:25 30-feed drwxrwxr-x 2 vagrant vagrant 4096 Feb 17 17:58 40-utils
        • Not sure where to specify recursion into /t subdirs.


        The way forward always starts with a minimal test.

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://1155474]
Approved by toolic
Front-paged by Arunbear
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (3)
As of 2017-11-21 05:30 GMT
Find Nodes?
    Voting Booth?
    In order to be able to say "I know Perl", you must have:

    Results (295 votes). Check out past polls.