Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tag: 2012.04
Fetching contributors…

Cannot retrieve contributors at this time

file 156 lines (129 sloc) 4.255 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
#! 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";
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,
    '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;
            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 (eval "require $tap_harness_class;") {
    my %harness_options = (
        exec => [$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 = 'rakudo';
    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.
Something went wrong with that request. Please try again.