harness5.pl

#!/usr/bin/env perl

# note: Due to a limitation in Getopt::Long options that should be passed
# through to fudgeall have to come after all other options

use strict;
use warnings;

use FindBin;
use File::Spec;
use List::Util qw(shuffle);
use Getopt::Long qw(:config pass_through);
use Pod::Usage;

use Test::Harness;
$Test::Harness::switches = '';

use constant FULL_ROAST_TEST_LIST_FILE => 't/spectest.data';
use constant ROAST_VERSION_FILE        => 't/spec/VERSION';
my $win   = $^O eq 'MSWin32';
my $slash = $win ? '\\' : '/';

GetOptions(
    'tests-from-file=s' => \my $list_file,
    'fudge'             => \my $do_fudge,
    'verbosity=i'       => \$Test::Harness::verbose,
    'jobs:1'            => \(my $jobs = $ENV{TEST_JOBS} || 6),
    'quick:1'           => \my $do_quick,
    'stress:1'          => \my $do_stress,
    'archive=s'         => \my $archive,
    'jvm'               => \my $jvm,
    'moar'              => \my $moar,
    'randomize'         => \my $randomize,
    'slow'              => \(my $slow = !$win),
    'no-merge'             => \my $no_merge,
    'help|h' => sub { pod2usage(1); },
) or pod2usage(2);

my @pass_through_options = grep m/^--?[^-]/, @ARGV;
my @files = grep m/^[^-]/, @ARGV;

$ENV{'HARNESS_PERL'} = ".${slash}perl6-" . ($moar ? "m" : $jvm ? "j" : "m");
$ENV{'PERL6LIB'} = "lib";

my @slow;
if ($list_file) {
    $list_file = convert_to_versioned_file($list_file);

    my $perl5 = not system $ENV{HARNESS_PERL} . ' -e "exit !try { require Inline::Perl5; 1 }"';
    print "Inline::Perl5 not installed: not running Perl 5 integration tests\n"
      if !$perl5;

    open(my $f, '<', $list_file)
        or die "Can't open file '$list_file' for reading: $!";
    while (<$f>) {
        next if m/^\s*#/;
        next unless m/\S/;
        s/^\s+//;
        s/\s+\z//;
        my ($fn, $fudgespec) = split /\s+#\s*/;
        if ($fudgespec) {
            next if ($fudgespec =~ m/perl5/)  && !$perl5;
            next if ($fudgespec =~ m/long/)   && $do_quick;
            next if ($fudgespec =~ m/stress/) && !$do_stress;
            next if ($fudgespec =~ m/jvm/)    && !$jvm;
            next if ($fudgespec =~ m/moar/)   && !$moar;
            next if ($fudgespec =~ m/conc/)   && !($moar || $jvm);
        }

        $fn = "t/spec/$fn" unless $fn =~ m/^t\Q$slash\Espec\Q$slash\E/;
        $fn =~ s{/}{$slash}g;
        if ( -r $fn ) {
            $slow && $fudgespec && $fudgespec =~ m/slow/
              ? push @slow, $fn
              : push @files, $fn;
        } else {
            warn "Missing test file: $fn\n";
        }
    }
    close $f or die $!;
}

my @tfiles = $randomize
  ? shuffle map { all_in($_) } @files
  : map { all_in($_) } sort @files;
if (@slow) {
    @slow = map { all_in($_) } @slow;

    if ($jobs > 1) {
        @tfiles = batch( @tfiles/(@slow + 1), @tfiles );
        @tfiles = map { (@slow ? shift(@slow) : ()), @$_ } @tfiles;
    }
    else {
        unshift @tfiles, map { all_in($_) } @slow;
    }
}

if ($do_fudge) {
    @tfiles = map { fudge(@$_) } batch( 200, @tfiles );
}

my $tap_harness_class = 'TAP::Harness';
$tap_harness_class .= '::Archive' if $archive;

