| 1 | #!./perl |
| 2 | |
| 3 | # We suppose that perl _mostly_ works at this moment, so may use |
| 4 | # sophisticated testing. |
| 5 | |
| 6 | BEGIN { |
| 7 | chdir 't' if -d 't'; |
| 8 | @INC = '../lib'; # pick up only this build's lib |
| 9 | } |
| 10 | delete $ENV{PERL5LIB}; |
| 11 | |
| 12 | my $torture; # torture testing? |
| 13 | |
| 14 | use Test::Harness; |
| 15 | use strict; |
| 16 | |
| 17 | $Test::Harness::switches = ""; # Too much noise otherwise |
| 18 | $Test::Harness::Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; |
| 19 | |
| 20 | if ($ARGV[0] && $ARGV[0] eq '-torture') { |
| 21 | shift; |
| 22 | $torture = 1; |
| 23 | } |
| 24 | |
| 25 | # Let tests know they're running in the perl core. Useful for modules |
| 26 | # which live dual lives on CPAN. |
| 27 | $ENV{PERL_CORE} = 1; |
| 28 | |
| 29 | #fudge DATA for now. |
| 30 | my %datahandle = qw( |
| 31 | lib/bigint.t 1 |
| 32 | lib/bigintpm.t 1 |
| 33 | lib/bigfloat.t 1 |
| 34 | lib/bigfloatpm.t 1 |
| 35 | op/gv.t 1 |
| 36 | lib/complex.t 1 |
| 37 | lib/ph.t 1 |
| 38 | lib/soundex.t 1 |
| 39 | op/misc.t 1 |
| 40 | op/runlevel.t 1 |
| 41 | op/tie.t 1 |
| 42 | op/lex_assign.t 1 |
| 43 | ); |
| 44 | |
| 45 | foreach (keys %datahandle) { |
| 46 | unlink "$_.t"; |
| 47 | } |
| 48 | |
| 49 | my (@tests, $re); |
| 50 | |
| 51 | # [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV |
| 52 | @ARGV = grep $_ && length( $_ ) => @ARGV; |
| 53 | |
| 54 | sub _populate_hash { |
| 55 | return map {$_, 1} split /\s+/, $_[0]; |
| 56 | } |
| 57 | |
| 58 | # Generate T::H schedule rules that run the contents of each directory |
| 59 | # sequentially. |
| 60 | sub _seq_dir_rules { |
| 61 | my @tests = @_; |
| 62 | my %dir; |
| 63 | for (@tests) { |
| 64 | s{[^/]+$}{\*}; |
| 65 | $dir{$_}++; |
| 66 | } |
| 67 | |
| 68 | return { par => [ map { { seq => $_ } } sort keys %dir ] }; |
| 69 | } |
| 70 | |
| 71 | sub _extract_tests; |
| 72 | sub _extract_tests { |
| 73 | # This can probably be done more tersely with a map, but I doubt that it |
| 74 | # would be as clear |
| 75 | my @results; |
| 76 | foreach (@_) { |
| 77 | my $ref = ref $_; |
| 78 | if ($ref) { |
| 79 | if ($ref eq 'ARRAY') { |
| 80 | push @results, _extract_tests @$_; |
| 81 | } elsif ($ref eq 'HASH') { |
| 82 | push @results, _extract_tests values %$_; |
| 83 | } else { |
| 84 | die "Unknown reference type $ref"; |
| 85 | } |
| 86 | } else { |
| 87 | push @results, glob $_; |
| 88 | } |
| 89 | } |
| 90 | @results; |
| 91 | } |
| 92 | |
| 93 | if ($ARGV[0] && $ARGV[0]=~/^-re/) { |
| 94 | if ($ARGV[0]!~/=/) { |
| 95 | shift; |
| 96 | $re=join "|",@ARGV; |
| 97 | @ARGV=(); |
| 98 | } else { |
| 99 | (undef,$re)=split/=/,shift; |
| 100 | } |
| 101 | } |
| 102 | |
| 103 | my $jobs = $ENV{TEST_JOBS}; |
| 104 | my ($fork, $rules, $state); |
| 105 | if ($ENV{HARNESS_OPTIONS}) { |
| 106 | for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) { |
| 107 | if ( $opt =~ /^j(\d*)$/ ) { |
| 108 | $jobs ||= $1 || 9; |
| 109 | } |
| 110 | elsif ( $opt eq 'f' ) { |
| 111 | $fork = 1; |
| 112 | } |
| 113 | elsif ( $opt eq 'c' ) { |
| 114 | # $args->{color} = 1; |
| 115 | } |
| 116 | else { |
| 117 | die "Unknown HARNESS_OPTIONS item: $opt\n"; |
| 118 | } |
| 119 | } |
| 120 | } |
| 121 | |
| 122 | if (@ARGV) { |
| 123 | # If you want these run in speed order, just use prove |
| 124 | if ($^O eq 'MSWin32') { |
| 125 | @tests = map(glob($_),@ARGV); |
| 126 | } |
| 127 | else { |
| 128 | @tests = @ARGV; |
| 129 | } |
| 130 | } else { |
| 131 | # Ideally we'd get somewhere close to Tux's Oslo rules |
| 132 | # my $rules = { |
| 133 | # par => [ |
| 134 | # { seq => '../ext/DB_File/t/*' }, |
| 135 | # { seq => '../ext/IO_Compress_Zlib/t/*' }, |
| 136 | # { seq => '../lib/CPANPLUS/*' }, |
| 137 | # { seq => '../lib/ExtUtils/t/*' }, |
| 138 | # '*' |
| 139 | # ] |
| 140 | # }; |
| 141 | |
| 142 | # but for now, run all directories in sequence. In particular, it would be |
| 143 | # nice to get the tests in t/op/*.t able to run in parallel. |
| 144 | |
| 145 | unless (@tests) { |
| 146 | my @seq = <base/*.t>; |
| 147 | |
| 148 | my @next = qw(comp cmd run io op uni mro lib); |
| 149 | push @next, 'japh' if $torture; |
| 150 | push @next, 'win32' if $^O eq 'MSWin32'; |
| 151 | push @next, 'benchmark' if $ENV{PERL_BENCHMARK}; |
| 152 | # Hopefully TAP::Parser::Scheduler will support this syntax soon. |
| 153 | # my $next = { par => '{' . join (',', @next) . '}/*.t' }; |
| 154 | my $next = { par => [ |
| 155 | map { "$_/*.t" } @next |
| 156 | ] }; |
| 157 | @tests = _extract_tests ($next); |
| 158 | |
| 159 | # This is a bit of a game, because we only want to sort these tests in |
| 160 | # speed order. base/*.t wants to run first, and ext,lib etc last and in |
| 161 | # MANIFEST order |
| 162 | if ($jobs) { |
| 163 | require App::Prove::State; |
| 164 | $state = App::Prove::State->new({ store => 'test_state' }); |
| 165 | $state->apply_switch('slow', 'save'); |
| 166 | # For some reason get_tests returns *all* the tests previously run, |
| 167 | # (in the right order), not simply the selection in @tests |
| 168 | # (in the right order). Not sure if this is a bug or a feature. |
| 169 | # Whatever, *we* are only interested in the ones that are in @tests |
| 170 | my %seen; |
| 171 | @seen{@tests} = (); |
| 172 | @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests); |
| 173 | } |
| 174 | @tests = (@seq, @tests); |
| 175 | push @seq, $next; |
| 176 | |
| 177 | my @last; |
| 178 | use Config; |
| 179 | my %skip; |
| 180 | { |
| 181 | my %extensions = _populate_hash $Config{'extensions'}; |
| 182 | my %known_extensions = _populate_hash $Config{'known_extensions'}; |
| 183 | foreach (keys %known_extensions) { |
| 184 | $skip{$_}++ unless $extensions{$_}; |
| 185 | } |
| 186 | } |
| 187 | use File::Spec; |
| 188 | my $updir = File::Spec->updir; |
| 189 | my $mani = File::Spec->catfile(File::Spec->updir, "MANIFEST"); |
| 190 | if (open(MANI, $mani)) { |
| 191 | my @manitests = (); |
| 192 | while (<MANI>) { # similar code in t/TEST |
| 193 | if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { |
| 194 | my ($test, $extension) = ($1, $2); |
| 195 | if (defined $extension) { |
| 196 | $extension =~ s!/t$!!; |
| 197 | # XXX Do I want to warn that I'm skipping these? |
| 198 | next if $skip{$extension}; |
| 199 | my $flat_extension = $extension; |
| 200 | $flat_extension =~ s!-!/!g; |
| 201 | next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar |
| 202 | } |
| 203 | push @manitests, File::Spec->catfile($updir, $test); |
| 204 | } |
| 205 | } |
| 206 | close MANI; |
| 207 | # Sort the list of test files read from MANIFEST into a sensible |
| 208 | # order instead of using the order in which they are listed there |
| 209 | push @last, sort { lc $a cmp lc $b } @manitests; |
| 210 | } else { |
| 211 | warn "$0: cannot open $mani: $!\n"; |
| 212 | } |
| 213 | push @last, <pod/*.t>; |
| 214 | push @last, <x2p/*.t>; |
| 215 | |
| 216 | push @tests, @last; |
| 217 | |
| 218 | push @seq, _seq_dir_rules @last; |
| 219 | |
| 220 | $rules = { seq => \@seq }; |
| 221 | } |
| 222 | } |
| 223 | if ($^O eq 'MSWin32') { |
| 224 | s,\\,/,g for @tests; |
| 225 | } |
| 226 | @tests=grep /$re/, @tests |
| 227 | if $re; |
| 228 | |
| 229 | if ($jobs) { |
| 230 | eval 'use TAP::Harness 3.13; 1' or die $@; |
| 231 | |
| 232 | # Test::Harness parses $ENV{HARNESS_OPTIONS}, TAP::Harness does not |
| 233 | local $ENV{HARNESS_OPTIONS}; |
| 234 | my $h = TAP::Harness->new({ jobs => $jobs, rules => $rules, ($fork ? (fork => $fork) : ())}); |
| 235 | if ($state) { |
| 236 | $h->callback( |
| 237 | after_test => sub { |
| 238 | $state->observe_test(@_); |
| 239 | } |
| 240 | ); |
| 241 | $h->callback( |
| 242 | after_runtests => sub { |
| 243 | $state->commit(@_); |
| 244 | } |
| 245 | ); |
| 246 | } |
| 247 | $h->callback( |
| 248 | parser_args => sub { |
| 249 | my ( $args, $test ) = @_; |
| 250 | push @{ $args->{switches} }, '-I../lib'; |
| 251 | } |
| 252 | ); |
| 253 | $h->runtests(@tests); |
| 254 | } else { |
| 255 | Test::Harness::runtests @tests; |
| 256 | } |
| 257 | exit(0); |