CUFP
tobyink
<p>This script acts as a handy interface to the CPAN testers service, allowing you to quickly check pass/fail rates for a particular release.</p>
<p>It fetches <del>YAML</del><ins>JSON</ins> and performs HTTP caching, so probably puts <em>less</em> stress on the CPAN testers servers than a hit from a browser.</p>
<pre>
Usage:
cpan-testers Example-Distribution
cpan-testers -v0.001 Example-Distribution
cpan-testers -ov0.001 Example-Distribution
cpan-testers -s Example-Distribution
Options:
--version=V, -vV Show results for particular release version.
--os, -o Break down by operating system.
--summary, -s Show summary for all versions
(excludes "--version" and "--os" options).
--stable, -S Hide dev versions (excludes "--version").
</pre>
<p>Requires:</p>
<ul>
<li>Perl 5.010</li>
<li>[mod://Any::Moose]</li>
<li><ins>[mod://JSON]</ins></li>
<li>[mod://LWP::Simple]</li>
<li>[mod://PerlX::Maybe]</li>
<li><del>[mod://YAML::Any]</del></li>
<li>[mod://namespace::clean]</li>
</ul>
<readmore>
<code>
#!/usr/bin/env perl
use 5.010;
use strict;
use utf8;
{
package App::CpanTesters;
use Any::Moose 0;
use File::Path 0 qw< make_path >;
use File::Spec 0 qw< >;
use Getopt::Long 0 qw<
GetOptionsFromArray
:config permute bundling no_ignore_case no_auto_abbrev
>;
use JSON 0 qw< from_json >;
use LWP::Simple 0 qw< mirror is_success >;
use List::Util 0 qw< maxstr >;
use PerlX::Maybe 0 qw< maybe >;
sub show_help
{
my $exit_status = shift || 0;
print <<"HELP";
Usage:
$0 Example-Distribution
$0 -v0.001 Example-Distribution
$0 -ov0.001 Example-Distribution
$0 -s Example-Distribution
Options:
--version=V, -vV Show results for particular release version.
--os, -o Break down by operating system.
--summary, -s Show summary for all versions
(excludes "--version" and "--os" options).
--stable, -S Hide dev versions (excludes "--version").
HELP
exit($exit_status);
}
use namespace::clean;
has cache_dir => (
is => 'ro',
isa => 'Str',
lazy => 1,
builder => '_build_cache_dir',
);
has distro => (
is => 'ro',
isa => 'Str',
required => 1,
);
has results => (
is => 'ro',
isa => 'ArrayRef',
lazy => 1,
builder => '_build_results',
);
has version => (
is => 'ro',
isa => 'Str',
lazy => 1,
builder => '_build_version',
);
has os_data => (
is => 'ro',
isa => 'Bool',
default => 0,
);
has stable => (
is => 'ro',
isa => 'Bool',
default => 0,
);
sub run
{
my ($class, @argv) = @_;
my ($version, $summary, $os_data, $stable) = (undef, 0, 0, 0);
GetOptionsFromArray(
\@argv,
'version|v=s' => \$version,
'summary|s' => \$summary,
'os|o' => \$os_data,
'stable|S' => \$stable,
'help|usage|h' => \&show_help,
);
show_help(1) if $summary && ($os_data or length $version);
show_help(1) if $stable && length $version;
my $distro = shift @argv or show_help(1);
$distro =~ s{::}{-}g;
my $self = $class->new(
distro => $distro,
os_data => !!$os_data,
stable => !!$stable,
maybe version => $version,
);
if ($summary)
{
exit ! print $self->summary_report;
}
exit ! print $self->version_report;
}
sub version_data
{
my ($self) = @_;
my %data;
foreach (@{$self->results})
{
next unless $_->{version} eq $self->version;
my ($pv) = ($_->{perl} =~ /^5\.(\d+)/) or next;
next if $pv ~~ [9, 11, 13, 15];
my $key = $self->os_data
? sprintf("Perl 5.%03d, %s", $pv, $_->{ostext})
: sprintf("Perl 5.%03d", $pv);
my $num = { PASS => 0, FAIL => 1 }->{$_->{status}} // 2;
$data{$key}[$num]++;
}
return \%data;
}
sub summary_data
{
my ($self) = @_;
my %data;
foreach (@{$self->results})
{
my $key = $_->{version};
my $num = { PASS => 0, FAIL => 1 }->{$_->{status}} // 2;
$data{$key}[$num]++;
}
return \%data;
}
sub format_report
{
my ($self, $title, $data) = @_;
no warnings;
join "\n" => (
$title,
q(),
sprintf("%-32s%6s%6s%6s", q(), qw(PASS FAIL ETC)),
(
map { sprintf "%-32s% 6d% 6d% 6d", $_, @{$data->{$_}} }
sort keys %$data
),
q(),
);
}
sub version_report
{
my ($self) = @_;
$self->format_report(
sprintf("CPAN Testers results for %s version %s", $self->distro, $self->version),
$self->version_data,
);
}
sub summary_report
{
my ($self, $os_data) = @_;
$self->format_report(
sprintf("CPAN Testers results for %s", $self->distro),
$self->summary_data,
);
}
sub _build_version
{
maxstr
map { $_->{version} }
@{ shift->results }
}
sub _build_results
{
my $self = shift;
my $results_uri = sprintf(
'http://www.cpantesters.org/distro/%s/%s.json',
substr($self->distro, 0, 1),
$self->distro,
);
my $results_file = File::Spec->catfile(
$self->cache_dir,
sprintf('%s.json', $self->distro),
);
is_success mirror($results_uri => $results_file)
or do {
unlink $results_file;
die "Failed to retrieve URI $results_uri\n";
};
my $results = from_json do {
open my $fh, '<', $results_file
or die "Could not open $results_file: $!";
local $/ = <$fh>;
};
die "Unexpected non-ARRAY content from $results_uri\n"
unless ref $results eq 'ARRAY';
$self->stable
? [ grep { $_->{version} !~ /_/ } @$results ]
: $results;
}
sub _build_cache_dir
{
my $dir = File::Spec->catdir(
File::Spec->tmpdir,
'CpanTesters',
);
make_path $dir unless -d $dir;
return $dir;
}
}
App::CpanTesters->run(@ARGV)
unless scalar caller(0);
</code>
</readmore>
<p><b>Update:</b> switched from retrieving YAML to retrieving JSON. The YAML files seem a bit smaller, but JSON parsing seems more reliable, and the JSON files served by the CPAN Testers site seem to have more cache-friendly headers.</p>
<!-- Node text goes above. Div tags should contain sig only -->
<div class="pmsig"><div class="pmsig-757127">
<small><small>
<tt>perl -E'sub Monkey::do{say$_,for@_,do{($monkey=[caller(0)]->[3])=~s{::}{ }and$monkey}}"Monkey say"->Monkey::do'
</tt></small></small>
</div></div>