perl-compiler/t/modules.pm

# -*- cperl -*-
use strict;
BEGIN {
  unshift @INC, 't';
}

require "test.pl";
use Test::More;
use Config;
use Cwd;
use Exporter;
our @ISA     = qw(Exporter);
our @EXPORT = qw(%modules $keep
		 perlversion
		 percent log_diag log_pass log_err get_module_list
                 random_sublist is_subset
		);
our (%modules);
our $log = 0;
our $keep = '';

sub perlversion {
  my $DEBUGGING = ($Config{ccflags} =~ m/-DDEBUGGING/);
  return sprintf("%1.6f%s%s",
		 $],
		 ($DEBUGGING ? 'd' : ''),
		 ($Config{useithreads} ? '' 
		    : $Config{usemultiplicity} ? '-m' 
		      : '-nt'));
}

sub percent {
  $_[1] ? sprintf("%0.1f%%", $_[0]*100/$_[1]) : '';
}

sub log_diag {
  my $message = shift;
  chomp $message;
  diag( $message );
  return unless $log;

  foreach ($log, "$log.err") {
    open(LOG, ">>", $_);
    $message =~ s/\n./\n# /xmsg;
    print LOG "# $message\n";
    close LOG;
  }
}

sub log_pass {
  my ($pass_msg, $module, $todo) = @_;
  return unless $log;

  if ($todo) {
    $todo = " #TODO $todo";
  } else {
    $todo = '';
  }

  diag( "$pass_msg $module$todo" );
  open(LOG, ">>", "$log");
  print LOG "$pass_msg $module$todo\n";
  close LOG;
}

sub log_err {
  my ($module, $out, $err) = @_;
  return if(!$log);

  # diag prints for TODO to a special todo fh, which does not end at the console
  # ignore diag the TODO empty STDERR test for now. we diag the ok test only
  # diag( "fail $module $out" );
  # Test::More->builder->_print_comment( Test::More->builder->failure_output, "fail $module $out" );

  $_ =~ s/\n/\n# /xmsg foreach($out, $err); # Format for comments

  open(ERR, ">>", "$log.err");
  print ERR "Failed $module\n";
  print ERR "# No output\n" if(!$out && !$err);
  print ERR "# STDOUT:\n# $out\n" if($out && $out ne 'ok');
  print ERR "# STDERR:\n# $err\n" if($err);
  close ERR;
}

sub is_subset {
  return 0 if grep /^-no-subset$/, @ARGV;
  return ! (-d '.svn' or -d'.git') || grep /^-subset$/, @ARGV;
}

sub get_module_list {
  # Parse for command line modules and use this if seen.
  my @modules = grep {$_ !~ /^-([\w-]+)$/} @ARGV; # ignore options
  # -no-subset defaults to all top100
  my $module_list  = (grep /^-no-subset$/, @ARGV) ? 't/top100' : 't/test10';
  if (@modules and -e $modules[0] and ! -x $modules[0]) { # skip an executable compiled module
    $module_list = $modules[0];
  }
  elsif (@modules) {
    # cmdline overrides require check and keeps .c
    $modules{$_} = 1 for @modules;
    $keep = "-S";
    return @modules;
  }

  local $/;
  open F, "<", $module_list or die "$module_list not found";
  my $s = <F>;
  close F;
  @modules = grep {s/\s+//g;!/^#/} split /\n/, $s;

  diag "scanning installed modules";
  for my $m (@modules) {
    # redirect stderr
    open (SAVEOUT, ">&STDERR");
    close STDERR;
    open (STDERR, ">", \$modules::saveout);
    if (eval "require $m;" or $m eq 'if') {
      $modules{$m} = 1;
    }
    # restore stderr
    close STDERR;
    open (STDERR, ">&SAVEOUT");
    close SAVEOUT;
  }

  if (&is_subset and @modules > 10) {
    log_diag("testing a random subset of the $module_list modules");
    @modules = random_sublist(@modules);
  }

  @modules;
}

sub random_sublist {
  my @modules = @_;
  my %sublist;
  return 1 if scalar(@modules) < 2;
  while (keys %sublist < 10) {
    my $m = $modules[int(rand(scalar @modules))];
    next unless $modules{$m}; # Don't random test uninstalled modules
    $sublist{$m} = 1;
  }
  return keys %sublist;
}

# for t/testm.sh -s
sub skip_modules {
  my @modules = get_module_list;
  my @skip = ();
  for my $m (@modules) {
    push @skip, ($m) unless $modules{$m};
  }
  @skip;
}

# preparing automatic module tests

package CPAN::Shell;
#{   # add testcc to the dispatching methods
#    no strict "refs";
#    my $command = 'testcc';
#    *$command = sub { shift->rematein($command, @_); };
#}
sub testcc { shift->rematein('testcc', @_); }
package CPAN::Module;
sub testcc   {
    my $self = shift;
    my $inst_file = $self->inst_file or return;
    # only if its a not-deprecated CPAN module. perl core not
    if ($self->can('_in_priv_or_arch')) { # 1.9301 not, 1.94 yes
      return if $self->_in_priv_or_arch($inst_file);
    }
    if ($] >= 5.011){
      if ($self->can('deprecated_in_core')) {
        return if $self->deprecated_in_core;
      } else {
        # CPAN-1.9402 has no such method anymore
        # trying to support deprecated.pm by Nicholas 2009-02
        if (my $distribution = $self->distribution) {
          return if $distribution->isa_perl;
        }
      }
    }
    $self->rematein('testcc', @_);
}
package CPAN::Distribution;
sub testcc   {
    my $self = shift;
    # $CPAN::DEBUG++;
    my $cwd = Cwd::getcwd();
    # posix shell only, but we are using a posix shell here. XXX -Wb=-uTest::Builder
    my $X = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
    $self->prefs->{test}->{commandline} =
      "for t in t/*.t; do "
	. "echo \"# \$t\"; $X -Iblib/arch -Iblib/lib -I\"$cwd/blib/arch\" -I\"$cwd/blib/lib\" \"$cwd/blib/script/perlcc\" -T -r \$t;"
     ."done";
    $self->prefs->{test_report} = ''; # XXX ignored!
    $self->{make_test} = 'NO'; # override YAML check "Has already been tested successfully"
    $self->test(@_);
    # done
}

1;