Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

509 lines (406 sloc) 11.375 kb
#!/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 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 $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 $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 = 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 " .
">> $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 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";
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_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})
{
my $workers = $ENV{CPANCOVER_WORKERS} || 0;
my @res = iterate_as_array
(
{ workers => $workers },
sub { get_cover $_[1] },
$Options->{module}
);
use Data::Dumper; print Dumper \@res;
# 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
Jump to Line
Something went wrong with that request. Please try again.