=head1 NAME
CPAN::YACSmoke - Yet Another CPAN Smoke Tester
=head1 SYNOPSIS
perl -MCPAN::YACSmoke -e test
=head1 DESCRIPTION
This module uses the backend of L<CPANPLUS> to run tests on modules
recently uploaded to CPAN and post results to the CPAN Testers list.
It will create a database file in the F<.cpanplus> directory, which it
uses to track tested distributions. This information will be used to
keep from posting multiple reports for the same module, and to keep
from testing modules that use non-passing modules as prerequisites.
If it is given multiple versions of the same distribution to test, it
will test the most recent version only. If that version fails, then
it will test a previous version.
By default it uses CPANPLUS configuration settings.
=cut
package CPAN::YACSmoke;
use 5.006001;
use strict;
use warnings;
use CPANPLUS::Backend 0.051;
use CPANPLUS::Configure;
use CPANPLUS::Error;
use File::Basename;
use File::HomeDir qw( home );
use File::Spec::Functions qw( splitpath catfile );
use LWP::Simple;
use POSIX qw( O_CREAT O_RDWR ); # for SDBM_File
use Regexp::Assemble;
use SDBM_File;
use Sort::Versions;
use URI;
use Module::Pluggable search_path => ["CPAN::YACSmoke::Plugin"];
use Carp;
use Config::IniFiles;
# use YAML 'Dump';
require Test::Reporter;
our $VERSION = '0.03';
$VERSION = eval $VERSION;
require Exporter;
our @ISA = qw( Exporter );
our %EXPORT_TAGS = (
'all' => [ qw( mark test excluded ) ],
'default' => [ qw( mark test excluded ) ],
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = ( @{ $EXPORT_TAGS{'default'} } );
# TODO: option to change default names
use constant DATABASE_FILE => 'cpansmoke.dat';
use constant CONFIG_FILE => 'cpansmoke.ini';
my $extn = qr/(?:\.(?:tar\.gz|tgz|zip))/; # supported archive extensions
{
my %Checked;
my $TiedObj;
# We use the TiedObj flag instead of tied(%Checked) because the
# function creates an additional reference in the scope of an
# if (tied %Checked) { ... } which causes a warning etc.
sub connect_db {
my $self = shift;
my $filename = shift || catfile($self->basedir(), DATABASE_FILE);
if ($TiedObj) {
# error("Already connected to the database!");
} else {
$TiedObj = tie %Checked, 'SDBM_File', $filename, O_CREAT|O_RDWR, 0644;
$self->{checked} = \%Checked;
$self->_debug("Connected to database ($filename).");
}
}
sub disconnect_db {
my $self = shift;
if ($TiedObj) {
$TiedObj = undef;
$self->{checked} = undef;
untie %Checked;
$self->_debug("Disconnected from database.");
# } else {
# error("Not connected to the database!");
}
}
my $CONF = CPANPLUS::Configure->new();
sub connect_configure {
return $CONF;
}
my $CpanPlus;
sub connect_cpanplus {
my $self = shift;
return $self->{cpan} = $CpanPlus if ($CpanPlus);
my $re = new Regexp::Assemble;
$re->add( @{$self->{exclude_dists}} );
$CpanPlus = CPANPLUS::Backend->new();
if ($CPANPLUS::Backend::VERSION >= 0.052) {
# TODO: if PASS included skipped tests, add a comment
$CpanPlus->_register_callback(
name => 'munge_test_report',
code => sub {
my $mod = shift;
my $report = shift || "";
$report .=
"\nThis report was machine-generated by CPAN::YACSmoke $VERSION.\n";
return $report;
},
);
}
# BUG: this callback does not seem to get called consistently, if at all.
$CpanPlus->_register_callback(
name => 'install_prerequisite',
code => sub {
my $mod = shift;
my $root;
if ($mod->package =~ /^(.+)$extn$/) {
$root = $1;
}
else {
error("Cannot handle ".$mod->package);
return;
}
unless ($TiedObj) {
croak "Not connected to database!";
}
while (my $arg = shift) {
$arg->package =~ m/^(.+)$extn$/;
my $package = $1;
# BUG: Exclusion does not seem to work for prereqs.
# Sometimes it seems that the install_prerequisite
# callback is not even called! Need to investigate.
if ($package =~ $re->re) { # prereq on excluded list
msg("Prereq $package is excluded");
return;
}
my $checked = $Checked{$package};
if (defined $checked &&
$checked =~ /aborted|fail|unknown|na|ungraded/ ) {
if ($self->{ignore_bad_prereqs}) {
msg("Known uninstallable prereqs $package - may have problems\n");
} else {
msg("Known uninstallable prereqs $package - aborting install\n");
$Checked{$root} = "aborted";
return;
}
}
}
return 1;
},
);
$CpanPlus->_register_callback(
name => 'send_test_report',
code => sub {
unless ($TiedObj) {
exit error("Not connected to database!");
}
my $mod = shift;
my $grade = lc shift;
if ($mod->{package} =~ /^(.+)$extn$/) {
my $package = $1;
my $checked = $Checked{$package};
# TODO: option to report only passing tests
return unless ($self->{cpantest});
return if (defined $checked && (
($checked eq 'aborted' && $grade ne 'pass') ||
($checked eq 'unknown' && $grade eq 'unknown') ||
($checked eq 'ungraded' && $grade eq 'fail') ||
($checked =~ /pass|na/) ||
($checked eq 'fail' && $grade =~ /unknown|na|fail/)));
$Checked{$package} = $grade;
return ((!$self->{report_pass_only}) || ($grade eq 'pass'));
} else {
error("Unable to parse package information\n");
return;
}
},
);
$CpanPlus->_register_callback(
name => 'edit_test_report',
code => sub { return; },
);
return $self->{cpan} = $CpanPlus;
}
}
my @CONFIG_FIELDS = qw(
verbose debug force cpantest
recent_list_age ignore_cpanplus_bugs fail_max
exclude_dists test_max audit_log
ignore_bad_prereqs report_pass_only
);
my @CPANPLUS_FIELDS = qw(
verbose debug force cpantest
prereqs skiptest
);
=head1 OBJECT INTERFACE
=over 4
=item new( [ %config ] )
The object interface is created normally through the test() or mark()
functions of the procedural interface. However, it can be accessed
with a set of configuration settings to extend the capabilities of
the package.
Configuration settings are:
verbose
debug
force
cpantest
report_pass_only
prereqs
ignore_cpanplus_bugs
ignore_bad_prereqs
fail_max
exclude_dists
test_max
list_from - List plugin required, default Recent
recent_list_age - used with the Recent plugin
recent_list_path - used with the Recent plugin
mailbox - used with the Outlook plugin
nntp_id - used with the NNTP plugin
webpath - used with the WebList plugin
audit_log - log file to write progress to
config_file - an INI file with the above settings
All settings can use defaults. With regards to the last setting,
the INI file should contain one setting per line, except the values
for the exclude_dists setting, which are laid out as:
[CONFIG]
exclude_dists=<<HERE
mod_perl
HERE
The above would then ignore any distribution that include the string
'mod_perl' in its name. This is useful for distributions which use
external C libraries, which are not installed, or for which testing
is problematic.
The setting 'test_max' is used to restrict the number of distributions
tested in a single run. As some distributions can take some time to be
tested, it may be more suitable to run in small batches at a time. The
default setting is 100 distributions.
=back
=cut
sub new {
my $class = shift || __PACKAGE__;
## Ensure CPANPLUS knows we automated. (Q: Should we use Env::C to
## set this instead?)
$ENV{AUTOMATED_TESTING} = 1;
my $conf = connect_configure();
## set internal defaults
my $self = {
conf => $conf,
checked => undef,
ignore_cpanplus_bugs => ($CPANPLUS::Backend::VERSION >= 0.052),
fail_max => 3, # max failed versions to try
exclude_dists => [ ], # Regexps to exclude
test_max => 100, # max distributions per run
};
bless $self, $class;
## set from CPANPLUS defaults
foreach my $field (@CPANPLUS_FIELDS) {
$self->{$field} = $conf->get_conf($field) || 0;
}
## force overide of default settings
$self->{skiptest} = 0;
$self->{prereqs} = 2; # force to ask callback
my %config = @_;
## config_file is an .ini file
$config{config_file} ||= catfile($self->basedir(), CONFIG_FILE);
if($config{config_file} && -r $config{config_file}) {
my $cfg = Config::IniFiles->new(-file => $config{config_file});
foreach my $field (@CONFIG_FIELDS) {
my $val = $cfg->val( 'CONFIG', $field );
$self->{$field} = $val if(defined $val);
}
my @list = $cfg->val( 'CONFIG', 'exclude_dists' );
$self->{exclude_dists} = [ @list ] if(@list);
}
if ($self->{audit_log}) {
my ($vol, $path, $file) = splitpath $self->{audit_log};
unless ($vol || $path) {
$self->{audit_log} = catfile($self->basedir(), $file);
}
}
## command line switches override
foreach my $field (@CONFIG_FIELDS, 'audit_cb') {
if (exists $config{$field}) {
$self->{$field} = $config{$field};
}
}
## reset CPANPLUS defaults
foreach my $field (@CPANPLUS_FIELDS) {
$conf->set_conf($field => $self->{$field});
}
$self->{test_max} = 0 if($self->{test_max} < 0); # sanity check
## determine the data source plugin
$config{list_from} ||= 'Recent';
my $plugin;
my @plugins = $self->plugins();
for(@plugins) {
$plugin = $_ if($_ =~ /$config{list_from}/);
}
croak("no plugin available of that name\n") unless($plugin);
eval "CORE::require $plugin";
croak "Couldn't require $plugin : $@" if $@;
$config{smoke} = $self;
$self->{plugin} = $plugin->new(\%config);
$self->connect_db();
$self->connect_cpanplus();
return $self;
}
sub DESTROY {
my $self = shift;
$self->_audit("Disconnecting from database");
$self->disconnect_db();
}
=head2 METHODS
=over 4
=item homedir
Obtains the users home directory
=cut
# TODO: use CPANPLUS function
sub homedir {
my $self = shift;
return $self->{homedir} = shift if (@_);
unless (defined $self->{homedir}) {
if ($^O eq "MSWin32") { # bug in File::HomeDir <= 0.06
$self->{homedir} = $ENV{HOME} ||
($ENV{HOMEDRIVE}.$ENV{HOMEPATH}) ||
$ENV{USERPROFILE} ||
home();
} else {
$self->{homedir} = home();
}
}
$self->_audit("homedir = " . $self->{homedir});
return $self->{homedir};
}
=item basedir
Obtains the base directory for downloading and testing distributions.
=back
=cut
sub basedir {
my $self = shift;
return $self->{basedir} = shift if (@_);
unless (defined $self->{basedir}) {
$self->{basedir} = $self->{conf}->get_conf("base") || $self->homedir();
}
return $self->{basedir};
}
sub _remove_excluded_dists {
my $self = shift;
my @dists = ( );
my $removed = 0;
my $re = new Regexp::Assemble;
$re->add( @{ $self->{exclude_dists} } );
while (my $dist = shift) {
if ($dist =~ $re->re) {
chomp($dist);
$self->_track("Excluding $dist");
$removed = 1;
} else {
push @dists, $dist;
}
}
$self->_audit('') if($removed);
return @dists;
}
sub _build_path_list {
my $self = shift;
my $ignored = 0;
my %paths = ( );
while (my $line = shift) {
if ($line =~ /^(.*)\-(.+)(\.tar\.gz)$/) {
my $dist = $1;
my @dirs = split /\/+/, $dist;
my $ver = $2;
# due to rt.cpan.org bugs #11093, #11125 in CPANPLUS
if ($self->{ignore_cpanplus_bugs} || (
(@dirs == 4) && ($ver =~ /^[\d\.\_]+$/)) ) {
if (exists $paths{$dist}) {
unshift @{ $paths{$dist} }, $ver;
} else {
$paths{$dist} = [ $ver ];
}
} else {
$self->_track("Ignoring $dist-$ver (due to CPAN+ bugs)");
$ignored = 1;
}
# check for previously parsed package string
} elsif ($line =~ /^(.*)\-(.+)$/) {
my $dist = $1;
my @dirs = split /\/+/, $dist;
my $ver = $2;
if (@dirs == 1) { # previously parsed
if (exists $paths{$dist}) {
unshift @{ $paths{$dist} }, $ver;
} else {
$paths{$dist} = [ $ver ];
}
}
}
}
$self->_audit('') if($ignored);
return %paths;
}
=head1 PROCEDURAL INTERFACE
=head2 EXPORTS
The following routines are exported by default. They are intended to
be called from the command-line, though they could be used from a
script.
=over
=cut
=item test( [ %config, ] [ $dist [, $dist .... ] ] )
perl -MCPAN::YACSmoke -e test
perl -MCPAN::YACSmoke -e test('R/RR/RRWO/Some-Dist-0.01.tar.gz')
Runs tests on CPAN distributions. Arguments should be paths of
individual distributions in the author directories. If no arguments
are given, it will download the F<RECENT> file from CPAN and use that.
By default it uses CPANPLUS configuration settings. If CPANPLUS is set
not to send test reports, then it will not send test reports.
For further use of configuration settings see the new() constructor.
=cut
sub test {
my $smoker;
eval {
if ((ref $_[0]) && $_[0]->isa(__PACKAGE__)) {
$smoker = shift;
}
};
my %config = ref($_[0]) eq 'HASH' ? %{ shift() } : ();
$smoker ||= __PACKAGE__->new(%config);
$smoker->_audit("\n\n".('-'x40)."\n");
my @distros = @_;
unless (@distros) {
@distros = $smoker->{plugin}->download_list(1);
unless (@distros) {
exit error("No new distributions uploaded to be tested");
}
}
my %paths = $smoker->_build_path_list(
$smoker->_remove_excluded_dists( @distros )
);
# only test as many distributions as specified
my @testlist;
push @testlist, keys %paths;
foreach my $distpath (sort @testlist) {
last unless($smoker->{test_max} > 0);
my @versions = @{ $paths{$distpath} };
my @dirs = split /\/+/, $distpath;
my $dist = $dirs[-1];
# When there are multiple recent versions of a distribution, we
# only want to test the latest one. If it fails, then we'll
# check previous distributions.
my $passed = 0;
my $fail_count = 0;
# TODO - if test fails due to bad prereqs, set $fail_count to
# fail_max and abort testing versions (based on an option)
while ( (!$passed) && ($fail_count < $smoker->{fail_max}) &&
(my $ver = shift @versions) ) {
my $distpathver = join("-", $distpath, $ver);
my $distver = join("-", $dist, $ver);
my $grade = $smoker->{checked}->{$distver}
|| 'ungraded';
if ((!defined $grade) ||
$grade =~ /(unknown|ungraded|none)/) {
my $mod = $smoker->{cpan}->parse_module( module => $distpathver)
or error("Invalid distribution $distver\n");
if ($mod && (!$mod->is_bundle)) {
$smoker->_audit("\n".('-'x40)."\n");
$smoker->_track("Testing $distpathver");
$smoker->{test_max}--;
eval {
CPANPLUS::Error->flush();
# TODO: option to not re-test prereqs that are known to
# pass (maybe if we use DBD::SQLite for the database and
# mark the date of the result?)
my $stat = $smoker->{cpan}->install(
modules => [ $mod ],
target => 'create',
allow_build_interactively => 0,
# other settings not set via set_confi() method
);
# TODO: check the $stat and react appropriately
$smoker->_audit(CPANPLUS::Error->stack_as_string());
# TODO: option to mark uncompleted tests as aborted vs ungraded
$grade = ($smoker->{checked}->{$distver} ||= 'aborted');
$passed = ($grade eq 'pass');
$smoker->_audit("\nReport Grade for $distver is ".uc($smoker->{checked}->{$distver})."\n");
}; # end eval block
}
} else {
$passed = ($grade eq 'pass');
$smoker->_audit("$distpathver already tested and graded ".uc($grade)."\n");
}
$fail_count++, unless ($passed);
}
}
$smoker = undef;
# TODO: repository fills up. An option to flush it is needed.
}
=item mark( [ %config, ] $dist [, $grade ] ] )
perl -MCPAN::YACSmoke -e mark('Some-Dist-0.01')
perl -MCPAN::YACSmoke -e mark('Some-Dist-0.01', 'fail')
Retrieves the test result in the database, or changes the test result.
It can be useful to update the status of a distribution that once
failed or was untestable but now works, so as to test modules which
make use of it.
Grades can be one of (case insensitive):
aborted
pass
fail
unknown
na
ungraded
none
For further use of configuration settings see the new() constructor.
=cut
sub mark {
my $smoker;
eval {
if ((ref $_[0]) && $_[0]->isa(__PACKAGE__)) {
$smoker = shift;
}
};
my %config = ref($_[0]) eq 'HASH' ? %{ shift() } : ( verbose => 1, );
$smoker ||= __PACKAGE__->new( );
$smoker->_audit("\n\n".('-'x40)."\n");
my $distver = shift || "";
my $grade = lc shift || "";
if ($grade) {
unless ($grade =~ /(pass|fail|unknown|na|none|ungraded|aborted)/) {
return error("Invalid grade: '$grade'");
}
if ($grade eq "none") {
$grade = undef;
}
$smoker->{checked}->{$distver} = $grade;
$smoker->_track("result for '$distver' marked as '" . ($grade||"none")."'");
} else {
my @distros = ($distver ? ($distver) : $smoker->{plugin}->download_list());
my %paths = $smoker->_build_path_list(
$smoker->_remove_excluded_dists( @distros )
);
foreach my $dist (sort { versioncmp($a, $b) } keys %paths) {
foreach my $ver (@{ $paths{$dist} }) {
$grade = $smoker->{checked}->{"$dist-$ver"};
if ($grade) {
$smoker->_track("result for '$dist-$ver' is '$grade'");
} else {
$smoker->_track("no result for '$dist-$ver'");
}
}
}
}
$smoker = undef;
return $grade if($distver);
}
=item excluded( [ %config, ] [ $dist [, $dist ... ] ] )
perl -MCPAN::YACSmoke -e excluded('Some-Dist-0.01')
perl -MCPAN::YACSmoke -e excluded()
Given a list of distributions, indicates which ones would be excluded from
testing, based on the exclude_dist list that is created.
For further use of configuration settings see the new() constructor.
=cut
sub excluded {
my $smoker;
eval {
if ((ref $_[0]) && $_[0]->isa(__PACKAGE__)) {
$smoker = shift;
}
};
my %config = ref($_[0]) eq 'HASH' ? %{ shift() } : ();
$smoker ||= __PACKAGE__->new(%config);
$smoker->_audit("\n\n".('-'x40)."\n");
my @distros = @_;
unless (@distros) {
@distros = $smoker->{plugin}->download_list();
unless (@distros) {
exit err("No new distributions uploaded to be tested");
}
}
my @dists = $smoker->_remove_excluded_dists( @distros );
$smoker->_audit('EXCLUDED: '.(scalar(@distros) - scalar(@dists))." distributions\n\n");
$smoker = undef;
return @dists;
}
# TODO: a method to purge older versions of test results from Checked
# database. (That is, if the latest version tested is 1.23, we don't
# need to keep earlier results around.) There should be an option to
# disable this behaviour.
## Private Methods
sub _track {
my ($self,$message) = @_;
msg($message, $self->{verbose});
$self->_audit($message);
}
sub _debug {
my ($self,$message) = @_;
return unless($self->{debug});
$self->_audit($message);
}
sub _audit {
my $self = shift;
$self->{audit_cb}->(@_) if($self->{audit_cb});
return unless($self->{audit_log});
my $FH = IO::File->new(">>".$self->{audit_log})
or exit error("Failed to write to file [$self->{audit_log}]: $!\n");
print $FH join("\n",@_) . "\n";
$FH->close;
}
1;
__END__
=pod
=back
=head1 PLUGINS
To know which distributions to test, the packages needs to access a list
of distributions that have been recently uploaded to CPAN. There are
currently four plugins which can enable this:
=head2 Recent
The Recent plugin downloads the F<RECENT> file from CPAN, and returns
the list of recently added modules, by diff-ing from the previously
downloaded version.
Pass through configuration settings:
%config = {
list_from => 'Recent',
recent_list_age => '',
recent_list_path => '.'
};
=head2 Writing A Plugin
For an example, see one of the above plugins.
The constructor, new(), is passed a hash of the configuration settings. The
setting 'smoke' is an object reference to YACSmoke. Be sure to save the
configuration settings your plugin requires in the constructor.
The single instance method used by YACSmoke is download_list(). This should
return a simple list of the distributions available for testing. Note
that if a parameter value of 1 is passed to download_list(), this indicates
that a test run is in progress, otherwise only a query on the outstanding
list is being made.
=head1 CAVEATS
This is a proto-type release. Use with caution and supervision.
The current version has a very primitive interface and limited
functionality. Future versions may have a lot of options.
There is always a risk associated with automatically downloading and
testing code from CPAN, which could turn out to be malicious or
severely buggy. Do not run this on a critical machine.
This module uses the backend of CPANPLUS to do most of the work, so is
subject to any bugs of CPANPLUS.
=head1 SUGGESTIONS AND BUG REPORTING
Please submit suggestions and report bugs to the CPAN Bug Tracker at
L<http://rt.cpan.org>.
=head1 SEE ALSO
The CPAN Testers Website at L<http://testers.cpan.org> has information
about the CPAN Testing Service.
For additional information, see the documentation for these modules:
CPANPLUS
Test::Reporter
=head1 AUTHORS
Robert Rothenberg <rrwo at cpan.org>
Barbie <barbie at cpan.org>, for Miss Barbell Productions,
L<http://www.missbarbell.co.uk>
=head2 Acknowledgements
Jos Boumans <kane at cpan.org> for writing L<CPANPLUS>.
=head2 Suggestions and Bug Reporting
Please submit suggestions and report bugs to the CPAN Bug Tracker at
L<http://rt.cpan.org>.
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2005 by Robert Rothenberg. All Rights Reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.3 or,
at your option, any later version of Perl 5 you may have available.
=cut
syntax highlighted by Code2HTML, v. 0.9.1