Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
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.72";
use Devel::Cover::DB 0.72;
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.72";
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.72
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.72 - 27th 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.