harness

#! 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 Getopt::Long qw(:config pass_through);
use Pod::Usage;

my $slash = $^O eq 'MSWin32' ? '\\' : '/';
$ENV{'HARNESS_PERL'} = ".${slash}perl6";
my $path_sep = $^O eq 'MSWin32' ? ';' : ':';
$ENV{'PERL6LIB'} = join $path_sep, qw/ lib . /;
use Test::Harness;
$Test::Harness::switches = '';

GetOptions(
    'tests-from-file=s' => \my $list_file,
    'fudge'             => \my $do_fudge,
    'verbosity=i'       => \$Test::Harness::verbose,
    'jobs:1'            => \my $jobs,
    'icu:1'             => \my $do_icu,
    'long:1'            => \my $do_long,
    'stress:1'          => \my $do_stress,
    'archive=s'         => \my $archive,
    'parrot_revision=s' => \my $parrot_revision,
    'jvm'               => \my $jvm,
    'help|h' => sub { pod2usage(1); },
) or pod2usage(2);

$do_long = 1 unless defined $do_long;
$do_stress = 0 unless defined $do_stress;

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

if ($list_file) {
    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/icu/)    && !$do_icu && !$jvm;
            next if ($fudgespec =~ m/long/)   && !$do_long;
            next if ($fudgespec =~ m/stress/) && !$do_stress;
        }
        $fn = "t/spec/$fn" unless $fn =~ m/^t\Q$slash\Espec\Q$slash\E/;
        $fn =~ s{/}{$slash}g;
        if ( -r $fn ) {
            push @files, $fn;
        } else {
            warn "Missing test file: $fn\n";
        }
    }
    close $f or die $!;
}

my @tfiles = map { all_in($_) } sort @files;

if ($do_fudge) {
    @tfiles = fudge(@tfiles);
}

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

my $extra_properties;
if ($archive) {
    $extra_properties->{'Parrot Revision'} = $parrot_revision
    if $parrot_revision;
    $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 || $ENV{TEST_JOBS} || 1,
        ignore_exit => 1,
        merge       => 1,
        $archive ? ( archive => $archive ) : (),
        $extra_properties ? ( extra_properties => $extra_properties ) : (),
    );
    $tap_harness_class->new( \%harness_options )->runtests(@tfiles);
}
elsif ($archive) {
    die "Can't load $tap_harness_class, which is needed for smolder submissions: $@";
}
else {
    runtests(@tfiles);
}

# 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 = $jvm ? 'rakudo.jvm' : 'rakudo.parrot';
    my $cmd  = join ' ', $^X, 't/spec/fudgeall',
                         @pass_through_options, $impl, @_;
    return split ' ', `$cmd`;
}

=head1 NAME

t/harness - run the harness tests for Rakudo.

=head1 SYNOPSIS

t/harness [options] [files]

Options:

    --help / -h - display the help message.
    --tests-from-file=[filename] - get the tests from the filename.
    --fudge - fudge (?)
    --verbosity=[level] - set the verbosity level.
    --jobs - number of jobs.
    --icu - do icu.
    --long - do long.
    --stress - perform the stress tests/
    --archive=[archive] - write to an archive.
    --parrot_revision=[rev] - test with Parrot revision.