my $extra_properties;
if ($archive) {
    $extra_properties->{'Submitter'} = $ENV{SMOLDER_SUBMITTER}
    if $ENV{SMOLDER_SUBMITTER};
}

if ($jvm) {
    unlink("TESTTOKEN");
    $ENV{HARNESS_PERL} = "$^X .${slash}eval-client.pl TESTTOKEN run";

    no warnings 'once';
    # leak the filehandle; it will be closed at exit, robustly telling the server to terminate
    open JVMSERVER, "| .${slash}perl6-eval-server -bind-stdin -cookie TESTTOKEN -app .${slash}perl6.jar" or die "cannot fork eval server: $!\n";
    sleep 1;
}

if (eval "require $tap_harness_class;") {
    my %harness_options = (
        exec        => $jvm ? [$^X, "./eval-client.pl", "TESTTOKEN", "run"] : [$ENV{HARNESS_PERL}],
        verbosity   => 0+$Test::Harness::verbose,
        jobs        => $jobs,
        ignore_exit => 1,
        merge       => ($no_merge ? 0 : 1),
        $TAP::Harness::VERSION gt 3.21 ? (trap => 1) : (),
        $archive ? ( archive => $archive ) : (),
        $extra_properties ? ( extra_properties => $extra_properties ) : (),
    );
    my $results = $tap_harness_class->new( \%harness_options )->runtests(@tfiles);
    exit 1 if $results->has_errors;
}
elsif ($archive) {
    die "Can't load $tap_harness_class, which is needed for smolder submissions: $@";
}
else {
    runtests(@tfiles);
}

sub batch {
    my $size = shift;
    my @batches;
    while (@_) {
        my @batch = splice @_, 0, $size;
        push @batches, \@batch;
    }
    @batches
}

# adapted to return only files ending in '.t'
sub all_in {
    my $start = shift;

    return $start unless -d $start;

    my @skip = ( File::Spec->updir, File::Spec->curdir, qw( .svn CVS .git ) );
    my %skip = map {($_,1)} @skip;

    my @hits = ();

    if ( opendir( my $dh, $start ) ) {
        my @files = sort readdir $dh;
        closedir $dh or die $!;
        for my $file ( @files ) {
            next if $skip{$file};

            my $currfile = File::Spec->catfile( $start, $file );
            if ( -d $currfile ) {
                push( @hits, all_in( $currfile ) );
            } else {
                push( @hits, $currfile ) if $currfile =~ /\.t$/;
            }
        }
    } else {
        warn "$start: $!\n";
    }

    return @hits;
}

sub fudge {
    my $impl = $moar ? 'rakudo.moar' : 'rakudo.jvm';
    my $cmd  = join ' ', $^X, 't/spec/fudgeall',
                         @pass_through_options, $impl, @_;
    return split ' ', `$cmd`;
}

sub warn_in_box {
    warn +('#' x 76) . "\n\n" . shift . "\n\n" . ('#' x 76) . "\n";
}

sub convert_to_versioned_file {
    my $file = shift;
    return $file unless $file eq FULL_ROAST_TEST_LIST_FILE;

    open my $fh, '<', ROAST_VERSION_FILE or do {
        warn_in_box "Failed to open roast VERSION file in "
            . ROAST_VERSION_FILE . ": $!\n"
            . "Defaulting to test files from $file";
        return $file;
    };
    (my $ver = (grep !/^\s*#/ && /\S/, <$fh>)[0]) =~ s/^\s+|\s+$//g;

    # Make a new test file name using the version of the roast. The master
    # branch would have version something like `6.d-proposals`; in such
    # a case, we'll use the default test file list
    my $new_file = $ver =~ /propos/i ? $file : "$file.$ver";
    if (-r $new_file) {
        print "Testing Roast version $ver using test file list from $new_file\n";
        return $new_file;
    }

    warn_in_box "Test list file `$new_file` for Roast version $ver does not exist\n"
        . "or isn't readable. Defaulting to $file";
    return $file;
}