Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tag: Amsterdam
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 122 lines (101 sloc) 3.233 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
#! 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);

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:3' => \my $jobs,
    'icu:1' => \my $do_icu,
    'archive=s' => \my $archive,
    'parrot_revision=s' => \my $parrot_revision,
);

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*/;
        next if ($fudgespec && ($fudgespec =~ m/icu/) && !$do_icu);
        $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 => ['./perl6'],
        verbosity => 0+$Test::Harness::verbose,
        jobs => $ENV{TEST_JOBS} || $jobs || 1,
        ignore_exit => 1,
        merge => 1,
        $archive ? ( archive => $archive ) : (),
        $extra_properties ? ( extra_properties => $extra_properties ) : (),
    );
    $tap_harness_class->new( \%harness_options )->runtests(@tfiles);
}
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`;
}
Something went wrong with that request. Please try again.