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