File Coverage

blib/lib/CPAN/Reporter/Smoker.pm

Criterion	Covered	Total	%
statement	210	244	86.0
branch	76	114	66.6
condition	14	25	56.0
subroutine	24	25	96.0
pod	1	1	100.0
total	325	409	79.4

use 5.006;
use strict;
use warnings;
package CPAN::Reporter::Smoker;

our $VERSION = '0.29';

use Carp;
use Config;
use CPAN 1.93;
use CPAN::Tarzip;
use CPAN::HandleConfig;
use CPAN::Reporter::History 1.1702;
use Compress::Zlib 1.2;
use Fcntl ':flock';
use File::Basename qw/basename dirname/;
use File::Spec 3.27;
use File::Temp 0.20;
use List::Util 1.03 qw/shuffle/;
use Probe::Perl 0.01;
use Term::Title 0.01;

use Exporter;
our @ISA = 'Exporter';
our @EXPORT = qw/ start /; ## no critic Export

#--------------------------------------------------------------------------#
# globals
#--------------------------------------------------------------------------#

my $perl = Probe::Perl->find_perl_interpreter;
my $tmp_dir = File::Temp::tempdir(
  'C-R-Smoker-XXXXXXXX', DIR => File::Spec->tmpdir, CLEANUP => 1
);

#--------------------------------------------------------------------------#
# start -- start automated smoking
#--------------------------------------------------------------------------#
my %spec = (
  clean_cache_after => {
    default => 100,
    is_valid => sub { /^\d+$/ },
  },
  restart_delay => {
    default => 12 * 3600, # 12 hours
    is_valid => sub { /^\d+$/ },
  },
  set_term_title => {
    default => 1,
    is_valid => sub { /^[01]$/ },
  },
  status_file => {
    default => File::Spec->catfile( File::Spec->tmpdir, "smoker-status-$$.txt" ),
    is_valid => sub { -d dirname( $_ ) },
  },
  list => {
    default => undef,
    is_valid => sub { !defined $_ || ref $_ eq 'ARRAY' || -r $_ }
  },
  install => {
    default  => 0,
    is_valid => sub { /^[01]$/ },
  },
  'reverse' => {
    default => 0,
    is_valid => sub { /^[01]$/ },
  },
  'random' => {
    default => 0,
    is_valid => sub { /^[01]$/ },
  },
  force_trust => {
    default => 0,
    is_valid => sub { /^[01]$/ },
  },
  'reload_history_period' => {
    default => 30*60,
    is_valid => sub { /^\d+$/ },
  },
  filter => {
    default => undef,
    is_valid => sub { !defined $_ || ref $_ eq 'CODE' }
  },
  skip_dev_versions => {
    default => 0,
    is_valid => sub { /^[01]$/ },
  },
  '_start_from_timestamp' => {
    default => 0,
    is_valid => sub { /^(?:[\d.]{8}|0)$/ },
  },
  _hook_after_test => {
    default => undef,
    is_valid => sub { !defined $_ || ref $_ eq 'CODE' }
  },
);

