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 | |
a3323f52 |
106 | sub _tests_from_manifest { |
107 | my ($extensions, $known_extensions) = @_; |
108 | my %skip; |
109 | my %extensions = _populate_hash($extensions); |
110 | my %known_extensions = _populate_hash($known_extensions); |
111 | |
112 | foreach (keys %known_extensions) { |
113 | $skip{$_}++ unless $extensions{$_}; |
114 | } |
115 | |
116 | my @results; |
117 | use File::Spec; |
118 | my $updir = File::Spec->updir; |
119 | my $mani = File::Spec->catfile(File::Spec->updir, "MANIFEST"); |
120 | if (open(MANI, $mani)) { |
121 | while (<MANI>) { # similar code in t/TEST |
122 | if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { |
123 | my ($test, $extension) = ($1, $2); |
124 | if (defined $extension) { |
125 | $extension =~ s!/t$!!; |
126 | # XXX Do I want to warn that I'm skipping these? |
127 | next if $skip{$extension}; |
128 | my $flat_extension = $extension; |
129 | $flat_extension =~ s!-!/!g; |
130 | next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar |
131 | } |
132 | push @results, File::Spec->catfile($updir, $test); |
133 | } |
134 | } |
135 | close MANI; |
136 | } else { |
137 | warn "$0: cannot open $mani: $!\n"; |
138 | } |
139 | return @results; |
140 | } |
141 | |
7a315204 |
142 | if (@ARGV) { |
0279961e |
143 | # If you want these run in speed order, just use prove |
4efb34a6 |
144 | if ($^O eq 'MSWin32') { |
145 | @tests = map(glob($_),@ARGV); |
146 | } |
147 | else { |
148 | @tests = @ARGV; |
149 | } |
7a315204 |
150 | } else { |
9ae5a6c3 |
151 | # Ideally we'd get somewhere close to Tux's Oslo rules |
152 | # my $rules = { |
153 | # par => [ |
154 | # { seq => '../ext/DB_File/t/*' }, |
155 | # { seq => '../ext/IO_Compress_Zlib/t/*' }, |
156 | # { seq => '../lib/CPANPLUS/*' }, |
157 | # { seq => '../lib/ExtUtils/t/*' }, |
158 | # '*' |
159 | # ] |
160 | # }; |
161 | |
162 | # but for now, run all directories in sequence. In particular, it would be |
163 | # nice to get the tests in t/op/*.t able to run in parallel. |
164 | |
b695f709 |
165 | unless (@tests) { |
0279961e |
166 | my @seq = <base/*.t>; |
9ae5a6c3 |
167 | |
03d95bfa |
168 | my @next = qw(comp run cmd io op uni mro lib porting); |
9ae5a6c3 |
169 | push @next, 'japh' if $torture; |
170 | push @next, 'win32' if $^O eq 'MSWin32'; |
7019aa11 |
171 | push @next, 'benchmark' if $ENV{PERL_BENCHMARK}; |
0279961e |
172 | # Hopefully TAP::Parser::Scheduler will support this syntax soon. |
173 | # my $next = { par => '{' . join (',', @next) . '}/*.t' }; |
174 | my $next = { par => [ |
2f4cffa7 |
175 | map { "$_/*.t" } @next |
e6867818 |
176 | ] }; |
0279961e |
177 | @tests = _extract_tests ($next); |
178 | |
179 | # This is a bit of a game, because we only want to sort these tests in |
180 | # speed order. base/*.t wants to run first, and ext,lib etc last and in |
181 | # MANIFEST order |
182 | if ($jobs) { |
183 | require App::Prove::State; |
184 | $state = App::Prove::State->new({ store => 'test_state' }); |
185 | $state->apply_switch('slow', 'save'); |
186 | # For some reason get_tests returns *all* the tests previously run, |
187 | # (in the right order), not simply the selection in @tests |
188 | # (in the right order). Not sure if this is a bug or a feature. |
189 | # Whatever, *we* are only interested in the ones that are in @tests |
190 | my %seen; |
191 | @seen{@tests} = (); |
192 | @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests); |
193 | } |
194 | @tests = (@seq, @tests); |
195 | push @seq, $next; |
9ae5a6c3 |
196 | |
197 | my @last; |
6234cb77 |
198 | use Config; |
a3323f52 |
199 | push @last, sort { lc $a cmp lc $b } |
200 | _tests_from_manifest($Config{extensions}, $Config{known_extensions}); |
9ae5a6c3 |
201 | push @last, <pod/*.t>; |
202 | push @last, <x2p/*.t>; |
203 | |
226de479 |
204 | my %times; |
205 | if ($state) { |
206 | # Where known, collate the elapsed times by test name |
207 | foreach ($state->results->tests()) { |
208 | $times{$_->name} = $_->elapsed(); |
209 | } |
210 | } |
211 | |
212 | my %dir; |
213 | my %total_time; |
214 | |
215 | for (@last) { |
133fac12 |
216 | if ($^O eq 'MSWin32') { |
217 | s,\\,/,g; # canonicalize path |
218 | }; |
219 | m!(.*[/])! or die "'$_'"; |
226de479 |
220 | push @{$dir{$1}}, $_; |
221 | $total_time{$1} += $times{$_} || 0; |
222 | } |
223 | |
0279961e |
224 | push @tests, @last; |
9ae5a6c3 |
225 | |
fc279e46 |
226 | # Generate T::H schedule rules that run the contents of each directory |
227 | # sequentially. |
226de479 |
228 | push @seq, { par => [ map { { seq => "$_*" } } sort { |
229 | # Directories, ordered by total time descending then name ascending |
230 | $total_time{$b} <=> $total_time{$a} || $a cmp $b |
231 | } keys %dir ] }; |
9ae5a6c3 |
232 | |
233 | $rules = { seq => \@seq }; |
7a315204 |
234 | } |
235 | } |
22a65f1e |
236 | if ($^O eq 'MSWin32') { |
237 | s,\\,/,g for @tests; |
238 | } |
8a76aa1f |
239 | @tests=grep /$re/, @tests |
240 | if $re; |
9ae5a6c3 |
241 | |
abd39864 |
242 | my $h = TAP::Harness->new({ |
243 | rules => $rules, |
244 | color => $color, |
245 | jobs => $jobs, |
246 | verbosity => $Verbose, |
247 | }); |
a0f20b65 |
248 | |
249 | if ($state) { |
e8fb11d7 |
250 | $h->callback( |
a0f20b65 |
251 | after_test => sub { |
252 | $state->observe_test(@_); |
e8fb11d7 |
253 | } |
a0f20b65 |
254 | ); |
255 | $h->callback( |
256 | after_runtests => sub { |
257 | $state->commit(@_); |
258 | } |
259 | ); |
9ae5a6c3 |
260 | } |
a0f20b65 |
261 | |
262 | $h->callback( |
263 | parser_args => sub { |
264 | my ( $args, $test ) = @_; |
265 | push @{ $args->{switches} }, '-I../lib'; |
266 | } |
267 | ); |
abd39864 |
268 | $h->runtests(@tests); |
de125441 |
269 | exit(0); |