Update Test-Harness to CPAN version 3.39
[perl.git] / cpan / Test-Harness / lib / Test / Harness.pm
1 package Test::Harness;
2
3 use 5.006;
4
5 use strict;
6 use warnings;
7
8 use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
9 use constant IS_VMS => ( $^O eq 'VMS' );
10
11 use TAP::Harness                     ();
12 use TAP::Parser::Aggregator          ();
13 use TAP::Parser::Source              ();
14 use TAP::Parser::SourceHandler::Perl ();
15
16 use Text::ParseWords qw(shellwords);
17
18 use Config;
19 use base 'Exporter';
20
21 # $ML $Last_ML_Print
22
23 BEGIN {
24     eval q{use Time::HiRes 'time'};
25     our $has_time_hires = !$@;
26 }
27
28 =head1 NAME
29
30 Test::Harness - Run Perl standard test scripts with statistics
31
32 =head1 VERSION
33
34 Version 3.39
35
36 =cut
37
38 our $VERSION = '3.39';
39
40 # Backwards compatibility for exportable variable names.
41 *verbose  = *Verbose;
42 *switches = *Switches;
43 *debug    = *Debug;
44
45 $ENV{HARNESS_ACTIVE}  = 1;
46 $ENV{HARNESS_VERSION} = $VERSION;
47
48 END {
49
50     # For VMS.
51     delete $ENV{HARNESS_ACTIVE};
52     delete $ENV{HARNESS_VERSION};
53 }
54
55 our @EXPORT    = qw(&runtests);
56 our @EXPORT_OK = qw(&execute_tests $verbose $switches);
57
58 our $Verbose = $ENV{HARNESS_VERBOSE} || 0;
59 our $Debug   = $ENV{HARNESS_DEBUG}   || 0;
60 our $Switches = '-w';
61 our $Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
62 $Columns--;    # Some shells have trouble with a full line of text.
63 our $Timer      = $ENV{HARNESS_TIMER}       || 0;
64 our $Color      = $ENV{HARNESS_COLOR}       || 0;
65 our $IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
66
67 =head1 SYNOPSIS
68
69   use Test::Harness;
70
71   runtests(@test_files);
72
73 =head1 DESCRIPTION
74
75 Although, for historical reasons, the L<Test::Harness> distribution
76 takes its name from this module it now exists only to provide
77 L<TAP::Harness> with an interface that is somewhat backwards compatible
78 with L<Test::Harness> 2.xx. If you're writing new code consider using
79 L<TAP::Harness> directly instead.
80
81 Emulation is provided for C<runtests> and C<execute_tests> but the
82 pluggable 'Straps' interface that previous versions of L<Test::Harness>
83 supported is not reproduced here. Straps is now available as a stand
84 alone module: L<Test::Harness::Straps>.
85
86 See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this
87 distribution.
88
89 =head1 FUNCTIONS
90
91 The following functions are available.
92
93 =head2 runtests( @test_files )
94
95 This runs all the given I<@test_files> and divines whether they passed
96 or failed based on their output to STDOUT (details above).  It prints
97 out each individual test which failed along with a summary report and
98 a how long it all took.
99
100 It returns true if everything was ok.  Otherwise it will C<die()> with
101 one of the messages in the DIAGNOSTICS section.
102
103 =cut
104
105 sub _has_taint {
106     my $test = shift;
107     return TAP::Parser::SourceHandler::Perl->get_taint(
108         TAP::Parser::Source->shebang($test) );
109 }
110
111 sub _aggregate {
112     my ( $harness, $aggregate, @tests ) = @_;
113
114     # Don't propagate to our children
115     local $ENV{HARNESS_OPTIONS};
116
117     _apply_extra_INC($harness);
118     _aggregate_tests( $harness, $aggregate, @tests );
119 }
120
121 # Make sure the child sees all the extra junk in @INC
122 sub _apply_extra_INC {
123     my $harness = shift;
124
125     $harness->callback(
126         parser_args => sub {
127             my ( $args, $test ) = @_;
128             push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
129         }
130     );
131 }
132
133 sub _aggregate_tests {
134     my ( $harness, $aggregate, @tests ) = @_;
135     $aggregate->start();
136     $harness->aggregate_tests( $aggregate, @tests );
137     $aggregate->stop();
138
139 }
140
141 sub runtests {
142     my @tests = @_;
143
144     # shield against -l
145     local ( $\, $, );
146
147     my $harness   = _new_harness();
148     my $aggregate = TAP::Parser::Aggregator->new();
149
150     local $ENV{PERL_USE_UNSAFE_INC} = 1 if not exists $ENV{PERL_USE_UNSAFE_INC};
151     _aggregate( $harness, $aggregate, @tests );
152
153     $harness->formatter->summary($aggregate);
154
155     my $total  = $aggregate->total;
156     my $passed = $aggregate->passed;
157     my $failed = $aggregate->failed;
158
159     my @parsers = $aggregate->parsers;
160
161     my $num_bad = 0;
162     for my $parser (@parsers) {
163         $num_bad++ if $parser->has_problems;
164     }
165
166     die(sprintf(
167             "Failed %d/%d test programs. %d/%d subtests failed.\n",
168             $num_bad, scalar @parsers, $failed, $total
169         )
170     ) if $num_bad;
171
172     return $total && $total == $passed;
173 }
174
175 sub _canon {
176     my @list   = sort { $a <=> $b } @_;
177     my @ranges = ();
178     my $count  = scalar @list;
179     my $pos    = 0;
180
181     while ( $pos < $count ) {
182         my $end = $pos + 1;
183         $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
184         push @ranges, ( $end == $pos + 1 )
185           ? $list[$pos]
186           : join( '-', $list[$pos], $list[ $end - 1 ] );
187         $pos = $end;
188     }
189
190     return join( ' ', @ranges );
191 }
192
193 sub _new_harness {
194     my $sub_args = shift || {};
195
196     my ( @lib, @switches );
197     my @opt = map { shellwords($_) } grep { defined } $Switches, $ENV{HARNESS_PERL_SWITCHES};
198     while ( my $opt = shift @opt ) {
199         if ( $opt =~ /^ -I (.*) $ /x ) {
200             push @lib, length($1) ? $1 : shift @opt;
201         }
202         else {
203             push @switches, $opt;
204         }
205     }
206
207     # Do things the old way on VMS...
208     push @lib, _filtered_inc() if IS_VMS;
209
210     # If $Verbose isn't numeric default to 1. This helps core.
211     my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
212
213     my $args = {
214         timer       => $Timer,
215         directives  => our $Directives,
216         lib         => \@lib,
217         switches    => \@switches,
218         color       => $Color,
219         verbosity   => $verbosity,
220         ignore_exit => $IgnoreExit,
221     };
222
223     $args->{stdout} = $sub_args->{out}
224       if exists $sub_args->{out};
225
226     my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness';
227     if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
228         for my $opt ( split /:/, $env_opt ) {
229             if ( $opt =~ /^j(\d*)$/ ) {
230                 $args->{jobs} = $1 || 9;
231             }
232             elsif ( $opt eq 'c' ) {
233                 $args->{color} = 1;
234             }
235             elsif ( $opt =~ m/^f(.*)$/ ) {
236                 my $fmt = $1;
237                 $fmt =~ s/-/::/g;
238                 $args->{formatter_class} = $fmt;
239             }
240             elsif ( $opt =~ m/^a(.*)$/ ) {
241                 my $archive = $1;
242                 $class = "TAP::Harness::Archive";
243                 $args->{archive} = $archive;
244             }
245             else {
246                 die "Unknown HARNESS_OPTIONS item: $opt\n";
247             }
248         }
249     }
250
251     return TAP::Harness->_construct( $class, $args );
252 }
253
254 # Get the parts of @INC which are changed from the stock list AND
255 # preserve reordering of stock directories.
256 sub _filtered_inc {
257     my @inc = grep { !ref } @INC;    #28567
258
259     if (IS_VMS) {
260
261         # VMS has a 255-byte limit on the length of %ENV entries, so
262         # toss the ones that involve perl_root, the install location
263         @inc = grep !/perl_root/i, @inc;
264
265     }
266     elsif (IS_WIN32) {
267
268         # Lose any trailing backslashes in the Win32 paths
269         s/[\\\/]+$// for @inc;
270     }
271
272     my @default_inc = _default_inc();
273
274     my @new_inc;
275     my %seen;
276     for my $dir (@inc) {
277         next if $seen{$dir}++;
278
279         if ( $dir eq ( $default_inc[0] || '' ) ) {
280             shift @default_inc;
281         }
282         else {
283             push @new_inc, $dir;
284         }
285
286         shift @default_inc while @default_inc and $seen{ $default_inc[0] };
287     }
288
289     return @new_inc;
290 }
291
292 {
293
294     # Cache this to avoid repeatedly shelling out to Perl.
295     my @inc;
296
297     sub _default_inc {
298         return @inc if @inc;
299
300         local $ENV{PERL5LIB};
301         local $ENV{PERLLIB};
302
303         my $perl = $ENV{HARNESS_PERL} || $^X;
304
305         # Avoid using -l for the benefit of Perl 6
306         chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` );
307         return @inc;
308     }
309 }
310
311 sub _check_sequence {
312     my @list = @_;
313     my $prev;
314     while ( my $next = shift @list ) {
315         return if defined $prev && $next <= $prev;
316         $prev = $next;
317     }
318
319     return 1;
320 }
321
322 sub execute_tests {
323     my %args = @_;
324
325     my $harness   = _new_harness( \%args );
326     my $aggregate = TAP::Parser::Aggregator->new();
327
328     my %tot = (
329         bonus       => 0,
330         max         => 0,
331         ok          => 0,
332         bad         => 0,
333         good        => 0,
334         files       => 0,
335         tests       => 0,
336         sub_skipped => 0,
337         todo        => 0,
338         skipped     => 0,
339         bench       => undef,
340     );
341
342     # Install a callback so we get to see any plans the
343     #┬áharness executes.
344     $harness->callback(
345         made_parser => sub {
346             my $parser = shift;
347             $parser->callback(
348                 plan => sub {
349                     my $plan = shift;
350                     if ( $plan->directive eq 'SKIP' ) {
351                         $tot{skipped}++;
352                     }
353                 }
354             );
355         }
356     );
357
358     local $ENV{PERL_USE_UNSAFE_INC} = 1 if not exists $ENV{PERL_USE_UNSAFE_INC};
359     _aggregate( $harness, $aggregate, @{ $args{tests} } );
360
361     $tot{bench} = $aggregate->elapsed;
362     my @tests = $aggregate->descriptions;
363
364     # TODO: Work out the circumstances under which the files
365     # and tests totals can differ.
366     $tot{files} = $tot{tests} = scalar @tests;
367
368     my %failedtests = ();
369     my %todo_passed = ();
370
371     for my $test (@tests) {
372         my ($parser) = $aggregate->parsers($test);
373
374         my @failed = $parser->failed;
375
376         my $wstat         = $parser->wait;
377         my $estat         = $parser->exit;
378         my $planned       = $parser->tests_planned;
379         my @errors        = $parser->parse_errors;
380         my $passed        = $parser->passed;
381         my $actual_passed = $parser->actual_passed;
382
383         my $ok_seq = _check_sequence( $parser->actual_passed );
384
385         # Duplicate exit, wait status semantics of old version
386         $estat ||= '' unless $wstat;
387         $wstat ||= '';
388
389         $tot{max} += ( $planned || 0 );
390         $tot{bonus} += $parser->todo_passed;
391         $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
392         $tot{sub_skipped} += $parser->skipped;
393         $tot{todo}        += $parser->todo;
394
395         if ( @failed || $estat || @errors ) {
396             $tot{bad}++;
397
398             my $huh_planned = $planned ? undef : '??';
399             my $huh_errors  = $ok_seq  ? undef : '??';
400
401             $failedtests{$test} = {
402                 'canon' => $huh_planned
403                   || $huh_errors
404                   || _canon(@failed)
405                   || '??',
406                 'estat'  => $estat,
407                 'failed' => $huh_planned
408                   || $huh_errors
409                   || scalar @failed,
410                 'max' => $huh_planned || $planned,
411                 'name'  => $test,
412                 'wstat' => $wstat
413             };
414         }
415         else {
416             $tot{good}++;
417         }
418
419         my @todo = $parser->todo_passed;
420         if (@todo) {
421             $todo_passed{$test} = {
422                 'canon'  => _canon(@todo),
423                 'estat'  => $estat,
424                 'failed' => scalar @todo,
425                 'max'    => scalar $parser->todo,
426                 'name'   => $test,
427                 'wstat'  => $wstat
428             };
429         }
430     }
431
432     return ( \%tot, \%failedtests, \%todo_passed );
433 }
434
435 =head2 execute_tests( tests => \@test_files, out => \*FH )
436
437 Runs all the given C<@test_files> (just like C<runtests()>) but
438 doesn't generate the final report.  During testing, progress
439 information will be written to the currently selected output
440 filehandle (usually C<STDOUT>), or to the filehandle given by the
441 C<out> parameter.  The I<out> is optional.
442
443 Returns a list of two values, C<$total> and C<$failed>, describing the
444 results.  C<$total> is a hash ref summary of all the tests run.  Its
445 keys and values are this:
446
447     bonus           Number of individual todo tests unexpectedly passed
448     max             Number of individual tests ran
449     ok              Number of individual tests passed
450     sub_skipped     Number of individual tests skipped
451     todo            Number of individual todo tests
452
453     files           Number of test files ran
454     good            Number of test files passed
455     bad             Number of test files failed
456     tests           Number of test files originally given
457     skipped         Number of test files skipped
458
459 If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
460 got a successful test.
461
462 C<$failed> is a hash ref of all the test scripts that failed.  Each key
463 is the name of a test script, each value is another hash representing
464 how that script failed.  Its keys are these:
465
466     name        Name of the test which failed
467     estat       Script's exit value
468     wstat       Script's wait status
469     max         Number of individual tests
470     failed      Number which failed
471     canon       List of tests which failed (as string).
472
473 C<$failed> should be empty if everything passed.
474
475 =cut
476
477 1;
478 __END__
479
480 =head1 EXPORT
481
482 C<&runtests> is exported by C<Test::Harness> by default.
483
484 C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
485 exported upon request.
486
487 =head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
488
489 C<Test::Harness> sets these before executing the individual tests.
490
491 =over 4
492
493 =item C<HARNESS_ACTIVE>
494
495 This is set to a true value.  It allows the tests to determine if they
496 are being executed through the harness or by any other means.
497
498 =item C<HARNESS_VERSION>
499
500 This is the version of C<Test::Harness>.
501
502 =back
503
504 =head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
505
506 =over 4
507
508 =item C<HARNESS_PERL_SWITCHES>
509
510 Setting this adds perl command line switches to each test file run.
511
512 For example, C<HARNESS_PERL_SWITCHES=-T> will turn on taint mode.
513 C<HARNESS_PERL_SWITCHES=-MDevel::Cover> will run C<Devel::Cover> for
514 each test.
515
516 C<-w> is always set.  You can turn this off in the test with C<BEGIN {
517 $^W = 0 }>.
518
519 =item C<HARNESS_TIMER>
520
521 Setting this to true will make the harness display the number of
522 milliseconds each test took.  You can also use F<prove>'s C<--timer>
523 switch.
524
525 =item C<HARNESS_VERBOSE>
526
527 If true, C<Test::Harness> will output the verbose results of running
528 its tests.  Setting C<$Test::Harness::verbose> will override this,
529 or you can use the C<-v> switch in the F<prove> utility.
530
531 =item C<HARNESS_OPTIONS>
532
533 Provide additional options to the harness. Currently supported options are:
534
535 =over
536
537 =item C<< j<n> >>
538
539 Run <n> (default 9) parallel jobs.
540
541 =item C<< c >>
542
543 Try to color output. See L<TAP::Formatter::Base/"new">.
544
545 =item C<< a<file.tgz> >>
546
547 Will use L<TAP::Harness::Archive> as the harness class, and save the TAP to
548 C<file.tgz>
549
550 =item C<< fPackage-With-Dashes >>
551
552 Set the formatter_class of the harness being run. Since the C<HARNESS_OPTIONS>
553 is seperated by C<:>, we use C<-> instead.
554
555 =back
556
557 Multiple options may be separated by colons:
558
559     HARNESS_OPTIONS=j9:c make test
560
561 =item C<HARNESS_SUBCLASS>
562
563 Specifies a TAP::Harness subclass to be used in place of TAP::Harness.
564
565 =item C<HARNESS_SUMMARY_COLOR_SUCCESS>
566
567 Determines the L<Term::ANSIColor> for the summary in case it is successful.
568 This color defaults to C<'green'>.
569
570 =item C<HARNESS_SUMMARY_COLOR_FAIL>
571
572 Determines the L<Term::ANSIColor> for the failure in case it is successful.
573 This color defaults to C<'red'>.
574
575 =back
576
577 =head1 Taint Mode
578
579 Normally when a Perl program is run in taint mode the contents of the
580 C<PERL5LIB> environment variable do not appear in C<@INC>.
581
582 Because C<PERL5LIB> is often used during testing to add build
583 directories to C<@INC> C<Test::Harness> passes the names of any
584 directories found in C<PERL5LIB> as -I switches. The net effect of this
585 is that C<PERL5LIB> is honoured even in taint mode.
586
587 =head1 SEE ALSO
588
589 L<TAP::Harness>
590
591 =head1 BUGS
592
593 Please report any bugs or feature requests to
594 C<bug-test-harness at rt.cpan.org>, or through the web interface at
595 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.  I will be 
596 notified, and then you'll automatically be notified of progress on your bug 
597 as I make changes.
598
599 =head1 AUTHORS
600
601 Andy Armstrong  C<< <andy@hexten.net> >>
602
603 L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
604 module is based) has this attribution:
605
606     Either Tim Bunce or Andreas Koenig, we don't know. What we know for
607     sure is, that it was inspired by Larry Wall's F<TEST> script that came
608     with perl distributions for ages. Numerous anonymous contributors
609     exist.  Andreas Koenig held the torch for many years, and then
610     Michael G Schwern.
611
612 =head1 LICENCE AND COPYRIGHT
613
614 Copyright (c) 2007-2011, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
615
616 This module is free software; you can redistribute it and/or
617 modify it under the same terms as Perl itself. See L<perlartistic>.
618