sub start {
  my %args = map { $_ => $spec{$_}{default} } keys %spec;
  croak "Invalid arguments to start(): must be key/value pairs"
  if @_ % 2;
  while ( @_ ) {
    my ($key, $value) = splice @_, 0, 2;
    local $_ = $value; # alias for validator
    croak "Invalid argument to start(): $key => $value"
    unless $spec{$key} && $spec{$key}{is_valid}->($value);
    $args{$key} = $value;
  }

  # Stop here if we're just testing
  return 1 if $ENV{PERL_CR_SMOKER_SHORTCUT};

  # Notify before CPAN messages start
  $CPAN::Frontend->mywarn( "Starting CPAN::Reporter::Smoker\n" );

  # Let things know we're running automated
  local $ENV{AUTOMATED_TESTING} = 1;

  # Always accept default prompts
  local $ENV{PERL_MM_USE_DEFAULT} = 1;
  local $ENV{PERL_EXTUTILS_AUTOINSTALL} = "--defaultdeps";

  # Load CPAN configuration
  my $init_cpan = 0;
  unless ( $init_cpan++ ) {
    CPAN::HandleConfig->load();
    CPAN::Shell::setup_output;
    CPAN::Index->reload;
    $CPAN::META->checklock(); # needed for cache scanning
  }

  # Win32 SIGINT propogates all the way to us, so trap it before we smoke
  # Must come *after* checklock() to override CPAN's $SIG{INT}
  local $SIG{INT} = \&_prompt_quit;

  # Master loop
  # loop counter will increment with each restart - useful for testing
  my $loop_counter = 0;

  # global cache of distros smoked to speed skips on restart
  my %seen = map { $_->{dist} => 1 } CPAN::Reporter::History::have_tested();
  my $history_loaded_at = time;

  SCAN_LOOP:
  while ( 1 ) {
    $loop_counter++;
    my $loop_start_time = time;
    my $dists;

    # Get the list of distributions to process
    if ( $args{list} ) {
      # Given a list
      if ( ref $args{list} eq 'ARRAY' ) {
        $dists = $args{list};
      }
      # Given a file
      else {
        open( my $list_fh, "<", $args{list} ) or die $!;
        my @list = map { chomp; $_ } grep { /\S/ } <$list_fh>;
        $dists = \@list;
      }
    }
    else {
      # Or get list from CPAN
      my $package = _get_module_index( 'modules/02packages.details.txt.gz' );
      my $find_ls = _get_module_index( 'indices/find-ls.gz' );
      CPAN::Index->reload;
      $CPAN::Frontend->mywarn( "Smoker: scanning and sorting index\n");

      $dists = _parse_module_index( $package, $find_ls, $args{skip_dev_versions}, $args{_start_from_timestamp} );

      $CPAN::Frontend->mywarn( "Smoker: found " . scalar @$dists . " distributions on CPAN\n");
    }

    # Maybe reverse the list
    if ( $args{'reverse'} ) {
      $dists = [ reverse @$dists ];
    }

    # Maybe shuffle the list
    if ( $args{'random'} ) {
      $dists = [ shuffle @$dists ];
    }

    # Check if we need to manually reset test history during each dist loop
    my $reset_string = q{};
    if ( $CPAN::Config->{build_dir_reuse}
      && $CPAN::META->can('reset_tested') )
    {
      $reset_string = 'CPAN::Index->reload; $CPAN::META->reset_tested; '
    }

    # Force trust_test_report_history if requested
    my $trust_string = q{};
    if ( $args{force_trust} ) {
      $trust_string = '$CPAN::Config->{trust_test_report_history} = 1; '
    }

    # Clean cache on start and count dists tested to trigger cache cleanup
    _clean_cache();
    my $dists_tested = 0;

    # Start smoking
    DIST:
    for my $d ( 0 .. $#{$dists} ) {
      my $dist = CPAN::Shell->expandany($dists->[$d]);
      my $base = $dist->base_id;
      my $count = sprintf('%d/%d', $d+1, scalar @$dists);
      if ( $seen{$base}++ ) {
        $CPAN::Frontend->mywarn(
          "Smoker: already tested $base [$count]\n");
        next DIST;
      }
      elsif ( $args{filter} and $args{filter}->($dist) ) {
        $CPAN::Frontend->mywarn(
          "Smoker: dist skipped $base [$count]\n");
        next DIST;
      }
      elsif ( CPAN::Distribution->new(%{$dist})->prefs->{disabled} ) {
        $CPAN::Frontend->mywarn(
          "Smoker: dist disabled $base [$count]\n");
        next DIST;
      }
      else {
        # record distribution being smoked
        my $time = scalar localtime();
        my $msg = "$base [$count] at $time";
        if ( $args{set_term_title} ) {
          Term::Title::set_titlebar( "Smoking $msg" );
        }
        $CPAN::Frontend->mywarn( "\nSmoker: testing $msg\n\n" );
        local $ENV{PERL_CR_SMOKER_CURRENT} = $base;
        open my $status_fh, ">", $args{status_file};
        if ( $status_fh ) {
          flock $status_fh, LOCK_EX;
          print {$status_fh} $msg;
          flock $status_fh, LOCK_UN;
          close $status_fh;
        }
        # invoke CPAN.pm to test distribution
        system($perl, "-MCPAN", "-e",
          "\$CPAN::Config->{test_report} = 1; " . $trust_string
          . $reset_string . ($args{'install'} ? 'install' : 'test')
          . "( '$dists->[$d]' )"
        );
        my $interrupted = 0;
        if ( $? & 127 ) {
          $interrupted = 1;
          _prompt_quit( $? & 127 ) ;
        }

        if ($args{_hook_after_test}) {
          $args{_hook_after_test}->($dist, $interrupted);
        }

        # cleanup and record keeping
        unlink $args{status_file} if -f $args{status_file};
        $dists_tested++;
      }
      if ( $dists_tested >= $args{clean_cache_after} ) {
        _clean_cache();
        $dists_tested = 0;
      }
      if (time - $history_loaded_at > $args{reload_history_period}) { #_reload_history
        %seen = map { $_->{dist} => 1 } CPAN::Reporter::History::have_tested();
        $history_loaded_at = time;
        $CPAN::Frontend->mywarn( "List of distros smoked updated\n");
      }

      next SCAN_LOOP if time - $loop_start_time > $args{restart_delay};
    }
    last SCAN_LOOP if $ENV{PERL_CR_SMOKER_RUNONCE};
    last SCAN_LOOP if $args{list};
    # if here, we are out of distributions to test, so sleep
    my $delay = int( $args{restart_delay} - ( time - $loop_start_time ));
    if ( $delay > 0 ) {
      $CPAN::Frontend->mywarn(
        "\nSmoker: Finished all available dists. Sleeping for $delay seconds.\n\n"
      );
      sleep $delay ;
    }
  }

  CPAN::cleanup();
  return $loop_counter;
}

