File Coverage

lib/CPANPLUS/Dist/YACSmoke.pm

Criterion	Covered	Total	%
statement	128	153	83.6
branch	27	42	64.2
condition	13	26	50.0
subroutine	28	28	100.0
pod	2	2	100.0
total	198	251	78.8

package CPANPLUS::Dist::YACSmoke;
$CPANPLUS::Dist::YACSmoke::VERSION = '1.08';
# Dist::Zilla: +PodWeaver
#ABSTRACT: CPANPLUS distribution class that integrates CPAN Testing services into CPANPLUS

use strict;
use warnings;

use base qw(CPANPLUS::Dist::Base);

use Carp;
use CPANPLUS::Internals::Utils;
use CPANPLUS::Internals::Constants;
use CPANPLUS::Internals::Constants::Report;
use CPANPLUS::Error;
use Params::Check qw[check];
use POSIX qw( O_CREAT O_RDWR );         # for SDBM_File
use version;
use SDBM_File;
use File::Spec::Functions;
use CPANPLUS::YACSmoke::ReAssemble;
use CPANPLUS::YACSmoke::IniFiles;

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

{

$ENV{AUTOMATED_TESTING} = 1;
$ENV{PERL_MM_USE_DEFAULT} = 1; # despite verbose setting

my %Checked;
my $TiedObj;
my $exclude_dists;
my $exclude_auths;
my %throw_away;

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

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

  sub init {
    my $self = shift;
    my $mod  = $self->parent;
    my $cb   = $mod->parent;

    $self->status->mk_accessors(qw(_prepare _create _prereqs _skipbuild));

    my $conf = $cb->configure_object;

    if ( $conf->get_conf( 'prefer_makefile' ) ) {
        msg(qq{CPANPLUS is prefering Makefile.PL});
    }
    else {
        msg(qq{CPANPLUS is prefering Build.PL});
    }

    return 1 if $TiedObj;

    my $filename = catfile( $conf->get_conf('base'), DATABASE_FILE );
    msg(qq{Loading YACSmoke database "$filename"});
    $TiedObj = tie( %Checked, 'SDBM_File', $filename, O_CREAT|O_RDWR, 0644 )
	or error(qq{Failed to open "$filename": $!});

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

    # munge test report
    $cb->_register_callback(
        name => 'munge_test_report',
        code => sub {
		  my $mod    = shift;
		  my $report = shift || "";
		  my $grade  = shift;
      my $stack = CPANPLUS::Error->stack_as_string;
      my $cnf   = $mod->parent->configure_object;

		  SWITCH: {
        my $sv = version->new($CPANPLUS::Internals::VERSION) > version->new('0.9116');
        my $installer = $mod->status->installer_type;
        if ( $sv and $installer eq 'CPANPLUS::Dist::Build' ) {
          require CPANPLUS::Dist::Build;
          $sv = version->new($CPANPLUS::Dist::Build::VERSION) > version->new('0.60');
        }

		    if ( $grade ne GRADE_PASS and $stack =~ /Will not install prerequisite /s ) {
			      $throw_away{ $mod->package_name . '-' . $mod->package_version } = 'toss';
			      last SWITCH;
		    }
        if ( $grade ne GRADE_PASS and $stack =~ /You may have to resolve this dependency manually\./s ) {
            $throw_away{ $mod->package_name . '-' . $mod->package_version } = 'toss';
            last SWITCH;
        }
        if ( !$sv and $grade eq GRADE_PASS ) {
            my $last = ( split /MAKE TEST passed/, $stack )[-1];
            $report .= join('', 'MAKE TEST passed', $last, "\n\n");
            ### add a list of what modules have been loaded of your prereqs list
            $report .= REPORT_LOADED_PREREQS->($mod);
            ### add a list of versions of toolchain modules
            $report .= REPORT_TOOLCHAIN_VERSIONS->($mod);
            $report .= REPORT_MESSAGE_FOOTER->();
			      last SWITCH;
        }
		    if ( $grade ne GRADE_PASS and $stack =~ /No \'Makefile.PL\' found - attempting to generate one/s ) {
			      $throw_away{ $mod->package_name . '-' . $mod->package_version } = 'toss';
		    }
		  }

		  $report =~ s/\[MSG\].*may need to build a \'CPANPLUS::Dist::YACSmoke\' package for it as well.*?\n//sg;
      $report =~ s/\[MSG\] \[[\w: ]+\] Extracted '\S*?'\n//sg;
		  $report .=
			"\nThis report was machine-generated by CPANPLUS::Dist::YACSmoke $CPANPLUS::Dist::YACSmoke::VERSION.\n";
		  if ( $ENV{PERL5_MINIYACSMOKER} ) {
			$report .= "Powered by miniyacsmoker version " . $ENV{PERL5_MINIYACSMOKER} . "\n";
		  }
		  if ( $ENV{PERL5_MINISMOKEBOX} ) {
			$report .= "Powered by minismokebox version " . $ENV{PERL5_MINISMOKEBOX} . "\n";
		  }
      if ( $cnf->get_conf( 'prefer_makefile' ) ) {
        $report .= qq{\nCPANPLUS is prefering Makefile.PL\n};
      }
      else {
        $report .= qq{\nCPANPLUS is prefering Build.PL\n};
      }
		  $report .= _gen_report();
		  return $report;
        },
    );

    $cb->_register_callback(
      name => 'install_prerequisite',
      code => sub {
		my $mod   = shift;
		my $root = $mod->package_name .'-'. $mod->package_version;

		unless ($TiedObj) {
		  croak "Not connected to database!";
		}

		while (my $arg = shift) {
		  my $package = $arg->package_name .'-'. $arg->package_version;

		  # 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 ( _is_excluded_dist($package) ) { # prereq on excluded list
			msg("Prereq $package is excluded");
			return;
		  }
		  if ( _is_excluded_auth($arg->author->cpanid) ) { # author is on excluded list
			msg("Author (" . $arg->author->cpanid . ") of prereq $package is excluded");
			return;
		  }

		  my $checked = $Checked{$package};
		  if (defined $checked &&
			  #$checked =~ /aborted|fail|na/ ) {
			  $checked =~ /fail|na/ ) {

			  msg("Known uninstallable prereqs $package - aborting install\n");
			  $Checked{$root} = "aborted";
			  return;
		  }
		}
		return 1;
      },
    );

    $cb->_register_callback(
      name => 'send_test_report',
      code => sub {

		unless ($TiedObj) {
		  exit error("Not connected to database!");
		}
		my $mod   = shift;
		my $grade = lc shift;
		my $package = $mod->package_name .'-'. $mod->package_version;
		my $checked = $Checked{$package};

		# Did we want to throw away this report?
		my $throw = delete $throw_away{ $package };
		return if $throw;

          # Simplified algorithm for reporting:
          # * don't send a report if
          #   - we get the same results as the last report sent
          #   - it passed the last test but not now
          #   - it didn't pass the last test or now

		return if (defined $checked && (
                    ($checked eq $grade)                     ||
		    ($checked ne 'pass' && $grade ne 'pass')));

		  $Checked{$package} = $grade;

		return 1;
      },
    );

    $cb->_register_callback(
      name => 'edit_test_report',
      code => sub { return; },
    );


    return 1;
  }

  sub create {
    my $self = shift;
    my $mod  = $self->parent;
    my $dist_cpan = $mod->status->dist_cpan;

    if ( $dist_cpan->status->created ) {
       my %hash = @_;
       my $conf = $mod->parent->configure_object;
       my $args;
       my($force,$verbose,$prereq_target,$prereq_format, $prereq_build);
       {   local $Params::Check::ALLOW_UNKNOWN = 1;
          my $tmpl = {
            force           => {    default => $conf->get_conf('force'),
                                    store   => \$force },
            verbose         => {    default => $conf->get_conf('verbose'),
                                    store   => \$verbose },
            prereq_target   => {    default => '', store => \$prereq_target },
            prereq_format   => {    #default => $self->status->installer_type,
                                    default => '',
                                    store   => \$prereq_format },
            prereq_build    => {    default => 0, store => \$prereq_build },
          };
          $args = check( $tmpl, \%hash ) or return;
       }
       return 0 unless
	                  $self->_resolve_prereqs(
                        force           => $force,
                        format          => $prereq_format,
                        verbose         => $verbose,
                        prereqs         => $mod->status->prereqs,
                        target          => $prereq_target,
                        prereq_build    => $prereq_build,
                    );
       $mod->add_to_includepath();
       return 1;
    }

    my $package = $mod->package_name .'-'. $mod->package_version;
    msg(qq{Checking for previous PASS result for "$package"});
    my $checked = $Checked{$package};
    {
      # Don't propagate 'skiptest'
      my %args = @_;
      delete $args{skiptest};
      @_ = %args;
    }
    if ( $checked and $checked eq 'pass' ) {
       msg(qq{Found previous PASS result for "$package" skipping tests.});
       push @_, skiptest => 1;
    }
    $self->SUPER::create( @_ );
  }

