1#!./perl 2 3# We suppose that perl _mostly_ works at this moment, so may use 4# sophisticated testing. 5 6BEGIN { 7 chdir 't' if -d 't'; 8 @INC = '../lib'; # pick up only this build's lib 9} 10 11my $torture; # torture testing? 12 13use TAP::Harness 3.13; 14use strict; 15use Config; 16 17$::do_nothing = $::do_nothing = 1; 18require './TEST'; 19our $Valgrind_Log; 20 21my $Verbose = 0; 22$Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; 23 24# For valgrind summary output 25my $htoolnm; 26my $hgrind_ct; 27 28if ($ARGV[0] && $ARGV[0] eq '-torture') { 29 shift; 30 $torture = 1; 31} 32 33# Let tests know they're running in the perl core. Useful for modules 34# which live dual lives on CPAN. 35$ENV{PERL_CORE} = 1; 36 37my (@tests, @re, @anti_re); 38 39# [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV 40@ARGV = grep $_ && length( $_ ) => @ARGV; 41 42sub _extract_tests; 43sub _extract_tests { 44 # This can probably be done more tersely with a map, but I doubt that it 45 # would be as clear 46 my @results; 47 foreach (@_) { 48 my $ref = ref $_; 49 if ($ref) { 50 if ($ref eq 'ARRAY') { 51 push @results, _extract_tests @$_; 52 } elsif ($ref eq 'HASH') { 53 push @results, _extract_tests values %$_; 54 } else { 55 die "Unknown reference type $ref"; 56 } 57 } else { 58 push @results, glob $_; 59 } 60 } 61 @results; 62} 63 64while ($ARGV[0] && $ARGV[0]=~/^-(n?)re/) { 65 my $ary= $1 ? \@anti_re : \@re; 66 67 if ( $ARGV[0] !~ /=/ ) { 68 shift @ARGV; 69 while (@ARGV and $ARGV[0] !~ /^-/) { 70 push @$ary, shift @ARGV; 71 } 72 } else { 73 push @$ary, (split/=/,shift @ARGV)[1]; 74 } 75} 76 77my $jobs = $ENV{TEST_JOBS}; 78my ($rules, $state, $color); 79if ($ENV{HARNESS_OPTIONS}) { 80 for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) { 81 if ( $opt =~ /^j(\d*)$/ ) { 82 $jobs ||= $1 || 9; 83 } 84 elsif ( $opt eq 'c' ) { 85 $color = 1; 86 } 87 else { 88 die "Unknown HARNESS_OPTIONS item: $opt\n"; 89 } 90 } 91} 92 93if (@ARGV) { 94 # If you want these run in speed order, just use prove 95 if ($^O eq 'MSWin32') { 96 @tests = map(glob($_),@ARGV); 97 } 98 else { 99 @tests = @ARGV; 100 } 101 # This is a hack to force config_heavy.pl to be loaded, before the 102 # prep work for running a test changes directory. 103 1 if $Config{d_fork}; 104} else { 105 # Ideally we'd get somewhere close to Tux's Oslo rules 106 # my $rules = { 107 # par => [ 108 # { seq => '../ext/DB_File/t/*' }, 109 # { seq => '../ext/IO_Compress_Zlib/t/*' }, 110 # { seq => '../lib/ExtUtils/t/*' }, 111 # '*' 112 # ] 113 # }; 114 115 # but for now, run all directories in sequence. 116 117 unless (@tests) { 118 my @seq = <base/*.t>; 119 120 my @next = qw(comp run cmd io re opbasic op uni mro lib porting perf); 121 push @next, 'japh' if $torture; 122 push @next, 'win32' if $^O eq 'MSWin32'; 123 push @next, 'benchmark' if $ENV{PERL_BENCHMARK}; 124 push @next, 'bigmem' if $ENV{PERL_TEST_MEMORY}; 125 # Hopefully TAP::Parser::Scheduler will support this syntax soon. 126 # my $next = { par => '{' . join (',', @next) . '}/*.t' }; 127 my $next = { par => [ 128 map { "$_/*.t" } @next 129 ] }; 130 @tests = _extract_tests ($next); 131 132 # This is a bit of a game, because we only want to sort these tests in 133 # speed order. base/*.t wants to run first, and ext,lib etc last and in 134 # MANIFEST order 135 if ($jobs) { 136 require App::Prove::State; 137 $state = App::Prove::State->new({ store => 'test_state' }); 138 $state->apply_switch('slow', 'save'); 139 # For some reason get_tests returns *all* the tests previously run, 140 # (in the right order), not simply the selection in @tests 141 # (in the right order). Not sure if this is a bug or a feature. 142 # Whatever, *we* are only interested in the ones that are in @tests 143 my %seen; 144 @seen{@tests} = (); 145 @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests); 146 } 147 @tests = (@seq, @tests); 148 push @seq, $next; 149 150 my @last; 151 push @last, 152 _tests_from_manifest($Config{extensions}, $Config{known_extensions}); 153 my %times; 154 if ($state) { 155 # Where known, collate the elapsed times by test name 156 foreach ($state->results->tests()) { 157 $times{$_->name} = $_->elapsed(); 158 } 159 } 160 161 my %dir; 162 my %total_time; 163 164 for (@last) { 165 if ($^O eq 'MSWin32') { 166 s,\\,/,g; # canonicalize path 167 }; 168 # Treat every file matching lib/*.t as a "directory" 169 m! \A ( \.\. / (?: lib | ext/XS-APItest/t ) 170 / [^/]+ \.t \z | .* [/] ) !x 171 or die "'$_'"; 172 push @{$dir{$1}}, $_; 173 $total_time{$1} += $times{$_} || 0; 174 } 175 176 push @tests, @last; 177 178 # Generate T::H schedule rules that run the contents of each directory 179 # sequentially. 180 push @seq, { par => [ map { s!/$!/*!; { seq => $_ } } sort { 181 # Directories, ordered by total time descending then name ascending 182 $total_time{$b} <=> $total_time{$a} || lc $a cmp lc $b 183 } keys %dir ] }; 184 185 $rules = { seq => \@seq }; 186 } 187} 188if ($^O eq 'MSWin32') { 189 s,\\,/,g for @tests; 190} 191if (@re or @anti_re) { 192 my @keepers; 193 foreach my $test (@tests) { 194 my $keep = 0; 195 if (@re) { 196 foreach my $re (@re) { 197 $keep = 1 if $test=~/$re/; 198 } 199 } else { 200 $keep = 1; 201 } 202 if (@anti_re) { 203 foreach my $anti_re (@anti_re) { 204 $keep = 0 if $test=~/$anti_re/; 205 } 206 } 207 if ($keep) { 208 push @keepers, $test; 209 } 210 } 211 @tests= @keepers; 212} 213 214# Allow eg ./perl t/harness t/op/lc.t 215for (@tests) { 216 if (! -f $_ && !/^\.\./ && -f "../$_") { 217 $_ = "../$_"; 218 s{^\.\./t/}{}; 219 } 220} 221 222my %options; 223 224my $type = 'perl'; 225 226# Load TAP::Parser now as otherwise it could be required in the short time span 227# in which the harness process chdirs into ext/Dist 228require TAP::Parser; 229 230my $h = TAP::Harness->new({ 231 rules => $rules, 232 color => $color, 233 jobs => $jobs, 234 verbosity => $Verbose, 235 timer => $ENV{HARNESS_TIMER}, 236 exec => sub { 237 my ($harness, $test) = @_; 238 239 my $options = $options{$test}; 240 if (!defined $options) { 241 $options = $options{$test} = _scan_test($test, $type); 242 } 243 244 (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; 245 246 return [ split ' ', _cmd($options, $type) ]; 247 }, 248}); 249 250# Print valgrind output after test completes 251if ($ENV{PERL_VALGRIND}) { 252 $h->callback( 253 after_test => sub { 254 my ($job) = @_; 255 my $test = $job->[0]; 256 my $vfile = "$test.valgrind-current"; 257 $vfile =~ s/^.*\///; 258 259 if ( (! -z $vfile) && open(my $voutput, '<', $vfile)) { 260 print "$test: Valgrind output:\n"; 261 print "$test: $_" for <$voutput>; 262 close($voutput); 263 } 264 265 (local $Valgrind_Log = "$test.valgrind-current") =~ s/^.*\///; 266 267 _check_valgrind(\$htoolnm, \$hgrind_ct, \$test); 268 } 269 ); 270} 271 272if ($state) { 273 $h->callback( 274 after_test => sub { 275 $state->observe_test(@_); 276 } 277 ); 278 $h->callback( 279 after_runtests => sub { 280 $state->commit(@_); 281 } 282 ); 283} 284 285$h->callback( 286 parser_args => sub { 287 my ($args, $job) = @_; 288 my $test = $job->[0]; 289 _before_fork($options{$test}); 290 push @{ $args->{switches} }, "-I../../lib"; 291 } 292 ); 293 294$h->callback( 295 made_parser => sub { 296 my ($parser, $job) = @_; 297 my $test = $job->[0]; 298 my $options = delete $options{$test}; 299 _after_fork($options); 300 } 301 ); 302 303my $agg = $h->runtests(@tests); 304_cleanup_valgrind(\$htoolnm, \$hgrind_ct); 305exit $agg->has_errors ? 1 : 0; 306