#--------------------------------------------------------------------------#
# private variables and functions
#--------------------------------------------------------------------------#

sub _clean_cache {
  my $phase = $CPAN::Config->{scan_cache};
  # Possibly clean up cache if it exceeds defined size
  if ( $CPAN::META->{cachemgr} ) {
    $CPAN::META->{cachemgr}->scan_cache($phase);
  }
  else {
    $CPAN::META->{cachemgr} = CPAN::CacheMgr->new($phase); # also scans cache
  }
}

sub _prompt_quit {
    my ($sig) = @_;
    # convert numeric to name
    if ( $sig =~ /\d+/ ) {
        my @signals = split q{ }, $Config{sig_name};
        $sig = $signals[$sig] || '???';
    }
    $CPAN::Frontend->myprint(
        "\nStopped during $ENV{PERL_CR_SMOKER_CURRENT}.\n"
    ) if defined $ENV{PERL_CR_SMOKER_CURRENT};
    $CPAN::Frontend->myprint(
        "\nCPAN testing halted on SIG$sig.  Continue (y/n)? [n]\n"
    );
    my $answer = ;
    CPAN::cleanup(), exit 0 unless substr( lc($answer), 0, 1) eq 'y';
    return;
}

#--------------------------------------------------------------------------#
# _get_module_index
#
# download the 01modules index and return the local file name
#--------------------------------------------------------------------------#

sub _get_module_index {
    my ($remote_file) = @_;

    $CPAN::Frontend->mywarn(
        "Smoker: getting $remote_file from CPAN\n");
    # CPAN.pm may not use aslocal if it's a file:// mirror
    my $aslocal_file = File::Spec->catfile( $tmp_dir, basename( $remote_file ));
    my $actual_local = CPAN::FTP->localize( $remote_file, $aslocal_file, 1 );
    if ( ! -r $actual_local ) {
        die "Couldn't get '$remote_file' from your CPAN mirror. Halting\n";
    }
    return $actual_local;
}

