File Coverage

lib/CPAN/Testers/WWW/Reports/Query/AJAX.pm

Criterion	Covered	Total	%
statement	9	89	10.1
branch	0	28	0.0
condition	0	11	0.0
subroutine	3	20	15.0
pod	14	14	100.0
total	26	162	16.0

package CPAN::Testers::WWW::Reports::Query::AJAX;

use strict;
use warnings;

our $VERSION = '0.09';

#----------------------------------------------------------------------------

=head1 NAME

CPAN::Testers::WWW::Reports::Query::AJAX - Get specific CPAN Testers results

=head1 SYNOPSIS

    my $query = CPAN::Testers::WWW::Reports::Query::AJAX->new(
        dist            => 'App-Maisha',
        version         => '0.12',  # optional, will default to latest version
    );

    # basic results
    printf  "ALL: %d\n" .
            "PASS: %d\n" .
            "FAIL: %d\n" .
            "NA: %d\n" .
            "UNKNOWN: %d\n" .
            "%age PASS: %d\n" .
            "%age FAIL: %d\n" .
            "%age NA: %d\n" .
            "%age UNKNOWN: %d\n",

            $query->all,
            $query->pass,
            $query->fail,
            $query->na,
            $query->unknown,
            $query->pc_pass,
            $query->pc_fail,
            $query->pc_na,
            $query->pc_unknown;

    # get the raw data for all results, or a specific version if supplied
    my $data = $query->raw;

    # basic filters (see new() for details)
    my $query = CPAN::Testers::WWW::Reports::Query::AJAX->new(
        dist            => 'App-Maisha',
        version         => '0.12',
        osname          => 'Win32',
        patches         => 1,
        perlmat         => 1,
        perlver         => '5.10.0',
        format          => 'xml' # xml is default, text also supported
    );

    printf  "Win32 PASS: %d\n", $query->pass;

=head1 DESCRIPTION

This module queries the CPAN Testers website (via the AJAX interface) and
retrieves a simple data set of results. It then parses these to answer a few
simple questions.

=cut

#----------------------------------------------------------------------------
# Library Modules

use WWW::Mechanize;

#----------------------------------------------------------------------------
# Variables

my $URL = 'http://www.cpantesters.org/cgi-bin/reports-summary.cgi?';
#$URL = 'http://reports/cgi-bin/reports-summary.cgi?';    # local test version

my %rules = (
    dist    => qr/^([-\w.]+)$/i,
    version => qr/^([-\w.]+)$/i,
    perlmat => qr/^([0-2])$/i,
    patches => qr/^([0-2])$/i,
    perlver => qr/^([\w.]+)$/i,
    osname  => qr/^([\w.]+)$/i,
    format  => qr/^(csv|html|xml)$/i
);

my @fields = keys %rules;

my $mech = WWW::Mechanize->new();
$mech->agent_alias( 'Linux Mozilla' );

# -------------------------------------
# Program

sub new {
    my($class, %hash) = @_;
    my $self = {
        success => 0,
        error   => ''
    };
    bless $self, $class;
    my @valid = qw(format);

    unless($hash{dist}) {
        $self->{error} = q{no value for 'dist' provided};
        return;
    }

    for my $key (@fields) {
        next    unless($hash{$key});
        my ($value) = $hash{$key} =~ m/$rules{$key}/;
        next    unless($value);

        $self->{options}{$key} = $value;
        push @valid, $key;
    }

    $self->{options}{format} ||= 'xml';

    # ajax request
    my $url = $URL;
    $url .= join( '&', map { "$_=$self->{options}{$_}" } @valid );
    #print STDERR "# URL: $url\n";
	eval { $mech->get( $url ); };
    if($@ || !$mech->success()) {
        $self->{error} = $@;
        return $self;
    }

    #print "URI: " . $mech->uri . "\n";

    $self->_parse( $mech->content() );

    $self->{success} = 1;
    return $self;
}

sub is_success  { $_[0]->{success};         }
sub error       { $_[0]->{error};           }

sub all         { $_[0]->_basic('all');     }
sub pass        { $_[0]->_basic('pass');    }
sub fail        { $_[0]->_basic('fail');    }
sub na          { $_[0]->_basic('na');      }
sub unknown     { $_[0]->_basic('unknown'); }

sub pc_pass     { $_[0]->_basic_pc('pass');    }
sub pc_fail     { $_[0]->_basic_pc('fail');    }
sub pc_na       { $_[0]->_basic_pc('na');      }
sub pc_unknown  { $_[0]->_basic_pc('unknown'); }

sub _basic {
    my $self    = shift;
    my $grade   = shift;
    my $version = $self->{options}{version} || $self->{recent};
    return $self->{result}{$version}{$grade};
}

sub _basic_pc {
    my $self    = shift;
    my $grade   = shift;
    my $version = $self->{options}{version} || $self->{recent};
    return 0    unless($self->{result}{$version}{'all'});
    my $pc = sprintf "%3.10f", $self->{result}{$version}{$grade} / $self->{result}{$version}{'all'} * 100;
    $pc =~ s/\.?0+$//;
    return $pc;
}

sub _parse {
    my ($self,$content) = @_;
    $self->{content} = $content;

    if($self->{options}{format} eq 'csv') {
        my @lines = split("\n",$content);
        for my $line (@lines) {
            next if($line =~ /^\s*$/);
            my ($version,$all,$pass,$fail,$na,$unknown) = split(',',$line);
            next unless($version);
            if (!exists $self->{recent}) {
                $self->{recent} = $version;
            }
            $self->{result}{$version}{pass}    = $pass;
            $self->{result}{$version}{fail}    = $fail;
            $self->{result}{$version}{na}      = $na;
            $self->{result}{$version}{unknown} = $unknown;
            $self->{result}{$version}{all}     = $all;
        }

    } elsif($self->{options}{format} eq 'xml') {
        my @lines = split("\n",$content);
        for my $line (@lines) {
            next if($line =~ /^\s*$/);
            my ($all,$pass,$fail,$na,$unknown,$version) = $line =~ m{([^<]+)};
            next unless($version);
            if (!exists $self->{recent}) {
                $self->{recent} = $version;
            }
            $self->{result}{$version}{pass}    = $pass;
            $self->{result}{$version}{fail}    = $fail;
            $self->{result}{$version}{na}      = $na;
            $self->{result}{$version}{unknown} = $unknown;
            $self->{result}{$version}{all}     = $all;
        }

    #} elsif($self->{options}{format} eq 'html') {
    } else {
        # TODO: need to pull out OT response
    }

    # currently no parsing for other formats.
    # use raw to do it yourself :)
}

sub data {
    my $self    = shift;
    my $version = shift;
    return $self->{result}{$version}   if($version);
    return $self->{result};
}

sub raw {
    my $self    = shift;
    return $self->{content};
}

1;

__END__