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 | } |
c537bcda |
10 | |
e8fb11d7 |
11 | delete $ENV{PERL5LIB}; |
aa689395 |
12 | |
e018f8be |
13 | my $torture; # torture testing? |
14 | |
abd39864 |
15 | use TAP::Harness 3.13; |
9a4933c3 |
16 | use strict; |
a5f75d66 |
17 | |
c537bcda |
18 | $::do_nothing = $::do_nothing = 1; |
19 | require './TEST'; |
20 | |
abd39864 |
21 | my $Verbose = 0; |
22 | $Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; |
a5f75d66 |
23 | |
12558422 |
24 | if ($ARGV[0] && $ARGV[0] eq '-torture') { |
e018f8be |
25 | shift; |
26 | $torture = 1; |
27 | } |
28 | |
60e23f2f |
29 | # Let tests know they're running in the perl core. Useful for modules |
30 | # which live dual lives on CPAN. |
31 | $ENV{PERL_CORE} = 1; |
32 | |
0ca04487 |
33 | #fudge DATA for now. |
9a4933c3 |
34 | my %datahandle = qw( |
0ca04487 |
35 | lib/bigint.t 1 |
36 | lib/bigintpm.t 1 |
37 | lib/bigfloat.t 1 |
38 | lib/bigfloatpm.t 1 |
39 | op/gv.t 1 |
40 | lib/complex.t 1 |
41 | lib/ph.t 1 |
42 | lib/soundex.t 1 |
43 | op/misc.t 1 |
44 | op/runlevel.t 1 |
45 | op/tie.t 1 |
46 | op/lex_assign.t 1 |
0ca04487 |
47 | ); |
48 | |
49 | foreach (keys %datahandle) { |
50 | unlink "$_.t"; |
51 | } |
52 | |
0279961e |
53 | my (@tests, $re); |
122a0375 |
54 | |
40996b78 |
55 | # [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV |
56 | @ARGV = grep $_ && length( $_ ) => @ARGV; |
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; |
a3323f52 |
163 | push @last, sort { lc $a cmp lc $b } |
164 | _tests_from_manifest($Config{extensions}, $Config{known_extensions}); |
9ae5a6c3 |
165 | push @last, <pod/*.t>; |
166 | push @last, <x2p/*.t>; |
167 | |
226de479 |
168 | my %times; |
169 | if ($state) { |
170 | # Where known, collate the elapsed times by test name |
171 | foreach ($state->results->tests()) { |
172 | $times{$_->name} = $_->elapsed(); |
173 | } |
174 | } |
175 | |
176 | my %dir; |
177 | my %total_time; |
178 | |
179 | for (@last) { |
133fac12 |
180 | if ($^O eq 'MSWin32') { |
181 | s,\\,/,g; # canonicalize path |
182 | }; |
183 | m!(.*[/])! or die "'$_'"; |
226de479 |
184 | push @{$dir{$1}}, $_; |
185 | $total_time{$1} += $times{$_} || 0; |
186 | } |
187 | |
0279961e |
188 | push @tests, @last; |
9ae5a6c3 |
189 | |
fc279e46 |
190 | # Generate T::H schedule rules that run the contents of each directory |
191 | # sequentially. |
226de479 |
192 | push @seq, { par => [ map { { seq => "$_*" } } sort { |
193 | # Directories, ordered by total time descending then name ascending |
194 | $total_time{$b} <=> $total_time{$a} || $a cmp $b |
195 | } keys %dir ] }; |
9ae5a6c3 |
196 | |
197 | $rules = { seq => \@seq }; |
7a315204 |
198 | } |
199 | } |
22a65f1e |
200 | if ($^O eq 'MSWin32') { |
201 | s,\\,/,g for @tests; |
202 | } |
8a76aa1f |
203 | @tests=grep /$re/, @tests |
204 | if $re; |
9ae5a6c3 |
205 | |
abd39864 |
206 | my $h = TAP::Harness->new({ |
207 | rules => $rules, |
208 | color => $color, |
209 | jobs => $jobs, |
210 | verbosity => $Verbose, |
744c27e5 |
211 | exec => \&_run_test, |
abd39864 |
212 | }); |
a0f20b65 |
213 | |
214 | if ($state) { |
e8fb11d7 |
215 | $h->callback( |
a0f20b65 |
216 | after_test => sub { |
217 | $state->observe_test(@_); |
e8fb11d7 |
218 | } |
a0f20b65 |
219 | ); |
220 | $h->callback( |
221 | after_runtests => sub { |
222 | $state->commit(@_); |
223 | } |
224 | ); |
9ae5a6c3 |
225 | } |
a0f20b65 |
226 | |
227 | $h->callback( |
228 | parser_args => sub { |
229 | my ( $args, $test ) = @_; |
230 | push @{ $args->{switches} }, '-I../lib'; |
231 | } |
232 | ); |
abd39864 |
233 | $h->runtests(@tests); |
de125441 |
234 | exit(0); |