my $module_index_re = qr{
    ^\s href="\.\./authors/id/./../    # skip prelude
    ([^"]+)                     # capture to next dquote mark
    .+?                     # skip to end of hyperlink
    \s+                         # skip spaces
    \S+                         # skip size
    \s+                         # skip spaces
    (\S+)                       # capture day
    \s+                         # skip spaces
    (\S+)                       # capture month
    \s+                         # skip spaces
    (\S+)                       # capture year
}xms;

my %months = (
    Jan => '01', Feb => '02', Mar => '03', Apr => '04', May => '05',
    Jun => '06', Jul => '07', Aug => '08', Sep => '09', Oct => '10',
    Nov => '11', Dec => '12'
);

# standard regexes
# note on archive suffixes -- .pm.gz shows up in 02packagesf
my %re = (
    bundle => qr{^Bundle::},
    mod_perl => qr{/mod_perl},
    perls => qr{(?:
          /(?:emb|syb|bio)?perl-\d
        | /(?:parrot|ponie|kurila|Perl6-Pugs)-\d
        | /perl-?5\.004
        | /perl_mlb\.zip
    )}xi,
    archive => qr{\.(?:tar\.(?:bz2|gz|Z)|t(?:gz|bz)|(?
    target_dir => qr{
        ^(?:
            modules/by-module/[^/]+/./../ |
            modules/by-module/[^/]+/ |
            modules/by-category/[^/]+/[^/]+/./../ |
            modules/by-category/[^/]+/[^/]+/ |
            authors/id/./../
        )
    }x,
    leading_initials => qr{(.)/\1./},
);

# match version and suffix
$re{version_suffix} = qr{([-._]v?[0-9].*)($re{archive})};

# split into "AUTHOR/Name" and "Version"
$re{split_them} = qr{^(.+?)$re{version_suffix}$};

# matches "AUTHOR/tarball.suffix" or AUTHOR/modules/tarball.suffix
# and not other "AUTHOR/subdir/whatever"

# Just get AUTHOR/tarball.suffix from whatever file name is passed in
sub _get_base_id {
    my $file = shift;
    my $base_id = $file;
    $base_id =~ s{$re{target_dir}}{};
    return $base_id;
}

sub _base_name {
    my ($base_id) = @_;
    my $base_file = basename $base_id;
    my ($base_name, $base_version) = $base_file =~ $re{split_them};
    return $base_name;
}

#--------------------------------------------------------------------------#
# _parse_module_index
#
# parse index and return array_ref of distributions in reverse date order
#--------------------------------------------------------------------------#-

sub _parse_module_index {
    my ( $packages, $file_ls, $skip_dev_versions, $start_from_timestamp ) = @_;

    # first walk the packages list
    # and build an index

    my (%valid_bases, %valid_distros, %mirror);
    my (%latest, %latest_dev);

    my $gz = Compress::Zlib::gzopen($packages, "rb")
        or die "Cannot open package list: $Compress::Zlib::gzerrno";

    my $inheader = 1;
    while ($gz->gzreadline($_) > 0) {
        if ($inheader) {
            $inheader = 0 unless /\S/;
            next;
        }

        my ($module, $version, $path) = split;

        my $base_id = _get_base_id("authors/id/$path");

        # skip all perl-like distros
        next if $base_id =~ $re{perls};

        # skip mod_perl environment
        next if $base_id =~ $re{mod_perl};

        # skip all bundles
        next if $module =~ $re{bundle};

        $valid_distros{$base_id}++;
        my $base_name = _base_name( $base_id );
        if ($base_name) {
            $latest{$base_name} = {
                datetime => 0,
                base_id => $base_id
            };
        }
    }

    # next walk the find-ls file
    local *FH;
    tie *FH, 'CPAN::Tarzip', $file_ls;

    while ( defined ( my $line =  ) ) {
        my %stat;
        @stat{qw/inode blocks perms links owner group size datetime name linkname/}
            = split q{ }, $line;

        unless ($stat{name} && $stat{perms} && $stat{datetime}) {
            next;
        }
        # skip directories, symlinks and things that aren't a tarball
        next if $stat{perms} eq "l" || substr($stat{perms},0,1) eq "d";
        next unless $stat{name} =~ $re{target_dir};
        next unless $stat{name} =~ $re{archive};

        next if $start_from_timestamp && $stat{datetime} < $start_from_timestamp;

        # skip if not AUTHOR/tarball
        # skip perls
        my $base_id = _get_base_id($stat{name});
        next unless $base_id;

        next if $base_id =~ $re{perls};

        # skip Perl6 distros: AUTHOR/Perl6/...
        next if $base_id =~ m{\A\w+/Perl6/};

        my $base_name = _base_name( $base_id );

        # if $base_id matches 02packages, then it is the latest version
        # and we definitely want it; also update datetime from the initial
        # assumption of 0
        if ( $valid_distros{$base_id} ) {
            $mirror{$base_id} = $stat{datetime};
            next unless $base_name;
            if ( $stat{datetime} > $latest{$base_name}{datetime} ) {
                $latest{$base_name} = {
                    datetime => $stat{datetime},
                    base_id => $base_id
                };
            }
        }
        # if not in the packages file, we only want it if it resembles
        # something in the package file and we only the most recent one
        else {
            # skip if couldn't parse out the name without version number
            next unless defined $base_name;

            # skip unless there's a matching base from the packages file
            next unless $latest{$base_name};

            next if $skip_dev_versions;

            # keep only the latest
            $latest_dev{$base_name} ||= { datetime => 0 };
            if ( $stat{datetime} > $latest_dev{$base_name}{datetime} ) {
                $latest_dev{$base_name} = {
                    datetime => $stat{datetime},
                    base_id => $base_id
                };
            }
        }
    }

    if ( !$start_from_timestamp ) {
        # pick up anything from packages that wasn't found in find-ls
        # usually because find-ls is updated more rarely than packages
        # as it is missing from find-ls, timestamp would be set to 0
        for my $name ( keys %latest ) {
            my $base_id = $latest{$name}{base_id};
            $mirror{$base_id} = $latest{$name}{datetime} unless $mirror{$base_id};
        }
    }

    # for dev versions, it must be newer than the latest version of
    # the same base name from the packages file

    for my $name ( keys %latest_dev ) {
        if ( ! $latest{$name} ) {
            next;
        }
        next if $latest{$name}{datetime} > $latest_dev{$name}{datetime};
        $mirror{ $latest_dev{$name}{base_id} } = $latest_dev{$name}{datetime}
    }

    return [ sort { $mirror{$b} <=> $mirror{$a} } keys %mirror ];
}

1;

# ABSTRACT: Turnkey CPAN Testers smoking

__END__