Skip to content
This repository
tree: bc68e57b5e
Fetching contributors…

Cannot retrieve contributors at this time

file 154 lines (128 sloc) 4.082 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
#! perl
# Copyright (C) 2008 - 2011, The Perl Foundation.
# this script was developed for Rakudo, and later adapted for Niecza

=head1 DESCRIPTION

This tool runs all spectests, except those that C<make spectest> runs (that
means all tests of which we don't know yet if they will pass or not).

For each file that passes at least one test (criterion might change in future)
it prints out a short summary about the status of this file.

This is primarily used to identify tests that could be added to
F<t/spectest.data>, and those that are worth a closer look. But
please don't add them blindly just because they all pass - chances are that
there's a good reason for them not already being included.

This script should be called from the main Niecza directory.

=cut

use strict;
use warnings;
use TAP::Harness;
use TAP::Parser::Aggregator 3.01;

use File::Find;
use Data::Dumper;

my %not_process = map { $_ => 1 } read_specfile('t/spectest.data');

print <<'KEY';
Key:
[S ] = some tests passed
[ P ] = plan ok (ran all tests)
[ A] = all passed
( passed / planned or ran )
==================================
KEY

my @wanted;

$ENV{PUGS_USE_EXTERNAL_TEST}=1;
if ($^O eq 'darwin') {
    $ENV{LC_ALL}="en_US.ISO8859-1";
}
else {
    $ENV{LC_ALL}="en_US.ISO-8859-1";
}

find({ wanted => \&queue, no_chdir => 1 }, 't/spec/');

sub queue {
    return if -d $_;
    return if m/\.sv[nk]/;
    return unless m/\.t$/;
    return if $not_process{$_};

    push @wanted, $_;
}

if ( ! defined $ENV{TEST_JOBS} || int $ENV{TEST_JOBS} <= 1 ) {
    go( $_ ) for @wanted;
}
else {
    my $jobs_wanted = int $ENV{TEST_JOBS};
    my %running;

    while( @wanted || %running ) {
        if ( @wanted && $jobs_wanted > keys %running ) {
            my $file = shift @wanted;
            my $pid = fork;
            if ( $pid ) { # parent
                $running{ $pid } = $file;
            }
            elsif ( defined $pid ) { # child
                go( $file );
                exit;
            }
            else {
                die "Cannot fork: $!";
            }
        }
        else {
            my $pid = wait;
            if ( ! defined delete $running{ $pid } ) {
                die "reaped unknown child PID '$pid'";
            }
        }
    }
}

sub go {
    my $orig = shift @_;

    my $fudged = qx{t/spec/fudge --keep-exit-code pugs $orig};
    chomp $fudged;

    open my $x, "<", $orig;
    my $fileplan = "?";
    while (my $line = <$x>){
        if ($line =~ /^plan (\d+);/) {
           $fileplan = $1;
        }
    }

    my $H = get_harness();
    my $agg = TAP::Parser::Aggregator->new();
    $agg->start();
    $H->aggregate_tests($agg, $fudged);
    $agg->stop();

    # "older" version (prior to 3.16, which isn't released at the time
    # of writing) don't have a planned() method, so fall back on
    # total() instead
    my $planned = eval { $agg->cplanned };
    $planned = $agg->total unless defined $planned;

    my ($some_passed, $plan_ok, $all_passed) = (' ', ' ', ' ');
    my $actually_passed = $agg->passed - $agg->skipped - $agg->todo;
    $some_passed = 'S' if $actually_passed;
    $plan_ok = 'P' if !scalar($agg->parse_errors);
    $all_passed = 'A' if ! $agg->has_errors;
    printf "[%s%s%s] (% 3d/%-3d/%-3s) %s\n", $some_passed, $plan_ok, $all_passed,
           $actually_passed, $planned, $fileplan, $orig;
                #if $actually_passed || ($plan_ok && $planned > 0);
}

sub read_specfile {
    my $fn = shift;
    my @res;
    open (my $f, '<', $fn) or die "Cannot open file '$fn' for reading: $!";
    while (<$f>){
        s/\s*\#.*//; # strip out comments and any spaces before them
        m/(\S+)/ && push @res, "t/spec/$1";
    }
    close $f or die $!;
    return @res;
}

sub get_harness {
    return TAP::Harness->new({
            verbosity => -2,
            exec => ["./tools/perl6-limited.pl"],
            merge => 1,
    });
}

# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
Something went wrong with that request. Please try again.