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.43
35
36=cut
37
38our $VERSION = '3.43';
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    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
175sub _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
193sub _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.
256sub _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
311sub _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
322sub 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
437Runs all the given C<@test_files> (just like C<runtests()>) but
438doesn't generate the final report.  During testing, progress
439information will be written to the currently selected output
440filehandle (usually C<STDOUT>), or to the filehandle given by the
441C<out> parameter.  The I<out> is optional.
442
443Returns a list of two values, C<$total> and C<$failed>, describing the
444results.  C<$total> is a hash ref summary of all the tests run.  Its
445keys 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
459If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
460got a successful test.
461
462C<$failed> is a hash ref of all the test scripts that failed.  Each key
463is the name of a test script, each value is another hash representing
464how 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
473C<$failed> should be empty if everything passed.
474
475=cut
476
4771;
478__END__
479
480=head1 EXPORT
481
482C<&runtests> is exported by C<Test::Harness> by default.
483
484C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
485exported upon request.
486
487=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
488
489C<Test::Harness> sets these before executing the individual tests.
490
491=over 4
492
493=item C<HARNESS_ACTIVE>
494
495This is set to a true value.  It allows the tests to determine if they
496are being executed through the harness or by any other means.
497
498=item C<HARNESS_VERSION>
499
500This 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
510Setting this adds perl command line switches to each test file run.
511
512For example, C<HARNESS_PERL_SWITCHES=-T> will turn on taint mode.
513C<HARNESS_PERL_SWITCHES=-MDevel::Cover> will run C<Devel::Cover> for
514each test.
515
516C<-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
521Setting this to true will make the harness display the number of
522milliseconds each test took.  You can also use F<prove>'s C<--timer>
523switch.
524
525=item C<HARNESS_VERBOSE>
526
527If true, C<Test::Harness> will output the verbose results of running
528its tests.  Setting C<$Test::Harness::verbose> will override this,
529or you can use the C<-v> switch in the F<prove> utility.
530
531=item C<HARNESS_OPTIONS>
532
533Provide additional options to the harness. Currently supported options are:
534
535=over
536
537=item C<< j<n> >>
538
539Run <n> (default 9) parallel jobs.
540
541=item C<< c >>
542
543Try to color output. See L<TAP::Formatter::Base/"new">.
544
545=item C<< a<file.tgz> >>
546
547Will use L<TAP::Harness::Archive> as the harness class, and save the TAP to
548C<file.tgz>
549
550=item C<< fPackage-With-Dashes >>
551
552Set the formatter_class of the harness being run. Since the C<HARNESS_OPTIONS>
553is seperated by C<:>, we use C<-> instead.
554
555=back
556
557Multiple options may be separated by colons:
558
559    HARNESS_OPTIONS=j9:c make test
560
561=item C<HARNESS_SUBCLASS>
562
563Specifies a TAP::Harness subclass to be used in place of TAP::Harness.
564
565=item C<HARNESS_SUMMARY_COLOR_SUCCESS>
566
567Determines the L<Term::ANSIColor> for the summary in case it is successful.
568This color defaults to C<'green'>.
569
570=item C<HARNESS_SUMMARY_COLOR_FAIL>
571
572Determines the L<Term::ANSIColor> for the failure in case it is successful.
573This color defaults to C<'red'>.
574
575=back
576
577=head1 Taint Mode
578
579Normally when a Perl program is run in taint mode the contents of the
580C<PERL5LIB> environment variable do not appear in C<@INC>.
581
582Because C<PERL5LIB> is often used during testing to add build
583directories to C<@INC> C<Test::Harness> passes the names of any
584directories found in C<PERL5LIB> as -I switches. The net effect of this
585is that C<PERL5LIB> is honoured even in taint mode.
586
587=head1 SEE ALSO
588
589L<TAP::Harness>
590
591=head1 BUGS
592
593Please report any bugs or feature requests to
594C<bug-test-harness at rt.cpan.org>, or through the web interface at
595L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.  I will be
596notified, and then you'll automatically be notified of progress on your bug
597as I make changes.
598
599=head1 AUTHORS
600
601Andy Armstrong  C<< <andy@hexten.net> >>
602
603L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
604module 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
614Copyright (c) 2007-2011, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
615
616This module is free software; you can redistribute it and/or
617modify it under the same terms as Perl itself. See L<perlartistic>.
618
619