Commit | Line | Data |
---|---|---|
a5f75d66 AD |
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 | |
e018f8be JH |
11 | my $torture; # torture testing? |
12 | ||
abd39864 | 13 | use TAP::Harness 3.13; |
9a4933c3 | 14 | use strict; |
68bb50b0 | 15 | use Config; |
a5f75d66 | 16 | |
c537bcda NC |
17 | $::do_nothing = $::do_nothing = 1; |
18 | require './TEST'; | |
19 | ||
abd39864 MS |
20 | my $Verbose = 0; |
21 | $Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; | |
a5f75d66 | 22 | |
12558422 | 23 | if ($ARGV[0] && $ARGV[0] eq '-torture') { |
e018f8be JH |
24 | shift; |
25 | $torture = 1; | |
26 | } | |
27 | ||
60e23f2f MS |
28 | # Let tests know they're running in the perl core. Useful for modules |
29 | # which live dual lives on CPAN. | |
30 | $ENV{PERL_CORE} = 1; | |
31 | ||
0ca04487 | 32 | #fudge DATA for now. |
9a4933c3 | 33 | my %datahandle = qw( |
0ca04487 VB |
34 | lib/bigint.t 1 |
35 | lib/bigintpm.t 1 | |
36 | lib/bigfloat.t 1 | |
37 | lib/bigfloatpm.t 1 | |
38 | op/gv.t 1 | |
39 | lib/complex.t 1 | |
40 | lib/ph.t 1 | |
41 | lib/soundex.t 1 | |
42 | op/misc.t 1 | |
43 | op/runlevel.t 1 | |
44 | op/tie.t 1 | |
45 | op/lex_assign.t 1 | |
0ca04487 VB |
46 | ); |
47 | ||
48 | foreach (keys %datahandle) { | |
49 | unlink "$_.t"; | |
50 | } | |
51 | ||
0279961e | 52 | my (@tests, $re); |
122a0375 | 53 | |
40996b78 AT |
54 | # [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV |
55 | @ARGV = grep $_ && length( $_ ) => @ARGV; | |
56 | ||
9ae5a6c3 NC |
57 | sub _extract_tests; |
58 | sub _extract_tests { | |
59 | # This can probably be done more tersely with a map, but I doubt that it | |
60 | # would be as clear | |
61 | my @results; | |
62 | foreach (@_) { | |
63 | my $ref = ref $_; | |
64 | if ($ref) { | |
65 | if ($ref eq 'ARRAY') { | |
66 | push @results, _extract_tests @$_; | |
67 | } elsif ($ref eq 'HASH') { | |
68 | push @results, _extract_tests values %$_; | |
69 | } else { | |
70 | die "Unknown reference type $ref"; | |
71 | } | |
72 | } else { | |
0ae187c2 | 73 | push @results, glob $_; |
9ae5a6c3 NC |
74 | } |
75 | } | |
76 | @results; | |
77 | } | |
78 | ||
12558422 | 79 | if ($ARGV[0] && $ARGV[0]=~/^-re/) { |
8a76aa1f YO |
80 | if ($ARGV[0]!~/=/) { |
81 | shift; | |
82 | $re=join "|",@ARGV; | |
83 | @ARGV=(); | |
84 | } else { | |
85 | (undef,$re)=split/=/,shift; | |
86 | } | |
87 | } | |
88 | ||
0279961e | 89 | my $jobs = $ENV{TEST_JOBS}; |
abd39864 | 90 | my ($rules, $state, $color); |
cd1b270f B |
91 | if ($ENV{HARNESS_OPTIONS}) { |
92 | for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) { | |
93 | if ( $opt =~ /^j(\d*)$/ ) { | |
94 | $jobs ||= $1 || 9; | |
95 | } | |
cd1b270f | 96 | elsif ( $opt eq 'c' ) { |
abd39864 | 97 | $color = 1; |
cd1b270f B |
98 | } |
99 | else { | |
100 | die "Unknown HARNESS_OPTIONS item: $opt\n"; | |
101 | } | |
102 | } | |
103 | } | |
0279961e | 104 | |
7a315204 | 105 | if (@ARGV) { |
0279961e | 106 | # If you want these run in speed order, just use prove |
4efb34a6 NIS |
107 | if ($^O eq 'MSWin32') { |
108 | @tests = map(glob($_),@ARGV); | |
109 | } | |
110 | else { | |
111 | @tests = @ARGV; | |
112 | } | |
68bb50b0 NC |
113 | # This is a hack to force config_heavy.pl to be loaded, before the |
114 | # prep work for running a test changes directory. | |
115 | 1 if $Config{d_fork}; | |
7a315204 | 116 | } else { |
9ae5a6c3 NC |
117 | # Ideally we'd get somewhere close to Tux's Oslo rules |
118 | # my $rules = { | |
119 | # par => [ | |
120 | # { seq => '../ext/DB_File/t/*' }, | |
121 | # { seq => '../ext/IO_Compress_Zlib/t/*' }, | |
122 | # { seq => '../lib/CPANPLUS/*' }, | |
123 | # { seq => '../lib/ExtUtils/t/*' }, | |
124 | # '*' | |
125 | # ] | |
126 | # }; | |
127 | ||
128 | # but for now, run all directories in sequence. In particular, it would be | |
129 | # nice to get the tests in t/op/*.t able to run in parallel. | |
130 | ||
b695f709 | 131 | unless (@tests) { |
0279961e | 132 | my @seq = <base/*.t>; |
9ae5a6c3 | 133 | |
a4499558 | 134 | my @next = qw(comp run cmd io re op uni mro lib porting); |
9ae5a6c3 NC |
135 | push @next, 'japh' if $torture; |
136 | push @next, 'win32' if $^O eq 'MSWin32'; | |
7019aa11 | 137 | push @next, 'benchmark' if $ENV{PERL_BENCHMARK}; |
0279961e NC |
138 | # Hopefully TAP::Parser::Scheduler will support this syntax soon. |
139 | # my $next = { par => '{' . join (',', @next) . '}/*.t' }; | |
140 | my $next = { par => [ | |
2f4cffa7 | 141 | map { "$_/*.t" } @next |
e6867818 | 142 | ] }; |
0279961e NC |
143 | @tests = _extract_tests ($next); |
144 | ||
145 | # This is a bit of a game, because we only want to sort these tests in | |
146 | # speed order. base/*.t wants to run first, and ext,lib etc last and in | |
147 | # MANIFEST order | |
148 | if ($jobs) { | |
149 | require App::Prove::State; | |
150 | $state = App::Prove::State->new({ store => 'test_state' }); | |
151 | $state->apply_switch('slow', 'save'); | |
152 | # For some reason get_tests returns *all* the tests previously run, | |
153 | # (in the right order), not simply the selection in @tests | |
154 | # (in the right order). Not sure if this is a bug or a feature. | |
155 | # Whatever, *we* are only interested in the ones that are in @tests | |
156 | my %seen; | |
157 | @seen{@tests} = (); | |
158 | @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests); | |
159 | } | |
160 | @tests = (@seq, @tests); | |
161 | push @seq, $next; | |
9ae5a6c3 NC |
162 | |
163 | my @last; | |
a3323f52 NC |
164 | push @last, sort { lc $a cmp lc $b } |
165 | _tests_from_manifest($Config{extensions}, $Config{known_extensions}); | |
9ae5a6c3 NC |
166 | push @last, <x2p/*.t>; |
167 | ||
226de479 NC |
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 MM |
180 | if ($^O eq 'MSWin32') { |
181 | s,\\,/,g; # canonicalize path | |
182 | }; | |
8f776eae NC |
183 | # Treat every file matching lib/*.t as a "directory" |
184 | m!\A(\.\./lib/[^/]+\.t\z|.*[/])! or die "'$_'"; | |
226de479 NC |
185 | push @{$dir{$1}}, $_; |
186 | $total_time{$1} += $times{$_} || 0; | |
187 | } | |
188 | ||
0279961e | 189 | push @tests, @last; |
9ae5a6c3 | 190 | |
fc279e46 NC |
191 | # Generate T::H schedule rules that run the contents of each directory |
192 | # sequentially. | |
8f776eae | 193 | push @seq, { par => [ map { s!/$!/*!; { seq => $_ } } sort { |
226de479 NC |
194 | # Directories, ordered by total time descending then name ascending |
195 | $total_time{$b} <=> $total_time{$a} || $a cmp $b | |
196 | } keys %dir ] }; | |
9ae5a6c3 NC |
197 | |
198 | $rules = { seq => \@seq }; | |
7a315204 JH |
199 | } |
200 | } | |
22a65f1e GS |
201 | if ($^O eq 'MSWin32') { |
202 | s,\\,/,g for @tests; | |
203 | } | |
8a76aa1f YO |
204 | @tests=grep /$re/, @tests |
205 | if $re; | |
9ae5a6c3 | 206 | |
4013a0e1 VP |
207 | my %options; |
208 | ||
209 | my $type = 'perl'; | |
210 | ||
211 | # Load TAP::Parser now as otherwise it could be required in the short time span | |
212 | # in which the harness process chdirs into ext/Dist | |
213 | require TAP::Parser; | |
214 | ||
abd39864 MS |
215 | my $h = TAP::Harness->new({ |
216 | rules => $rules, | |
217 | color => $color, | |
218 | jobs => $jobs, | |
219 | verbosity => $Verbose, | |
4013a0e1 VP |
220 | exec => sub { |
221 | my ($harness, $test) = @_; | |
222 | ||
223 | my $options = $options{$test}; | |
224 | if (!defined $options) { | |
225 | $options = $options{$test} = _scan_test($test, $type); | |
226 | } | |
227 | ||
228 | return [ split ' ', _cmd($options, $type) ]; | |
229 | }, | |
abd39864 | 230 | }); |
a0f20b65 NC |
231 | |
232 | if ($state) { | |
e8fb11d7 | 233 | $h->callback( |
a0f20b65 NC |
234 | after_test => sub { |
235 | $state->observe_test(@_); | |
e8fb11d7 | 236 | } |
a0f20b65 NC |
237 | ); |
238 | $h->callback( | |
239 | after_runtests => sub { | |
240 | $state->commit(@_); | |
241 | } | |
242 | ); | |
9ae5a6c3 | 243 | } |
a0f20b65 NC |
244 | |
245 | $h->callback( | |
246 | parser_args => sub { | |
4013a0e1 VP |
247 | my ($args, $job) = @_; |
248 | my $test = $job->[0]; | |
249 | _before_fork($options{$test}); | |
250 | push @{ $args->{switches} }, "-I../../lib"; | |
a0f20b65 NC |
251 | } |
252 | ); | |
4013a0e1 VP |
253 | |
254 | $h->callback( | |
255 | made_parser => sub { | |
256 | my ($parser, $job) = @_; | |
257 | my $test = $job->[0]; | |
258 | my $options = delete $options{$test}; | |
259 | _after_fork($options); | |
260 | } | |
261 | ); | |
262 | ||
f483babb DG |
263 | my $agg = $h->runtests(@tests); |
264 | exit $agg->has_errors ? 1 : 0; |