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