File Coverage

lib/CPANPLUS/YACSmoke.pm

Criterion	Covered	Total	%
statement	203	324	62.6
branch	46	122	37.7
condition	19	61	31.1
subroutine	29	34	85.2
pod	7	7	100.0
total	304	548	55.4

package CPANPLUS::YACSmoke;
$CPANPLUS::YACSmoke::VERSION = '1.04';
# Dist::Zilla: +PodWeaver
#ABSTRACT: Yet Another CPANPLUS Smoke Tester

use strict;
use warnings;

use Carp;
use CPANPLUS::Backend;
use CPANPLUS::Configure;
use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;
use POSIX qw( O_CREAT O_RDWR O_RDONLY );         # for SDBM_File
use SDBM_File;
use File::Fetch;
use IO::File;
use File::Spec::Unix;
use File::Spec::Functions;
use File::Path;
use CPANPLUS::YACSmoke::ReAssemble;
use CPANPLUS::YACSmoke::SortVers;
use CPANPLUS::YACSmoke::IniFiles;

use constant DATABASE_FILE => 'cpansmoke.dat';
use constant CONFIG_FILE   => 'cpansmoke.ini';
use constant RECENT_FILE   => 'RECENT';

require Exporter;

our @ISA = qw( Exporter );
our %EXPORT_TAGS = (
  'all'      => [ qw( mark test excluded purge flush reindex) ],
  'default'  => [ qw( mark test excluded ) ],
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT    = ( @{ $EXPORT_TAGS{'default'} } );

{
  my %Checked;
  my $TiedObj;


sub _connect_db {
  my $self = shift;
  return if $TiedObj;
  my $filename = catfile( $self->{conf}->get_conf('base'), DATABASE_FILE );
  $TiedObj = tie %Checked, 'SDBM_File', $filename, O_CREAT|O_RDWR, 0644;
  $self->{checked} = \%Checked;
}

sub _disconnect_db {
  my $self = shift;
  return unless $TiedObj;
  $TiedObj         = undef;
  $self->{checked} = undef;
  untie %Checked;
}

sub new {
  my $package = shift;
  my $nconf = shift if ref $_[0] and $_[0]->isa('CPANPLUS::Configure');

  $ENV{AUTOMATED_TESTING} = 1;
  $ENV{NONINTERACTIVE_TESTING} = 1; # Lancaster Consensus
  $ENV{PERL_MM_USE_DEFAULT} = 1; # despite verbose setting
  $ENV{PERL_EXTUTILS_AUTOINSTALL} = '--defaultdeps';

  my $conf = $nconf || CPANPLUS::Configure->new();

  # Override configure settings
  $conf->set_conf( prereqs => 2 ); # force to ask callback
  $conf->set_conf( skiptest => 0 );
  $conf->set_conf( no_update => 1 )
    if glob( catfile( $conf->get_conf('base'), $conf->_get_source('stored') .'*'. STORABLE_EXT, ) );
  $conf->set_conf( dist_type => 'CPANPLUS::Dist::YACSmoke' ); # this is where the magic happens.
  $conf->set_conf( cpantest => 'dont_cc' ); # Yes, we want to report test results. But not CC
  $conf->set_conf( verbose => 1 ); # set verbosity to true.
  $conf->set_conf( allow_unknown_prereqs => 0 ); # don't allow unknown prereqs

  unless ( defined $ENV{MAILDOMAIN} ) {
     my $hostpart = ( split /\@/, ( $conf->get_conf( 'email' ) || '[e-mail]' ) )[1];
     $ENV{MAILDOMAIN} = $hostpart =~ /^(cpan\.org|gmail\.com)$/i ? 'cpantesters.org' : $hostpart;
  }

  if ( $^V gt v5.9.5 ) {
     $conf->set_conf( prefer_makefile => 0 ); # Prefer Build.PL if we have M::B
  }
  else {
     eval "require Module::Build";
     $conf->set_conf( prefer_makefile => 0 ) unless $@; #
  }

  my $cb   = CPANPLUS::Backend->new($conf);

  my $exclude_dists;
  my $exclude_auths;
  my $local_lib;
  my $config_file = catfile( $conf->get_conf('base'), CONFIG_FILE );
  if ( -r $config_file ) {
     my $cfg = CPANPLUS::YACSmoke::IniFiles->new(-file => $config_file);
     {
       my @list = $cfg->val( 'CONFIG', 'exclude_dists' );
       if ( @list ) {
          $exclude_dists = CPANPLUS::YACSmoke::ReAssemble->new();
          $exclude_dists->add( @list );
       }
     }
     {
       my @list = $cfg->val( 'CONFIG', 'exclude_auths' );
       if ( @list ) {
          $exclude_auths = CPANPLUS::YACSmoke::ReAssemble->new();
          $exclude_auths->add( @list );
       }
     }
     $local_lib = $cfg->val( 'CONFIG', 'local::lib' );
  }

  my $self = bless { @_ }, $package;
  $self->{conf} = $conf;
  $self->{cpanplus} = $cb;
  $self->{exclude_dists} = $exclude_dists;
  $self->{exclude_auths} = $exclude_auths;
  $self->{allow_retries} = 'aborted|ungraded';
  $self->{local_lib}     = $local_lib;
  return $self;
}

sub test {
  my $self;
  eval {
    if ( (ref $_[0]) && $_[0]->isa(__PACKAGE__) ) {
	$self = shift;
    }
  };
  $self ||= __PACKAGE__->new();
  $self->_connect_db();

  my @dists = @_;

  unless ( @dists ) {
     @dists = $self->_download_list();
  }

  my @mods;

  foreach my $dist ( @dists ) {
     my $mod = $self->{cpanplus}->parse_module( module => $dist );
     next unless $mod;
     my $package = $mod->package_name .'-'. $mod->package_version;
     my $grade = $self->{checked}->{$package} || 'ungraded';
     next if $self->_is_excluded_dist($package);
     next if $mod->is_bundle;
     next unless $grade =~ /$self->{allow_retries}/;
     push @mods, $mod;
  }

  $self->_disconnect_db();

  my $target = 'create';

  if ( $self->{local_lib} ) {
     $self->_setup_local_lib();
     $self->{conf}->_perl5lib( $ENV{PERL5LIB} );
     $target = 'install';
     msg("Setup local::lib environment in '$ENV{PERL_LOCAL_LIB_ROOT}'");
  }

  foreach my $mod ( @mods ) {
     eval {
		CPANPLUS::Error->flush();
		my $stat = $self->{cpanplus}->install(
				modules  => [ $mod ],
				target   => $target,
				allow_build_interactively => 0,
				# other settings now set via set_config() method
		);
     };
  }

  if ( $self->{local_lib} ) {
    my $build_dir = $self->_get_build_dir();
    msg("Flushing '$build_dir'");
    rmtree($build_dir) if -e $build_dir;
    msg("Flushed '$build_dir'");
  }

  $self->{cpanplus}->save_state() if !$self->{local_lib};

  return 1;
}

sub mark {
  my $self;
  eval {
    if ( (ref $_[0]) && $_[0]->isa(__PACKAGE__) ) {
	$self = shift;
    }
  };
  $self ||= __PACKAGE__->new();
  $self->_connect_db();

  my $distver = shift || '';
  my $grade   = lc shift || '';

  if ($grade) {
    my $mod = $self->{cpanplus}->parse_module( module => $distver );
    return error(qq{Invalid distribution "$distver"}) unless $mod;

    unless ($grade =~ /(pass|fail|unknown|na|none|ungraded|aborted|ignored)/) {
      return error("Invalid grade: '$grade'");
    }
    if ($grade eq "none") {
      $grade = undef;
    }

    $distver = $mod->package_name .'-'. $mod->package_version;
    $self->{checked}->{$distver} = $grade;
  }
  else {
    my @distros = ($distver ? ($distver) : $self->_download_list());
    foreach my $dist ( @distros ) {
       my $mod = $self->{cpanplus}->parse_module( module => $dist );
       next unless $mod;
       my $dist_ver = $mod->package_name .'-'. $mod->package_version;
       next if $self->_is_excluded_dist( $dist_ver );
       $grade = $self->{checked}->{$dist_ver};
       if ( $grade ) {
	 msg(qq{result for "$dist_ver" is "$grade"});
       }
       else {
	 msg(qq{no result for "$dist_ver"});
       }
    }
  }
  $self->_disconnect_db();
  return $grade if $distver;
}

sub excluded {
  my $self;
  eval {
    if ( (ref $_[0]) && $_[0]->isa(__PACKAGE__) ) {
	$self = shift;
    }
  };
  $self ||= __PACKAGE__->new();

  my @dists = @_;

  unless ( @dists ) {
     @dists = $self->_download_list();
  }

  my @mods;

  foreach my $dist ( @dists ) {
     my $mod = $self->{cpanplus}->parse_module( module => $dist );
     next unless $mod;
     my $package = $mod->package_name .'-'. $mod->package_version;
     my $auth = $mod->author->cpanid;
     next unless $self->_is_excluded_dist($package) || $self->_is_excluded_auth($auth);
     msg(qq{EXCLUDED: "$package"});
     push @mods, $package;
  }

  return @mods;
}

sub purge {
  my $self;
  eval {
    if ( (ref $_[0]) && $_[0]->isa(__PACKAGE__) ) {
	$self = shift;
    }
  };
  $self ||= __PACKAGE__->new();
  my %config = ref($_[0]) eq 'HASH' ? %{ shift() } : ();
  $self->_connect_db();

  my $flush = $config{flush_flag} || 0;
  my %distvars;
  my $override = 0;

  if(@_) {
     $override = 1;
     for(@_) {
	next	unless(/^(.*)\-(.+)$/);
	push @{$distvars{$1}}, $2;
     }
  }
  else {
     for(keys %{$self->{checked}}) {
	next	unless(/^(.*)\-(.+)$/);
	push @{$distvars{$1}}, $2;
     }
  }

  foreach my $dist (sort keys %distvars) {
     my $passed = $override;
     my @vers = sort { versioncmp($a, $b) } @{$distvars{$dist}};
     while(@vers) {
	my $vers = pop @vers;		# the latest
	if($passed) {
		msg("'$dist-$vers' ['".
					uc($self->{checked}->{"$dist-$vers"}).
					"'] has been purged");
		delete $self->{checked}->{"$dist-$vers"};
		if($flush) {
	          my $builddir =
                      catfile($self->_get_build_dir(), "$dist-$vers");
		      rmtree($builddir)	if(-d $builddir);
		}
	}
	elsif($self->{checked}->{"$dist-$vers"} eq 'pass') {
		$passed = 1;
	}
     }
  }

  $self->_disconnect_db();
  return 1;
}

sub flush {
  my $self;
  eval {
    if ( (ref $_[0]) && $_[0]->isa(__PACKAGE__) ) {
	$self = shift;
    }
  };
  $self ||= __PACKAGE__->new();
  my %config = ref($_[0]) eq 'HASH' ? %{ shift() } : ();
  $self->_connect_db();

  my $param = shift || 'all';

  my $build_dir = $self->_get_build_dir();

  if ( $param eq 'old' ) {
    my %dists;
    opendir(my $DIR, $build_dir);
    while(my $dir = readdir($DIR)) {
	    next if $dir =~ /^\.+$/;
		  $dir =~ /(.*)-(.+)/;
		  $dists{$1}->{$2} = "$dir";
	  }
    closedir($DIR);
	  for my $dist (keys %dists) {
	    for(sort { versioncmp($a, $b) } keys %{$dists{$dist}}) {
	      rmtree(catfile($build_dir,$dists{$dist}->{$_}));
		    msg("'$dists{$dist}->{$_}' flushed");
	    }
	  }
  }
	else {
		msg("Flushing '$build_dir'");
		rmtree($build_dir) if -e $build_dir;
		msg("Flushed '$build_dir'");
    require File::Glob;
    ( my $base = $self->{conf}->get_conf('base') ) =~ s![\\/]$!!;
    foreach my $sourcefile ( File::Glob::bsd_glob( $base . q{/sourcefile*} ) ) {
		  msg("Removing '$sourcefile'");
      rmtree $sourcefile;
    }
	}

  $self->_disconnect_db();
  return 1;
}

sub reindex {
  my $self;
  eval {
    if ( (ref $_[0]) && $_[0]->isa(__PACKAGE__) ) {
	$self = shift;
    }
  };
  $self ||= __PACKAGE__->new();
  $self->{conf}->set_conf( no_update => 0 );
  $self->{cpanplus}->reload_indices( update_source => 1 );
  $self->{conf}->set_conf( no_update => 1 )
    if glob( catfile( $self->{conf}->get_conf('base'), $self->{conf}->_get_source('stored') .'*'. STORABLE_EXT, ) );
  return 1;
}

sub _is_excluded_dist {
  my $self = shift;
  my $dist = shift || return;
  return unless $self->{exclude_dists};
  return 1 if $dist =~ $self->{exclude_dists}->re();
}

sub _is_excluded_auth {
  my $self = shift;
  my $auth = shift || return;
  return unless $self->{exclude_auths};
  return 1 if $auth =~ $self->{exclude_auths}->re();
}

sub _download_list {
  my $self  = shift;

  my $path  = $self->{conf}->get_conf('base');
  my $local = catfile( $path, RECENT_FILE );

  my $hosts = $self->{conf}->get_conf('hosts');
  my $h_ind = 0;

  while ($h_ind < @$hosts) {
      my $host = $hosts->[$h_ind];
      my $mirror_path = File::Spec::Unix->catfile(
           $host->{'path'},
           RECENT_FILE
      );

      my %args = (
          scheme => $host->{scheme},
          host   => $host->{host},
          path   => $mirror_path,
      );

      my $remote = $self->{cpanplus}->_host_to_uri( %args );

      my $ff = File::Fetch->new( uri => $remote );
      my $status = $ff->fetch( to => $path );
      last if $status;
      $h_ind++;
  }

  return ()   if(@$hosts == $h_ind); # no host accessible

  my @testlist;
  my $fh = IO::File->new($local)
    or croak("Cannot access local RECENT file [$local]: $!\n");
  while (<$fh>) {
    next    unless(/^authors/);
    next    unless(/\.(?:tar\.(?:bz2|gz|Z)|t(?:gz|bz)|(?
    s!authors/id/!!;
    chomp;
    push @testlist, $_;
  }

  return @testlist;
}

sub _get_build_dir {
  my $self = shift;
  File::Spec->catdir(
        $self->{conf}->get_conf('base'),
        $self->{cpanplus}->_perl_version( perl => $^X ),
        $self->{conf}->_get_build('moddir')
  );
}

sub _setup_local_lib {
  my $self = shift;
  return if !$self->{local_lib};
  require Cwd;
  require File::Temp;
  require CPANPLUS::YACSmoke::locallib;
  my $tmpdir = File::Temp::tempdir( DIR => '.', CLEANUP => 1 );
  my $abs = Cwd::abs_path($tmpdir);
  CPANPLUS::YACSmoke::locallib->ensure_dir_structure_for( $abs, { quiet => 1 } );
  CPANPLUS::YACSmoke::locallib->setup_env_hash_for( $abs );
}

}

'Yakkity Yac';

__END__