cpancover

#!/usr/bin/perl

# Copyright 2002-2004, 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.49";

use Devel::Cover::DB 0.49;

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

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

my $Template;

my $Options =
{
    collect      => 1,
    cover_source => "/home/pjcj/g/perl/dev/Devel-Cover",
    directory    => Cwd::cwd(),
    force        => 0,
    module       => [],
};

sub get_options
{
    die "Bad option" unless
    GetOptions($Options,                # Store the options in the Options hash.
               qw(
                   collect!
                   cover_source=s
                   directory=s
                   force!
                   help|h!
                   info|i!
                   module=s
                   outputdir=s
                   outputfile=s
                   redo_cpancover_html!
                   redo_html!
                   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 $s = $Options->{cover_source};
    my $inc = "-I$s/blib/lib -I$s/blib/arch";

    if ((! -e "$db/runs" || $Options->{force}))
    {
        print "Testing $module\n";
        sys "$^X Makefile.PL" unless -e "Makefile";
        sys "$^X $inc $s/cover -delete $db";
        local $ENV{ -d "t" ? "HARNESS_PERL_SWITCHES" : "PERL5OPT" } =
            "$inc -MDevel::Cover=-db,$db,+inc,$s,-ignore,\\\\bt/,-silent,1";
        sys "make";
        sys "make test";
    }

    my $od = "$Options->{outputdir}/$module";
    my $of = $Options->{outputfile};
    sys "$^X $inc $s/cover -report html -outputdir $od -outputfile $of"
        if !-e "$od/$of" || $Options->{redo_html};

    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 cpancover
 * 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 {
    background-color: #3399ff;
    border: solid 1px #999999;
    padding: 0.2em;
}

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

code {
    white-space: pre;
}

table {
/*    border: solid 1px #000000;*/
/*    border-collapse: collapse;*/
}
td,th {
    border: solid 1px #cccccc;
}

/* Classes for color-coding coverage information:
 *   header    : column/row header
 *   uncovered : path not covered or coverage < 75%
 *   covered75 : coverage >= 75%
 *   covered90 : coverage >= 90%
 *   covered   : path covered or coverage = 100%
 */
.header {
    background-color: #cccccc;
    border: solid 1px #333333;
    padding-left:  0.2em;
    padding-right: 0.2em;
}
.uncovered {
    background-color: #ff9999;
    border: solid 1px #cc0000;
}
.covered75 {
    background-color: #ffcc99;
    border: solid 1px #ff9933;
}
.covered90 {
    background-color: #ffff99;
    border: solid 1px #cccc66;
}
.covered {
    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  ? "uncovered" :
    $pc <    90  ? "covered75" :
    $pc <   100  ? "covered90" :
                   "covered"
}

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

    my $results = read_results;
    my $f = "$Options->{outputdir}/cpancover.html";
    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;
        print "Adding $module\n";

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

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

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

        push @{$vars->{modules}}, $module;
        $vals{$module}{link} = "$module/coverage.html";

        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.49";

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';
[% PROCESS colours %]

<!--

This file was generated by Devel::Cover Version 0.49

Devel::Cover is copyright 2001-2004, 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

-->

<?xml version="1.0" encoding="utf-8"?>
<!DOCTYPE html
    PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN"
    "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">
<head>
    <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"></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 border="2">

    [% IF modules %]
        <tr align="RIGHT" valign="CENTER">
            <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="CENTER">
            <td align="LEFT">
                <a href="[%- vals.$module.link -%]"> [% module %] </a>
            </td>

            [% FOREACH criterion = headers %]
                <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.49 - 6th October 2004

=head1 LICENCE

Copyright 2002-2004, 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