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