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