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{<version all="([^"]+)" pass="([^"]+)" fail="([^"]+)" na="([^"]+)" unknown="([^"]+)">([^<]+)</version>};
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__
=head1 INTERFACE
=head2 The Constructor
=over
=item * new
Instatiates the object CPAN::WWW::Testers. Requires a hash of parameters, with
'config' being the only mandatory key. Note that 'config' can be anything that
L<Config::IniFiles> accepts for the I<-file> option.
Available parameters are
=over 4
item * dist (required)
The distribution to provide a summary for. An error will be returned if no
distribution name is provided.
item * version (optional)
Filter based on a specific distribution version. Defaults to the latest
version.
item * perlmat (optional)
Filter based on perl maturity, i.e. whether a development version (5.21.3) or
a stable version (5.20.1). Values are:
=over 4
=item * 0 = all reports
=item * 1 = stable versions only
=item * 2 = development versions only
=back
item * patches (optional)
Filter based on whether the perl version is a patch. Values are:
=over 4
=item * 0 = all reports
=item * 1 = patches only
=item * 2 = exclude patches
=back
Defaults to all reports.
item * perlver (optional)
Filter based on Perl version, e.g. 5.20.1. Defaults to all versions.
item * osname (optional)
Filter based on Operating System name, e.g. MSWin32. Defaults to all Operating
Systems.
item * format (optional)
Available formats are: 'csv', 'html' and 'xml'. Defaults to 'html'.
=back
=back
=head2 Status Methods
=over 4
=item * is_success
Returns 1 if request succeeded, otherwise 0.
=item * error
Returns the error if the request was unsuccessful.
=back
=head2 Counter Methods
=over 4
=item * all
For the given query, the total number of reports stored.
=item * pass
For the given query, the total number of PASS reports stored.
=item * fail
For the given query, the total number of FAIL reports stored.
=item * na
For the given query, the total number of NA reports stored.
=item * unknown
For the given query, the total number of UNKNOWN reports stored.
=item * pc_pass
For the given query, the percentage number of PASS reports stored against all
reports stored.
=item * pc_fail
For the given query, the percentage number of FAIL reports stored against all
reports stored.
=item * pc_na
For the given query, the percentage number of NA reports stored against all
reports stored.
=item * pc_unknown
For the given query, the percentage number of UNKNOWN reports stored against all
reports stored.
=back
=head2 Data Methods
=over 4
=item * data
Returns the basic data structure as a hash reference. If a version is passed
as a parameter, the data only for that version is returned. Otherwise all the
results are returned, with the version as the top level key of the hash.
=item * raw
Returns the raw content returned from the server.
=back
=head1 BUGS, PATCHES & FIXES
There are no known bugs at the time of this release. However, if you spot a
bug or are experiencing difficulties, that is not explained within the POD
documentation, please send bug reports and patches to the RT Queue (see below).
Fixes are dependent upon their severity and my availability. Should a fix not
be forthcoming, please feel free to (politely) remind me.
RT Queue -
http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN::Testers::WWW::Reports::Query::AJAX
=head1 SEE ALSO
L<CPAN::Testers::Data::Generator>,
L<CPAN::Testers::WWW::Reports>
F<http://www.cpantesters.org/>,
F<http://stats.cpantesters.org/>,
F<http://wiki.cpantesters.org/>
I would also like to thank Leo Lapworth from prompting me to write this, sorry
its taken so long to release. However, you may be interested in his alternative
query distribution L<CPAN::Testers::Reports::Query::JSON>.
Initially released during the 2012 QA Hackathon in Paris.
=head1 CPAN TESTERS FUND
CPAN Testers wouldn't exist without the help and support of the Perl
community. However, since 2008 CPAN Testers has grown far beyond the
expectations of it's original creators. As a consequence it now requires
considerable funding to help support the infrastructure.
In early 2012 the Enlightened Perl Organisation very kindly set-up a
CPAN Testers Fund within their donatation structure, to help the project
cover the costs of servers and services.
If you would like to donate to the CPAN Testers Fund, please follow the link
below to the Enlightened Perl Organisation's donation site.
F<https://members.enlightenedperl.org/drupal/donate-cpan-testers>
If your company would like to support us, you can donate financially via the
fund link above, or if you have servers or services that we might use, please
send an email to admin@cpantesters.org with details.
Our full list of current sponsors can be found at our I <3 CPAN Testers site.
F<http://iheart.cpantesters.org>
=head1 AUTHOR
Barbie, <barbie@cpan.org>
for Miss Barbell Productions <http://www.missbarbell.co.uk>.
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2011-2014 Barbie for Miss Barbell Productions.
This module is free software; you can redistribute it and/or
modify it under the Artistic License 2.0.
=cut