Coverage::History

coverages

#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

use HTML::TableExtract;
use Time::Piece;
use XML::XSH2;

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 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_ready();
}


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();
            shell(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 {
    say 'Done.';
    say 'coverage.png created.';
    say "file://" . $ENV{PWD} . '/cover_db.0/coverage.html';
}


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();