libdevel-cover-perl 1.08-1ubuntu2 / usr / bin / cpancover

#!/usr/bin/perl

eval 'exec /usr/bin/perl  -S $0 ${1+"$@"}'
    if 0; # not running under some shell

# Copyright 2002-2013, Paul Johnson (paul@pjcj.net)

# 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 = '1.08'; # VERSION

use Devel::Cover::DB;
use Devel::Cover::Dumper;

use Cwd ();
use Fcntl ":flock";
use Getopt::Long;
use Pod::Usage;
use Template 2.00;
use Parallel::Iterator "iterate_as_array";

# 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 " . __PACKAGE__->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;

    open my $fh, "<", $f or return;
    my $try;
    until (flock $fh, LOCK_SH)
    {
        die "Can't lock $f: $!\n" if $try++ > 60;
        sleep 1;
    }
    while (<$fh>)
    {
        my ($mod, $status) = split;
        $results{$mod} = $status;
    }
    close $fh 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 $out = "cover.out";
    unlink $out;

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

    my $od = "$Options->{outputdir}/$module";
    my $of = $Options->{outputfile};
    my $timeout = 900;  # fifteen minutes should be enough

    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 " .
                ">> $out 2>&1";
            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 my $fh, ">", $f or die "Can't open $f: $!\n";
    my $try;
    until (flock $fh, LOCK_EX)
    {
        die "Can't lock $f: $!\n" if $try++ > 60;
        sleep 1;
    }
    for my $mod (sort keys %$results)
    {
        print $fh "$mod $results->{$mod}\n";
    }
    close $fh or die "Can't close $f: $!\n";

    sys "cat $out" if -e $out;
}

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_csv
{
    my ($data) = @_;

    open(my $fh, ">", "$Options->{outputdir}/cpan_cover.csv")
            or die "cannot open > cpan_cover.txt: $!";

    # TODO GET DISTRIBUTION
    my @header = qw/release distribution link
                    branch_class branch_details branch_pc
                    condition_class condition_details condition_pc
                    pod_class pod_details pod_pc
                    statement_class statement_details statement_pc
                    subroutine_class subroutine_details subroutine_pc
                    total_class total_details total_pc/;
    print $fh join(",", @header ) . "\n";
    foreach my $release  (keys %{$data->{vals}} ) {

        my $line = [];
        push @$line, $release,
        push @$line, $data->{vals}{$release}{link};

        foreach my $level1 (
            qw/branch condition pod statement subroutine total/ ) {
                foreach my $level2 ( qw/class details pc/ ) {
                    push @$line, $data->{vals}{$release}{$level1}{$level2};
                }
        }
        print $fh join ( ",",@$line)."\n";
    }
    close $fh;
    print "\n\nWrote cpan_cover.csv output to $Options->{outputdir}/cpan_cover.csv\n";
}

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

        eval
        {
            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);
            }
        }
    }
    write_stylesheet;
    $Template->process("summary", $vars, $f) or die $Template->error();
    write_csv($vars);

    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})
    {
        my $workers = $ENV{CPANCOVER_WORKERS} || 0;
        my @res = iterate_as_array
        (
            { workers => $workers },
            sub { eval { get_cover $_[1] };
                  warn "\n\n\n[$_[1]]: $@\n\n\n" if $@ },
            $Options->{module}
        );
        # print Dumper \@res;
        # get_cover($_) for @{$Options->{module}};
    }

    write_html;
}

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

use strict;
use warnings;

our $VERSION = '1.08'; # VERSION

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 $VERSION
Devel::Cover is copyright 2001-2012, Paul Johnson (paul\@pjcj.net)
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>

<br/>

<hr/>
Coverage information from <a href="https://metacpan.org/module/Devel::Cover">
  Devel::Cover
</a> by <a href="http://pjcj.net">Paul Johnson</a>.

<br/>

<a href="http://cpancover.com/blead/latest/coverage.html">Core coverage</a>
(under development)

<br/>
<br/>

This server generously donated by
<a href="http://www.bytemark.co.uk/r/cpancover">
  <img src="http://www.bytemark.co.uk/images/subpages/spreadtheword/bytemark_logo_179_x_14.png" alt="bytemark"/>
</a>

[% END %]
EOT

::main

__END__

=head1 NAME

cpancover - report coverage statistics on CPAN modules

=head1 VERSION

version 1.08

=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 REQUIREMENTS

The modules L<Template> and L<Parallel::Iterator> are required.

=head1 EXIT STATUS

The following exit values are returned:

0   All operations were completed successfully.

>0  An error occurred.

=head1 SEE ALSO

 L<Devel::Cover>

=head1 BUGS

 Incomplete.
 Undocumented.
 Needs to be redone properly.

=head1 LICENCE

Copyright 2002-2013, Paul Johnson (paul@pjcj.net)

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