sub _env_report {
  my @env_vars= qw(
    /PERL/
    /LC_/
    /HARNESS/
    CFLAGS
    LDFLAGS
    LANG
    LANGUAGE
    PATH
    SHELL
    COMSPEC
    TERM
    AUTOMATED_TESTING
    NONINTERACTIVE_TESTING
    AUTHOR_TESTING
    RELEASE_TESTING
    INCLUDE
    LIB
    LD_LIBRARY_PATH
    PROCESSOR_IDENTIFIER
    NUMBER_OF_PROCESSORS
  );
    my @vars_found;
    for my $var ( @env_vars ) {
        if ( $var =~ m{^/(.+)/$} ) {
            push @vars_found, grep { /$1/ } keys %ENV;
        }
        else {
            push @vars_found, $var if exists $ENV{$var};
        }
    }

    my $report = "";
    for my $var ( sort @vars_found ) {
        $report .= "    $var = $ENV{$var}\n" if defined $ENV{$var};
    }
    return $report;
}

sub _special_vars_report {
    my $special_vars = << "HERE";
    Perl: \$^X = $^X
    UID:  \$<  = $<
    EUID: \$>  = $>
    GID:  \$(  = $(
    EGID: \$)  = $)
HERE
    if ( $^O eq 'MSWin32' && eval "require Win32" ) {
        my @getosversion = Win32::GetOSVersion();
        my $getosversion = join(", ", @getosversion);
        $special_vars .= "    Win32::GetOSName = " . Win32::GetOSName() . "\n";
        $special_vars .= "    Win32::GetOSVersion = $getosversion\n";
        $special_vars .= "    Win32::IsAdminUser = " . Win32::IsAdminUser() . "\n";
    }
    return $special_vars;
}

sub _gen_report {
  my $env_vars = _env_report;
  my $special_vars = _special_vars_report();
  my $return = << "ADDREPORT";

------------------------------
ENVIRONMENT AND OTHER CONTEXT
------------------------------

Environment variables:

$env_vars
Perl special variables (and OS-specific diagnostics, for MSWin32):

$special_vars

-------------------------------

ADDREPORT

  return $return;
}

}

'Yakkity Yac';

__END__