The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl
# ABSTRACT: delegate testing to the cloud
# PODNAME: cpan-tested
use 5.008;
use strict;
use utf8;
use warnings qw(all);

use CPAN::DistnameInfo;
use Carp qw(carp croak);
use Config;
use Data::Dumper;
use File::Spec::Functions;
use Getopt::Long;
use HTTP::Tiny;
use IO::Uncompress::Gunzip qw(gunzip $GunzipError);
use JSON::PP qw(decode_json);
use Pod::Usage qw(pod2usage);

$Data::Dumper::Sortkeys = 1;

our $VERSION = '0.001'; # VERSION


# parse the options file
my $rcname = catfile($ENV{HOME}, q(.cpan-tested.conf));
if (open(my $rcfile, q(<), $rcname)) {
    while (<$rcfile>) {
        s/\#.*$//x;
        s/^\s+|\s+$//gx;
        next unless $_;
        my @pair = split /\s+/x, $_, 2;
        $pair[0] = q(--) . $pair[0];
        unshift @ARGV, @pair;
    }
    close $rcfile;
}


my %match = (
    archname    => 0,
    osname      => 1,
    osvers      => 0,
    version     => 1,
);
Getopt::Long::GetOptions(
    q(h|help)       => \my $help,
    q(b|blacklist=s)=> \my @blacklist,
    q(v|verbose)    => \my $verbose,
    q(archname!)    => \$match{archname},   # "x86_64-linux"
    q(osname!)      => \$match{osname},     # "linux"
    q(osvers!)      => \$match{osvers},     # "3.0.0-26-generic"
    q(perl!)        => \$match{version},    # "5.14.2"
) or pod2usage(-verbose => 1);
pod2usage(-verbose => 2) if $help;

print STDERR Dumper \%match
    if $verbose;

my $ua = HTTP::Tiny->new(
    agent           => q(cpan-tested/) . $main::VERSION,
    default_headers => { q(Accept-Encoding) => q(gzip) },
);

while (my $name = <>) {
    chomp $name;
    my $d = CPAN::DistnameInfo->new($name);
    my %prop = $d->properties;
    next unless defined $prop{dist};

    # do not update blacklisted modules
    next if grep { $prop{dist} =~ /^$_$/x } @blacklist;

    my $json = fetch_results($prop{dist});
    my $versions = $json->{$prop{distvname}};
    if (q(ARRAY) ne ref $versions) {
        carp qq($prop{distvname} not tested yet);
        next;
    }

    for my $test (@{$versions}) {
        # cine qua non
        next if $test->{status} ne q(PASS);
        $test->{version} = delete $test->{perl};

        my %cross = map { $match{$_} ? ($_ => 1) : () } keys %match;
        for my $property (keys %cross) {
            delete $cross{$property}
                if $Config{$property} eq $test->{$property};
        }

        unless (keys %cross) {
            print STDERR Dumper $test
                if defined $verbose;

            print $name, qq(\n);
            last;
        }
    }
}

sub fetch_results {
    my ($dist) = @_;

    my $url = sprintf
        q(http://cpantesters.org/static/distro/%s/%s.js),
        substr($dist, 0, 1),
        $dist;

    print STDERR "$url\n"
        if defined $verbose;

    my $res = $ua->get($url);
    croak qq($url: $res->{reason})
        unless $res->{success};

    my $content;
    if (defined $res->{headers}->{q(content-encoding)}
            and $res->{headers}->{q(content-encoding)} eq q(gzip)) {

        my $tmp;
        gunzip \$res->{content} => \$tmp
            or croak qq($url: $GunzipError);

        $content = $tmp;
    } else {
        $content = $res->{content};
    }

    ($content) = $content =~ /\bvar\s+results\s*=\s*({.*?});/sx;
    $content =~ s/([{,])(\w+):/$1"$2":/gsx;
    my $json = eval { decode_json($content) };
    croak qq($url: $@)
        if $@
        or q(HASH) ne ref $json;

    return $json;
}

__END__

=pod

=encoding utf8

=head1 NAME

cpan-tested - delegate testing to the cloud

=head1 VERSION

version 0.001

=head1 SYNOPSIS

    cpan-outdated | cpan-tested [options] | cpanm

=head1 DESCRIPTION

Pre-filter the output from the L<cpan-outdated> utility, joining it with the results from the L<CPAN Testers Reports|http://cpantesters.org/>.

=head1 CONFIGURATION FILE

C<~/.cpan-tested.conf> can be used to persistently store L</OPTIONS>, in a quasi-L<perltidy> fashion:

    # installed manually; don't mess
    blacklist libintl-perl
    blacklist IO-Socket-SSL
    archname    # same architecture
    perl        # same Perl version
    no-osname   # ignore OS name string
    no-osvers   # ignore OS version string

=head1 OPTIONS

=over 4

=item --help

This.

=item --blacklist=regexp

Force skipping of the module which I<dist> name matches C<regexp>.
Can be issued multiple times.

=item --[no]archname

Expect B<PASS> from testers with the same C<$Config{archname}>.
Disabled by default.

=item --[no]osname

Expect B<PASS> from testers with the same C<$Config{osname}>.

=item --[no]osvers

Expect B<PASS> from testers with the same C<$Config{osvers}>.
Disabled by default.

=item --[no]perl

Expect B<PASS> from testers with the same C<$Config{perl}>.

=item --verbose

Dump what's happening to C<STDERR>.

=back

=head1 SEE ALSO

=over 4

=item *

L<cpan-outdated>

=item *

L<cpanm>

=item *

L<cpant>

=item *

L<CPAN Testers Reports|http://cpantesters.org/>

=back

=head1 AUTHOR

Stanislaw Pusep <stas@sysd.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2013 by Stanislaw Pusep.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut