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

474 lines (363 sloc) 10.481 kb
#!/usr/bin/perl
# Copyright 2002-2004, 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.38";
use Devel::Cover::DB 0.38;
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
outputfile=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};
$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;
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";
my $of = $Options->{outputfile};
sys "$^X $inc $s/cover -report html -outputdir $od -outputfile $of"
if -d && /^cover_db\z/ && (!-e "$od/$of" || $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
{
my $base = $Options->{directory};
my $db = Devel::Cover::DB->new(db => "$base/$File::Find::dir");
return unless $db->is_valid;
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.38";
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.38
Devel::Cover is copyright 2001-2004, 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.38 - 12th March 2004
=head1 LICENCE
Copyright 2002-2004, 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.