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