=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