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