#!/usr/bin/perl
# Copyright 2002-2014, 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.09'; # 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.09'; # 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.09
=head1 SYNOPSIS
cpancover -help -info -version
-collect -redo_cpancover_html -redo_html -force
-module module_name
-directory /path/to/dir
-outputdir /path/to/dir
-outputfile filename.html
-report report_name
=head1 DESCRIPTION
=head1 OPTIONS
The following command line options are supported:
-h -help - show help
-i -info - show documentation
-v -version - show version
-collect - collect coverage from modules (on)
-directory - location of the modules ($cwd)
-force - recollect coverage (off)
-module - modules to use (all in $directory)
-outputdir - where to store output ($directory)
-outputfile - top level index (coverage.html)
-redo_cpancover_html - don't set default modules (off)
-redo_html - force html generation for modules (off)
-report - report to use (html_basic)
=head1 DETAILS
=head1 REQUIREMENTS
Collect coverage for results and create html, csv and json output.
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-2014, 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