Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

474 lines (363 sloc) 10.465 kB
#!/usr/local/bin/perl
# Copyright 2002-2003, 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.28";
use Devel::Cover::DB 0.28;
use Cwd ();
use File::Find ();
use Getopt::Long;
use Pod::Usage;
use Template 2.00;
my $Template;
my $Options =
{
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(
cover_source=s
directory=s
force!
help|h!
info|i!
module=s
outputdir=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};
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;
print "Cannot cover tests in test.pl\n" if -e "test.pl";
my $s = $Options->{cover_source};
my $inc = "-I$s/blib/lib -I$s/blib/arch";
$ENV{HARNESS_PERL_SWITCHES} =
"$inc -MDevel::Cover=-db,$db,+inc,$s,-ignore,\\\\bt/,-silent,1";
if ((! -d $db || $Options->{force}) && ! -e "test.pl")
{
print "Testing $module\n";
sys "$^X $inc $s/cover -delete $db";
sys "make";
sys "make test";
}
my $func = sub
{
my $od = "$Options->{outputdir}/$module";
sys "$^X $inc $s/cover -report html -outputdir $od"
if -d && /^cover_db\z/ &&
(!-e "$od/coverage.html" || $Options->{redo_html});
};
File::Find::find($func, $d);
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 $vars =
{
title => "CPAN Coverage report",
modules => [],
};
my %vals;
my $func = sub
{
if (/^cover\.5\z/s)
{
my $base = $Options->{directory};
my $db = Devel::Cover::DB->new(db => "$base/$File::Find::dir");
my $criteria = $vars->{headers} ||=
[ grep(!/path|time/, $db->all_criteria) ];
my %options = map { $_ => 1 } @$criteria;
$db->calculate_summary(%options);
my $module = $File::Find::dir;
$module =~ s|/cover_db$||;
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);
}
}
};
$vars->{vals} = \%vals;
for my $mod (sort keys %$results)
{
File::Find::find($func, $mod);
}
# use Data::Dumper;
# print Dumper $vars;
write_stylesheet;
$Template->process("summary", $vars, $f) or die $Template->error();
print "done.\n";
}
sub main
{
get_options;
$Template = Template->new
({
LOAD_TEMPLATES =>
[
Devel::Cover::Cpancover::Template::Provider->new({}),
],
});
get_cover($_) for @{$Options->{module}};
write_html;
}
package Devel::Cover::Cpancover::Template::Provider;
use strict;
use warnings;
our $VERSION = "0.28";
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.28
Devel::Cover is copyright 2001-2003, 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.
Needs to be redone properly.
=head1 VERSION
Version 0.28 - 1st December 2003
=head1 LICENCE
Copyright 2002-2003, 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.