File Coverage

blib/lib/CPAN/YACSmoke.pm

Criterion	Covered	Total	%
statement	68	324	20.9
branch	3	124	2.4
condition	0	84	0.0
subroutine	23	40	57.5
pod	6	10	60.0
total	100	582	17.1

=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 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=<
  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 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__