cpancover

#!/usr/bin/perl

# Copyright 2002-2010, Paul Johnson (pjcj@cpan.org)

# This software is free.  It is licensed under the same terms as Perl itself.

# The latest version of this software should be available from my homepage:
# http://www.pjcj.net

require 5.6.1;

use strict;
use warnings;

our $VERSION = "0.71";

use Devel::Cover::DB 0.71;

use Cwd ();
use Getopt::Long;
use Pod::Usage;
use Template 2.00;

# use Carp; $SIG{__DIE__} = \&Carp::confess;

my $Template;

my $Options =
{
    collect      => 1,
    directory    => Cwd::cwd(),
    force        => 0,
    module       => [],
    report       => "html_basic",
};

sub get_options
{
    die "Bad option" unless
    GetOptions($Options,                # Store the options in the Options hash.
               qw(
                   collect!
                   directory=s
                   force!
                   help|h!
                   info|i!
                   module=s
                   outputdir=s
                   outputfile=s
                   redo_cpancover_html!
                   redo_html!
                   report=s
                   version|v!
                 ));

    print "$0 version $VERSION\n" and exit 0 if $Options->{version};
    pod2usage(-exitval => 0, -verbose => 0)  if $Options->{help};
    pod2usage(-exitval => 0, -verbose => 2)  if $Options->{info};

    $Options->{outputdir}  ||= $Options->{directory};
    $Options->{outputfile} ||= "coverage.html";
    push @{$Options->{module}}, @ARGV;
    if (!$Options->{redo_cpancover_html} && !@{$Options->{module}})
    {
        my $d = $Options->{directory};
        opendir D, $d or die "Can't opendir $d: $!\n";
        @{$Options->{module}} = grep !/^\./ && -e "$d/$_/Makefile.PL",
                                     sort readdir D
            or die "No module directories found\n";
        closedir D or die "Can't closedir $d: $!\n";
    }
}

sub sys
{
    my ($command) = @_;
    print "$command\n";
    system $command;
}

sub read_results
{
    my $f = "$Options->{outputdir}/cover.results";
    my %results;

    if (open S, "<", $f)
    {
        while (<S>)
        {
            my ($mod, $status) = split;
            $results{$mod} = $status;
        }
        close S or die "Can't close $f: $!\n";
    }

    \%results
}

sub get_cover
{
    my ($module) = @_;

    print "\n\n\n**** Checking coverage of $module ****\n\n\n";

    my $d = "$Options->{directory}/$module";
    chdir $d or die "Can't chdir $d: $!\n";

    my $db = "$d/cover_db";
    print "Already analysed\n" if -d $db;

    my $test = !-e "$db/runs" || $Options->{force} ? " -test" : "";
    if ($test)
    {
        print "Testing $module\n";
        sys "$^X Makefile.PL" unless -e "Makefile";
    }

    my $od = "$Options->{outputdir}/$module";
    my $of = $Options->{outputfile};
    my $timeout = 1800;  # Half an hour should be enough even for SVK

    if ($test || !-e "$od/$of" || $Options->{redo_html})
    {
        eval
        {
            local $SIG{ALRM} = sub { die "alarm\n" };
            alarm $timeout;
            sys "cover$test -report $Options->{report} " .
                "-outputdir $od -outputfile $of";
            alarm 0;
        };
        if ($@)
        {
            die unless $@ eq "alarm\n";   # propagate unexpected errors
            warn "Timed out after $timeout seconds!\n";
        }
    }

    my $results = read_results;
    my $f = "$Options->{outputdir}/cover.results";

    $results->{$module} = 1;

    open S, ">", $f or die "Can't open $f: $!\n";
    for my $mod (sort keys %$results)
    {
        print S "$mod $results->{$mod}\n";
    }
    close S or die "Can't close $f: $!\n";
}

sub write_stylesheet
{
    my $css = "$Options->{outputdir}/cpancover.css";
    open CSS, ">", $css or return;
    print CSS <<EOF;
/* Stylesheet for Devel::Cover cpancover reports */

/* You may modify this file to alter the appearance of your coverage
 * reports. If you do, you should probably flag it read-only to prevent
 * future runs from overwriting it.
 */

/* Note: default values use the color-safe web palette. */

body {
    font-family: sans-serif;
}

h1 {
    text-align : center;
    background-color: #cc99ff;
    border: solid 1px #999999;
    padding: 0.2em;
    -moz-border-radius: 10px;
}

a {
    color: #000000;
}
a:visited {
    color: #333333;
}

table {
    border-spacing: 0px;
}
tr {
    text-align : center;
    vertical-align: top;
}
th,.h,.hh {
    background-color: #cccccc;
    border: solid 1px #333333;
    padding: 0em 0.2em;
    width: 2.5em;
    -moz-border-radius: 4px;
}
.hh {
    width: 25%;
}
td {
    border: solid 1px #cccccc;
    border-top: none;
    border-left: none;
    -moz-border-radius: 4px;
}
.hblank {
    height: 0.5em;
}
.dblank {
    border: none;
}

/* source code */
pre,.s {
    text-align: left;
    font-family: monospace;
    white-space: pre;
    padding: 0.2em 0.5em 0em 0.5em;
}

/* Classes for color-coding coverage information:
 *   c0  : path not covered or coverage < 75%
 *   c1  : coverage >= 75%
 *   c2  : coverage >= 90%
 *   c3  : path covered or coverage = 100%
 */
.c0 {
    background-color: #ff9999;
    border: solid 1px #cc0000;
}
.c1 {
    background-color: #ffcc99;
    border: solid 1px #ff9933;
}
.c2 {
    background-color: #ffff99;
    border: solid 1px #cccc66;
}
.c3 {
    background-color: #99ff99;
    border: solid 1px #009900;
}
EOF

    close CSS or die "Can't close $css: $!\n";
}

