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 |
ef712cf7 | 9 | $ENV{PERL5LIB} = '../lib'; # so children will see it too |
aa689395 | 10 | } |
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 = (); |
00701878 | 191 | my $ext_pat = $^O eq 'MSWin32' ? '(?:win32/)?ext' : 'ext'; |
b695f709 | 192 | while (<MANI>) { # similar code in t/TEST |
00701878 | 193 | if (m!^($ext_pat/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) { |
6234cb77 NC |
194 | my ($test, $extension) = ($1, $2); |
195 | if (defined $extension) { | |
196 | $extension =~ s!/t$!!; | |
197 | # XXX Do I want to warn that I'm skipping these? | |
198 | next if $skip{$extension}; | |
199 | } | |
b1d1c89d | 200 | push @manitests, File::Spec->catfile($updir, $test); |
b695f709 | 201 | } |
7a315204 | 202 | } |
35d88760 | 203 | close MANI; |
b1d1c89d SH |
204 | # Sort the list of test files read from MANIFEST into a sensible |
205 | # order instead of using the order in which they are listed there | |
9ae5a6c3 | 206 | push @last, sort { lc $a cmp lc $b } @manitests; |
b695f709 JH |
207 | } else { |
208 | warn "$0: cannot open $mani: $!\n"; | |
7a315204 | 209 | } |
9ae5a6c3 NC |
210 | push @last, <Module_Pluggable/*.t>; |
211 | push @last, <pod/*.t>; | |
212 | push @last, <x2p/*.t>; | |
213 | ||
0279961e | 214 | push @tests, @last; |
9ae5a6c3 NC |
215 | |
216 | push @seq, _seq_dir_rules @last; | |
217 | ||
218 | $rules = { seq => \@seq }; | |
7a315204 JH |
219 | } |
220 | } | |
22a65f1e GS |
221 | if ($^O eq 'MSWin32') { |
222 | s,\\,/,g for @tests; | |
223 | } | |
8a76aa1f YO |
224 | @tests=grep /$re/, @tests |
225 | if $re; | |
9ae5a6c3 | 226 | |
9ae5a6c3 NC |
227 | if ($jobs) { |
228 | eval 'use TAP::Harness 3.13; 1' or die $@; | |
cd1b270f B |
229 | |
230 | # Test::Harness parses $ENV{HARNESS_OPTIONS}, TAP::Harness does not | |
231 | local $ENV{HARNESS_OPTIONS}; | |
232 | my $h = TAP::Harness->new({ jobs => $jobs, rules => $rules, ($fork ? (fork => $fork) : ())}); | |
0279961e NC |
233 | if ($state) { |
234 | $h->callback( | |
235 | after_test => sub { | |
236 | $state->observe_test(@_); | |
237 | } | |
238 | ); | |
239 | } | |
9ae5a6c3 NC |
240 | $h->runtests(@tests); |
241 | } else { | |
242 | Test::Harness::runtests @tests; | |
243 | } | |
de125441 | 244 | exit(0); |