CPAN::YACSmoke - Yet Another CPAN Smoke Tester

  perl -MCPAN::YACSmoke -e test

  %config = {
	  list_from => 'Recent',
 	  recent_list_age => '',
	  recent_list_path => '.'
  };

  CPANPLUS
  Test::Reporter

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

);

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();
}

# 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};
}

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;
}

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.

}

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);
}

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__