sub class
{
    my ($pc) = @_;
    $pc eq "n/a" ? "na" :
    $pc <    75  ? "c0" :
    $pc <    90  ? "c1" :
    $pc <   100  ? "c2" :
                   "c3"
}

sub write_html
{
    my $d = $Options->{directory};
    chdir $d or die "Can't chdir $d: $!\n";

    my $results = read_results;
    my $f = "$Options->{outputdir}/$Options->{outputfile}";
    print "\n\nWriting cpancover output to $f ...\n";

    my %vals;
    my $vars =
    {
        title   => "CPAN Coverage report",
        modules => [],
        vals    => \%vals,
    };

    for my $module (sort keys %$results)
    {
        my $dbdir = "$Options->{directory}/$module/cover_db";
        next unless -d $dbdir;
        chdir "$Options->{directory}/$module";
        print "Adding $module from $dbdir\n";

        my $db = Devel::Cover::DB->new(db => $dbdir);
        # next unless $db->is_valid;

        my $criteria = $vars->{criteria} ||=
                       [ grep(!/path|time/, $db->all_criteria) ];
        $vars->{headers} ||=
                       [ grep(!/path|time/, $db->all_criteria_short) ];

        my %options = map { $_ => 1 } @$criteria;
        $db->calculate_summary(%options);

        push @{$vars->{modules}}, $module;
        $vals{$module}{link} = "$module/$Options->{outputfile}";

        for my $criterion (@$criteria)
        {
            my $summary = $db->summary("Total", $criterion);
            my $pc = $summary->{percentage};
            $pc = defined $pc ? sprintf "%6.2f", $pc : "n/a";
            $vals{$module}{$criterion}{pc}      = $pc;
            $vals{$module}{$criterion}{class}   = class($pc);
            $vals{$module}{$criterion}{details} =
                ($summary->{covered} || 0) . " / " . ($summary->{total} || 0);
        }
    }

    # use Data::Dumper; print Dumper $vars;

    write_stylesheet;
    $Template->process("summary", $vars, $f) or die $Template->error();

    print "done.\n";
    print "\n\nWrote cpancover output to $f\n";
}

sub main
{
    get_options;

    $Template = Template->new
    ({
        LOAD_TEMPLATES =>
        [
            Devel::Cover::Cpancover::Template::Provider->new({}),
        ],
    });

    if ($Options->{collect})
    {
        get_cover($_) for @{$Options->{module}};
    }

    write_html;
}

package Devel::Cover::Cpancover::Template::Provider;

use strict;
use warnings;

our $VERSION = "0.71";

use base "Template::Provider";

my %Templates;

sub fetch
{
    my $self = shift;
    my ($name) = @_;
    # print "Looking for <$name>\n";
    $self->SUPER::fetch(exists $Templates{$name} ? \$Templates{$name} : $name)
}

$Templates{colours} = <<'EOT';
[%
    colours =
    {
        default => "#ffffad",
        text    => "#000000",
        number  => "#ffffc0",
        error   => "#ff0000",
        ok      => "#00ff00",
    }
%]

[% MACRO bg BLOCK -%]
bgcolor="[% colours.$colour %]"
[%- END %]
EOT

$Templates{html} = <<'EOT';
<!DOCTYPE html
     PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<!--
This file was generated by Devel::Cover Version 0.71
Devel::Cover is copyright 2001-2010, Paul Johnson (pjcj\@cpan.org)
Devel::Cover is free. It is licensed under the same terms as Perl itself.
The latest version of Devel::Cover should be available from my homepage:
http://www.pjcj.net
-->
[% PROCESS colours %]
<head>
    <meta http-equiv="Content-Type" content="text/html; charset=utf-8"></meta>
    <meta http-equiv="Content-Language" content="en-us"></meta>
    <link rel="stylesheet" type="text/css" href="cpancover.css"></link>
    <title> [% title %] </title>
</head>
<body>
    [% content %]
</body>
</html>
EOT

$Templates{summary} = <<'EOT';
[% WRAPPER html %]

<h1> [% title %] </h1>

<table>

    [% IF modules %]
        <tr align="right" valign="middle">
            <th class="header" align="left"> File </th>
            [% FOREACH header = headers %]
                <th class="header"> [% header %] </th>
            [% END %]
        </tr>
    [% END %]

    [% FOREACH module = modules %]
        <tr align="right" valign="middle">
            <td align="left">
                <a href="[%- vals.$module.link -%]"> [% module %] </a>
            </td>

            [% FOREACH criterion = criteria %]
                <td class="[%- vals.$module.$criterion.class -%]"
                    title="[%- vals.$module.$criterion.details -%]">
                    [% vals.$module.$criterion.pc %]
                </td>
            [% END %]
        </tr>
    [% END %]

</table>

[% END %]
EOT

::main

__END__

=head1 NAME

cpancover - report coverage statistics on CPAN modules

=head1 SYNOPSIS

 cpancover -help -info -version

=head1 DESCRIPTION


=head1 OPTIONS

The following command line options are supported:

 -h -help              - show help
 -i -info              - show documentation
 -v -version           - show version

=head1 DETAILS


=head1 EXIT STATUS

The following exit values are returned:

0   All operaions were completed successfully.

>0  An error occurred.

=head1 SEE ALSO

 Devel::Cover

=head1 BUGS

 Incomplete.
 Undocumented.
 Needs to be redone properly.

=head1 VERSION

Version 0.71 - 10th September 2010

=head1 LICENCE

Copyright 2002-2010, Paul Johnson (pjcj@cpan.org)

This software is free.  It is licensed under the same terms as Perl itself.

The latest version of this software should be available from my homepage:
http://www.pjcj.net

=cut