This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't quote -T/-t in _scan_test()
[perl5.git] / t / harness
CommitLineData
a5f75d66
AD
1#!./perl
2
3# We suppose that perl _mostly_ works at this moment, so may use
4# sophisticated testing.
5
aa689395
PP
6BEGIN {
7 chdir 't' if -d 't';
122a0375 8 @INC = '../lib'; # pick up only this build's lib
aa689395 9}
c537bcda 10
e018f8be
JH
11my $torture; # torture testing?
12
abd39864 13use TAP::Harness 3.13;
9a4933c3 14use strict;
a5f75d66 15
c537bcda
NC
16$::do_nothing = $::do_nothing = 1;
17require './TEST';
18
abd39864
MS
19my $Verbose = 0;
20$Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift;
a5f75d66 21
12558422 22if ($ARGV[0] && $ARGV[0] eq '-torture') {
e018f8be
JH
23 shift;
24 $torture = 1;
25}
26
60e23f2f
MS
27# Let tests know they're running in the perl core. Useful for modules
28# which live dual lives on CPAN.
29$ENV{PERL_CORE} = 1;
30
0ca04487 31#fudge DATA for now.
9a4933c3 32my %datahandle = qw(
0ca04487
VB
33 lib/bigint.t 1
34 lib/bigintpm.t 1
35 lib/bigfloat.t 1
36 lib/bigfloatpm.t 1
37 op/gv.t 1
38 lib/complex.t 1
39 lib/ph.t 1
40 lib/soundex.t 1
41 op/misc.t 1
42 op/runlevel.t 1
43 op/tie.t 1
44 op/lex_assign.t 1
0ca04487
VB
45 );
46
47foreach (keys %datahandle) {
48 unlink "$_.t";
49}
50
0279961e 51my (@tests, $re);
122a0375 52
40996b78
AT
53# [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV
54@ARGV = grep $_ && length( $_ ) => @ARGV;
55
9ae5a6c3
NC
56sub _extract_tests;
57sub _extract_tests {
58 # This can probably be done more tersely with a map, but I doubt that it
59 # would be as clear
60 my @results;
61 foreach (@_) {
62 my $ref = ref $_;
63 if ($ref) {
64 if ($ref eq 'ARRAY') {
65 push @results, _extract_tests @$_;
66 } elsif ($ref eq 'HASH') {
67 push @results, _extract_tests values %$_;
68 } else {
69 die "Unknown reference type $ref";
70 }
71 } else {
0ae187c2 72 push @results, glob $_;
9ae5a6c3
NC
73 }
74 }
75 @results;
76}
77
12558422 78if ($ARGV[0] && $ARGV[0]=~/^-re/) {
8a76aa1f
YO
79 if ($ARGV[0]!~/=/) {
80 shift;
81 $re=join "|",@ARGV;
82 @ARGV=();
83 } else {
84 (undef,$re)=split/=/,shift;
85 }
86}
87
0279961e 88my $jobs = $ENV{TEST_JOBS};
abd39864 89my ($rules, $state, $color);
cd1b270f
B
90if ($ENV{HARNESS_OPTIONS}) {
91 for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) {
92 if ( $opt =~ /^j(\d*)$/ ) {
93 $jobs ||= $1 || 9;
94 }
cd1b270f 95 elsif ( $opt eq 'c' ) {
abd39864 96 $color = 1;
cd1b270f
B
97 }
98 else {
99 die "Unknown HARNESS_OPTIONS item: $opt\n";
100 }
101 }
102}
0279961e 103
7a315204 104if (@ARGV) {
0279961e 105 # If you want these run in speed order, just use prove
4efb34a6
NIS
106 if ($^O eq 'MSWin32') {
107 @tests = map(glob($_),@ARGV);
108 }
109 else {
110 @tests = @ARGV;
111 }
7a315204 112} else {
9ae5a6c3
NC
113 # Ideally we'd get somewhere close to Tux's Oslo rules
114 # my $rules = {
115 # par => [
116 # { seq => '../ext/DB_File/t/*' },
117 # { seq => '../ext/IO_Compress_Zlib/t/*' },
118 # { seq => '../lib/CPANPLUS/*' },
119 # { seq => '../lib/ExtUtils/t/*' },
120 # '*'
121 # ]
122 # };
123
124 # but for now, run all directories in sequence. In particular, it would be
125 # nice to get the tests in t/op/*.t able to run in parallel.
126
b695f709 127 unless (@tests) {
0279961e 128 my @seq = <base/*.t>;
9ae5a6c3 129
03d95bfa 130 my @next = qw(comp run cmd io op uni mro lib porting);
9ae5a6c3
NC
131 push @next, 'japh' if $torture;
132 push @next, 'win32' if $^O eq 'MSWin32';
7019aa11 133 push @next, 'benchmark' if $ENV{PERL_BENCHMARK};
0279961e
NC
134 # Hopefully TAP::Parser::Scheduler will support this syntax soon.
135 # my $next = { par => '{' . join (',', @next) . '}/*.t' };
136 my $next = { par => [
2f4cffa7 137 map { "$_/*.t" } @next
e6867818 138 ] };
0279961e
NC
139 @tests = _extract_tests ($next);
140
141 # This is a bit of a game, because we only want to sort these tests in
142 # speed order. base/*.t wants to run first, and ext,lib etc last and in
143 # MANIFEST order
144 if ($jobs) {
145 require App::Prove::State;
146 $state = App::Prove::State->new({ store => 'test_state' });
147 $state->apply_switch('slow', 'save');
148 # For some reason get_tests returns *all* the tests previously run,
149 # (in the right order), not simply the selection in @tests
150 # (in the right order). Not sure if this is a bug or a feature.
151 # Whatever, *we* are only interested in the ones that are in @tests
152 my %seen;
153 @seen{@tests} = ();
154 @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests);
155 }
156 @tests = (@seq, @tests);
157 push @seq, $next;
9ae5a6c3
NC
158
159 my @last;
6234cb77 160 use Config;
a3323f52
NC
161 push @last, sort { lc $a cmp lc $b }
162 _tests_from_manifest($Config{extensions}, $Config{known_extensions});
9ae5a6c3
NC
163 push @last, <pod/*.t>;
164 push @last, <x2p/*.t>;
165
226de479
NC
166 my %times;
167 if ($state) {
168 # Where known, collate the elapsed times by test name
169 foreach ($state->results->tests()) {
170 $times{$_->name} = $_->elapsed();
171 }
172 }
173
174 my %dir;
175 my %total_time;
176
177 for (@last) {
133fac12
MM
178 if ($^O eq 'MSWin32') {
179 s,\\,/,g; # canonicalize path
180 };
181 m!(.*[/])! or die "'$_'";
226de479
NC
182 push @{$dir{$1}}, $_;
183 $total_time{$1} += $times{$_} || 0;
184 }
185
0279961e 186 push @tests, @last;
9ae5a6c3 187
fc279e46
NC
188 # Generate T::H schedule rules that run the contents of each directory
189 # sequentially.
226de479
NC
190 push @seq, { par => [ map { { seq => "$_*" } } sort {
191 # Directories, ordered by total time descending then name ascending
192 $total_time{$b} <=> $total_time{$a} || $a cmp $b
193 } keys %dir ] };
9ae5a6c3
NC
194
195 $rules = { seq => \@seq };
7a315204
JH
196 }
197}
22a65f1e
GS
198if ($^O eq 'MSWin32') {
199 s,\\,/,g for @tests;
200}
8a76aa1f
YO
201@tests=grep /$re/, @tests
202 if $re;
9ae5a6c3 203
abd39864
MS
204my $h = TAP::Harness->new({
205 rules => $rules,
206 color => $color,
207 jobs => $jobs,
208 verbosity => $Verbose,
744c27e5 209 exec => \&_run_test,
abd39864 210});
a0f20b65
NC
211
212if ($state) {
e8fb11d7 213 $h->callback(
a0f20b65
NC
214 after_test => sub {
215 $state->observe_test(@_);
e8fb11d7 216 }
a0f20b65
NC
217 );
218 $h->callback(
219 after_runtests => sub {
220 $state->commit(@_);
221 }
222 );
9ae5a6c3 223}
a0f20b65
NC
224
225$h->callback(
226 parser_args => sub {
227 my ( $args, $test ) = @_;
228 push @{ $args->{switches} }, '-I../lib';
229 }
230 );
abd39864 231$h->runtests(@tests);
de125441 232exit(0);