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 | } |
e8fb11d7 | 10 | delete $ENV{PERL5LIB}; |
aa689395 | 11 | |
e018f8be JH |
12 | my $torture; # torture testing? |
13 | ||
a5f75d66 | 14 | use Test::Harness; |
9a4933c3 | 15 | use strict; |
a5f75d66 | 16 | |
ef712cf7 | 17 | $Test::Harness::switches = ""; # Too much noise otherwise |
9d6c4c89 | 18 | $Test::Harness::Verbose++ while @ARGV && $ARGV[0] eq '-v' && shift; |
a5f75d66 | 19 | |
12558422 | 20 | if ($ARGV[0] && $ARGV[0] eq '-torture') { |
e018f8be JH |
21 | shift; |
22 | $torture = 1; | |
23 | } | |
24 | ||
60e23f2f MS |
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 VB |
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 VB |
43 | ); |
44 | ||
45 | foreach (keys %datahandle) { | |
46 | unlink "$_.t"; | |
47 | } | |
48 | ||
0279961e | 49 | my (@tests, $re); |
122a0375 | 50 | |
40996b78 AT |
51 | # [.VMS]TEST.COM calls harness with empty arguments, so clean-up @ARGV |
52 | @ARGV = grep $_ && length( $_ ) => @ARGV; | |
53 | ||
6234cb77 NC |
54 | sub _populate_hash { |
55 | return map {$_, 1} split /\s+/, $_[0]; | |
56 | } | |
57 | ||
9ae5a6c3 NC |
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 NC |
75 | } |
76 | } | |
77 | @results; | |
78 | } | |
79 | ||
12558422 | 80 | if ($ARGV[0] && $ARGV[0]=~/^-re/) { |
8a76aa1f YO |
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}; |
cd1b270f B |
91 | my ($fork, $rules, $state); |
92 | if ($ENV{HARNESS_OPTIONS}) { | |
93 | for my $opt ( split /:/, $ENV{HARNESS_OPTIONS} ) { | |
94 | if ( $opt =~ /^j(\d*)$/ ) { | |
95 | $jobs ||= $1 || 9; | |
96 | } | |
97 | elsif ( $opt eq 'f' ) { | |
98 | $fork = 1; | |
99 | } | |
100 | elsif ( $opt eq 'c' ) { | |
101 | # $args->{color} = 1; | |
102 | } | |
103 | else { | |
104 | die "Unknown HARNESS_OPTIONS item: $opt\n"; | |
105 | } | |
106 | } | |
107 | } | |
0279961e | 108 | |
7a315204 | 109 | if (@ARGV) { |
0279961e | 110 | # If you want these run in speed order, just use prove |
4efb34a6 NIS |
111 | if ($^O eq 'MSWin32') { |
112 | @tests = map(glob($_),@ARGV); | |
113 | } | |
114 | else { | |
115 | @tests = @ARGV; | |
116 | } | |
7a315204 | 117 | } else { |
9ae5a6c3 NC |
118 | # Ideally we'd get somewhere close to Tux's Oslo rules |
119 | # my $rules = { | |
120 | # par => [ | |
121 | # { seq => '../ext/DB_File/t/*' }, | |
122 | # { seq => '../ext/IO_Compress_Zlib/t/*' }, | |
123 | # { seq => '../lib/CPANPLUS/*' }, | |
124 | # { seq => '../lib/ExtUtils/t/*' }, | |
125 | # '*' | |
126 | # ] | |
127 | # }; | |
128 | ||
129 | # but for now, run all directories in sequence. In particular, it would be | |
130 | # nice to get the tests in t/op/*.t able to run in parallel. | |
131 | ||
b695f709 | 132 | unless (@tests) { |
0279961e | 133 | my @seq = <base/*.t>; |
9ae5a6c3 | 134 | |
6b77813c | 135 | my @next = qw(comp cmd run io op uni mro lib porting); |
9ae5a6c3 NC |
136 | push @next, 'japh' if $torture; |
137 | push @next, 'win32' if $^O eq 'MSWin32'; | |
7019aa11 | 138 | push @next, 'benchmark' if $ENV{PERL_BENCHMARK}; |
0279961e NC |
139 | # Hopefully TAP::Parser::Scheduler will support this syntax soon. |
140 | # my $next = { par => '{' . join (',', @next) . '}/*.t' }; | |
141 | my $next = { par => [ | |
2f4cffa7 | 142 | map { "$_/*.t" } @next |
e6867818 | 143 | ] }; |
0279961e NC |
144 | @tests = _extract_tests ($next); |
145 | ||
146 | # This is a bit of a game, because we only want to sort these tests in | |
147 | # speed order. base/*.t wants to run first, and ext,lib etc last and in | |
148 | # MANIFEST order | |
149 | if ($jobs) { | |
150 | require App::Prove::State; | |
151 | $state = App::Prove::State->new({ store => 'test_state' }); | |
152 | $state->apply_switch('slow', 'save'); | |
153 | # For some reason get_tests returns *all* the tests previously run, | |
154 | # (in the right order), not simply the selection in @tests | |
155 | # (in the right order). Not sure if this is a bug or a feature. | |
156 | # Whatever, *we* are only interested in the ones that are in @tests | |
157 | my %seen; | |
158 | @seen{@tests} = (); | |
159 | @tests = grep {exists $seen{$_} } $state->get_tests(0, @tests); | |
160 | } | |
161 | @tests = (@seq, @tests); | |
162 | push @seq, $next; | |
9ae5a6c3 NC |
163 | |
164 | my @last; | |
6234cb77 NC |
165 | use Config; |
166 | my %skip; | |
167 | { | |
168 | my %extensions = _populate_hash $Config{'extensions'}; | |
169 | my %known_extensions = _populate_hash $Config{'known_extensions'}; | |
170 | foreach (keys %known_extensions) { | |
171 | $skip{$_}++ unless $extensions{$_}; | |
172 | } | |
173 | } | |
b695f709 JH |
174 | use File::Spec; |
175 | my $updir = File::Spec->updir; | |
122a0375 | 176 | my $mani = File::Spec->catfile(File::Spec->updir, "MANIFEST"); |
b695f709 | 177 | if (open(MANI, $mani)) { |
b1d1c89d | 178 | my @manitests = (); |
b695f709 | 179 | while (<MANI>) { # similar code in t/TEST |
e469beda | 180 | if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { |
6234cb77 NC |
181 | my ($test, $extension) = ($1, $2); |
182 | if (defined $extension) { | |
183 | $extension =~ s!/t$!!; | |
184 | # XXX Do I want to warn that I'm skipping these? | |
185 | next if $skip{$extension}; | |
142f6a0d SH |
186 | my $flat_extension = $extension; |
187 | $flat_extension =~ s!-!/!g; | |
188 | next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar | |
6234cb77 | 189 | } |
b1d1c89d | 190 | push @manitests, File::Spec->catfile($updir, $test); |
b695f709 | 191 | } |
7a315204 | 192 | } |
35d88760 | 193 | close MANI; |
b1d1c89d SH |
194 | # Sort the list of test files read from MANIFEST into a sensible |
195 | # order instead of using the order in which they are listed there | |
9ae5a6c3 | 196 | push @last, sort { lc $a cmp lc $b } @manitests; |
b695f709 JH |
197 | } else { |
198 | warn "$0: cannot open $mani: $!\n"; | |
7a315204 | 199 | } |
9ae5a6c3 NC |
200 | push @last, <pod/*.t>; |
201 | push @last, <x2p/*.t>; | |
202 | ||
0279961e | 203 | push @tests, @last; |
9ae5a6c3 | 204 | |
fc279e46 NC |
205 | # Generate T::H schedule rules that run the contents of each directory |
206 | # sequentially. | |
207 | { | |
208 | my %dir; | |
209 | for (@last) { | |
210 | s{[^/]+$}{\*}; | |
211 | $dir{$_}++; | |
212 | } | |
213 | ||
214 | push @seq, { par => [ map { { seq => $_ } } sort keys %dir ] }; | |
215 | } | |
9ae5a6c3 NC |
216 | |
217 | $rules = { seq => \@seq }; | |
7a315204 JH |
218 | } |
219 | } | |
22a65f1e GS |
220 | if ($^O eq 'MSWin32') { |
221 | s,\\,/,g for @tests; | |
222 | } | |
8a76aa1f YO |
223 | @tests=grep /$re/, @tests |
224 | if $re; | |
9ae5a6c3 | 225 | |
9ae5a6c3 NC |
226 | if ($jobs) { |
227 | eval 'use TAP::Harness 3.13; 1' or die $@; | |
cd1b270f B |
228 | |
229 | # Test::Harness parses $ENV{HARNESS_OPTIONS}, TAP::Harness does not | |
230 | local $ENV{HARNESS_OPTIONS}; | |
231 | my $h = TAP::Harness->new({ jobs => $jobs, rules => $rules, ($fork ? (fork => $fork) : ())}); | |
0279961e NC |
232 | if ($state) { |
233 | $h->callback( | |
234 | after_test => sub { | |
235 | $state->observe_test(@_); | |
236 | } | |
237 | ); | |
0b4436e8 NC |
238 | $h->callback( |
239 | after_runtests => sub { | |
240 | $state->commit(@_); | |
241 | } | |
242 | ); | |
0279961e | 243 | } |
e8fb11d7 NC |
244 | $h->callback( |
245 | parser_args => sub { | |
246 | my ( $args, $test ) = @_; | |
247 | push @{ $args->{switches} }, '-I../lib'; | |
248 | } | |
249 | ); | |
9ae5a6c3 NC |
250 | $h->runtests(@tests); |
251 | } else { | |
252 | Test::Harness::runtests @tests; | |
253 | } | |
de125441 | 254 | exit(0); |