diff options
author | Nicholas Clark <nick@ccl4.org> | 2007-12-19 18:18:04 +0000 |
---|---|---|
committer | Nicholas Clark <nick@ccl4.org> | 2007-12-19 18:18:04 +0000 |
commit | b965d173aab5196552f8fc4ba42e0913bbdb8d25 (patch) | |
tree | 9bd0cffb4752e50e638eb7d58e2c752d4f7fbd15 /lib/Test | |
parent | 794f4697121b50d7447d6309d7c9ada4bca913e2 (diff) | |
download | perl-b965d173aab5196552f8fc4ba42e0913bbdb8d25.tar.gz |
Upgrade to Test::Harness 3.05
Add test boilerplate to various test files.
Add FIXME skips for various tests that don't play nicely with the
altered layout in the core.
lib/Test/Harness/t/unicode.t appears to fail under UTF-8 locales and
so will need fixing.
p4raw-id: //depot/perl@32659
Diffstat (limited to 'lib/Test')
49 files changed, 12879 insertions, 3641 deletions
diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 1991a60f67..b355362db7 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -1,28 +1,34 @@ -# -*- Mode: cperl; cperl-indent-level: 4 -*- - package Test::Harness; require 5.00405; -use Test::Harness::Straps; -use Test::Harness::Assert; -use Exporter; -use Benchmark; -use Config; + use strict; +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); +use constant IS_VMS => ( $^O eq 'VMS' ); + +use TAP::Harness (); +use TAP::Parser::Aggregator (); +use TAP::Parser::Source::Perl (); +use Config; +use Exporter; + +# TODO: Emulate at least some of these use vars qw( - $VERSION - @ISA @EXPORT @EXPORT_OK - $Verbose $Switches $Debug - $verbose $switches $debug - $Columns - $Timer - $ML $Last_ML_Print - $Strap - $has_time_hires + $VERSION + @ISA @EXPORT @EXPORT_OK + $Verbose $Switches $Debug + $verbose $switches $debug + $Columns + $Directives + $Timer + $Strap + $has_time_hires ); +# $ML $Last_ML_Print + BEGIN { eval q{use Time::HiRes 'time'}; $has_time_hires = !$@; @@ -34,72 +40,37 @@ Test::Harness - Run Perl standard test scripts with statistics =head1 VERSION -Version 2.64 +Version 3.05 =cut -$VERSION = '2.64'; +$VERSION = '3.05'; # Backwards compatibility for exportable variable names. *verbose = *Verbose; *switches = *Switches; *debug = *Debug; -$ENV{HARNESS_ACTIVE} = 1; +$ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_VERSION} = $VERSION; END { + # For VMS. delete $ENV{HARNESS_ACTIVE}; delete $ENV{HARNESS_VERSION}; } -my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR}; - -# Stolen from Params::Util -sub _CLASS { - (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s) ? $_[0] : undef; -} - -# Strap Overloading -if ( $ENV{HARNESS_STRAPS_CLASS} ) { - die 'Set HARNESS_STRAP_CLASS, singular, not HARNESS_STRAPS_CLASS'; -} -my $HARNESS_STRAP_CLASS = $ENV{HARNESS_STRAP_CLASS} || 'Test::Harness::Straps'; -if ( $HARNESS_STRAP_CLASS =~ /\.pm$/ ) { - # "Class" is actually a filename, that should return the - # class name as its true return value. - $HARNESS_STRAP_CLASS = require $HARNESS_STRAP_CLASS; - if ( !_CLASS($HARNESS_STRAP_CLASS) ) { - die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' is not a valid class name"; - } -} -else { - # It is a class name within the current @INC - if ( !_CLASS($HARNESS_STRAP_CLASS) ) { - die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' is not a valid class name"; - } - eval "require $HARNESS_STRAP_CLASS"; - die $@ if $@; -} -if ( !$HARNESS_STRAP_CLASS->isa('Test::Harness::Straps') ) { - die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' must be a Test::Harness::Straps subclass"; -} - -$Strap = $HARNESS_STRAP_CLASS->new; - -sub strap { return $Strap }; - -@ISA = ('Exporter'); +@ISA = ('Exporter'); @EXPORT = qw(&runtests); @EXPORT_OK = qw(&execute_tests $verbose $switches); -$Verbose = $ENV{HARNESS_VERBOSE} || 0; -$Debug = $ENV{HARNESS_DEBUG} || 0; +$Verbose = $ENV{HARNESS_VERBOSE} || 0; +$Debug = $ENV{HARNESS_DEBUG} || 0; $Switches = '-w'; -$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; -$Columns--; # Some shells have trouble with a full line of text. -$Timer = $ENV{HARNESS_TIMER} || 0; +$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; +$Columns--; # Some shells have trouble with a full line of text. +$Timer = $ENV{HARNESS_TIMER} || 0; =head1 SYNOPSIS @@ -109,169 +80,354 @@ $Timer = $ENV{HARNESS_TIMER} || 0; =head1 DESCRIPTION -B<STOP!> If all you want to do is write a test script, consider -using Test::Simple. Test::Harness is the module that reads the -output from Test::Simple, Test::More and other modules based on -Test::Builder. You don't need to know about Test::Harness to use -those modules. - -Test::Harness runs tests and expects output from the test in a -certain format. That format is called TAP, the Test Anything -Protocol. It is defined in L<Test::Harness::TAP>. - -C<Test::Harness::runtests(@tests)> runs all the testscripts named -as arguments and checks standard output for the expected strings -in TAP format. +Although, for historical reasons, the L<Test::Harness> distribution +takes its name from this module it now exists only to provide +L<TAP::Harness> with an interface that is somewhat backwards compatible +with L<Test::Harness> 2.xx. If you're writing new code consider using +L<TAP::Harness> directly instead. -The F<prove> utility is a thin wrapper around Test::Harness. +Emulation is provided for C<runtests> and C<execute_tests> but the +pluggable 'Straps' interface that previous versions of L<Test::Harness> +supported is not reproduced here. Straps is now available as a stand +alone module: L<Test::Harness::Straps>. -=head2 Taint mode +See L<TAP::Parser> for the main documentation for this distribution. -Test::Harness will honor the C<-T> or C<-t> in the #! line on your -test files. So if you begin a test with: - - #!perl -T +=head1 FUNCTIONS -the test will be run with taint mode on. +The following functions are available. -=head2 Configuration variables. +=head2 runtests( @test_files ) -These variables can be used to configure the behavior of -Test::Harness. They are exported on request. +This runs all the given I<@test_files> and divines whether they passed +or failed based on their output to STDOUT (details above). It prints +out each individual test which failed along with a summary report and +a how long it all took. -=over 4 +It returns true if everything was ok. Otherwise it will C<die()> with +one of the messages in the DIAGNOSTICS section. -=item C<$Test::Harness::Verbose> +=cut -The package variable C<$Test::Harness::Verbose> is exportable and can be -used to let C<runtests()> display the standard output of the script -without altering the behavior otherwise. The F<prove> utility's C<-v> -flag will set this. +sub _has_taint { + my $test = shift; + return TAP::Parser::Source::Perl->get_taint( + TAP::Parser::Source::Perl->shebang($test) ); +} -=item C<$Test::Harness::switches> +sub _aggregate { + my ( $harness, $aggregate, @tests ) = @_; -The package variable C<$Test::Harness::switches> is exportable and can be -used to set perl command line options used for running the test -script(s). The default value is C<-w>. It overrides C<HARNESS_PERL_SWITCHES>. + # Don't propagate to our children + local $ENV{HARNESS_OPTIONS}; -=item C<$Test::Harness::Timer> + if (IS_VMS) { -If set to true, and C<Time::HiRes> is available, print elapsed seconds -after each test file. + # Jiggery pokery doesn't appear to work on VMS - so disable it + # pending investigation. + $harness->aggregate_tests( $aggregate, @tests ); + } + else { + my $path_sep = $Config{path_sep}; + my $path_pat = qr{$path_sep}; + my @extra_inc = _filtered_inc(); + + # Supply -I switches in taint mode + $harness->callback( + parser_args => sub { + my ( $args, $test ) = @_; + if ( _has_taint( $test->[0] ) ) { + push @{ $args->{switches} }, map {"-I$_"} _filtered_inc(); + } + } + ); -=back + my $previous = $ENV{PERL5LIB}; + local $ENV{PERL5LIB}; + if ($previous) { + push @extra_inc, split( $path_pat, $previous ); + } -=head2 Failure + if (@extra_inc) { + $ENV{PERL5LIB} = join( $path_sep, @extra_inc ); + } -When tests fail, analyze the summary report: + $harness->aggregate_tests( $aggregate, @tests ); + } +} - t/base..............ok - t/nonumbers.........ok - t/ok................ok - t/test-harness......ok - t/waterloo..........dubious - Test returned status 3 (wstat 768, 0x300) - DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19 - Failed 10/20 tests, 50.00% okay - Failed Test Stat Wstat Total Fail List of Failed - --------------------------------------------------------------- - t/waterloo.t 3 768 20 10 1 3 5 7 9 11 13 15 17 19 - Failed 1/5 test scripts, 80.00% okay. 10/44 subtests failed, 77.27% okay. +sub runtests { + my @tests = @_; -Everything passed but F<t/waterloo.t>. It failed 10 of 20 tests and -exited with non-zero status indicating something dubious happened. + # shield against -l + local ( $\, $, ); -The columns in the summary report mean: + my $harness = _new_harness(); + my $aggregate = TAP::Parser::Aggregator->new(); -=over 4 + _aggregate( $harness, $aggregate, @tests ); -=item B<Failed Test> + $harness->formatter->summary($aggregate); -The test file which failed. + my $total = $aggregate->total; + my $passed = $aggregate->passed; + my $failed = $aggregate->failed; -=item B<Stat> + my @parsers = $aggregate->parsers; -If the test exited with non-zero, this is its exit status. + my $num_bad = 0; + for my $parser (@parsers) { + $num_bad++ if $parser->has_problems; + } -=item B<Wstat> + die(sprintf( + "Failed %d/%d test programs. %d/%d subtests failed.\n", + $num_bad, scalar @parsers, $failed, $total + ) + ) if $num_bad; -The wait status of the test. + return $total && $total == $passed; +} -=item B<Total> +sub _canon { + my @list = sort { $a <=> $b } @_; + my @ranges = (); + my $count = scalar @list; + my $pos = 0; + + while ( $pos < $count ) { + my $end = $pos + 1; + $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1; + push @ranges, ( $end == $pos + 1 ) + ? $list[$pos] + : join( '-', $list[$pos], $list[ $end - 1 ] ); + $pos = $end; + } -Total number of tests expected to run. + return join( ' ', @ranges ); +} -=item B<Fail> +sub _new_harness { -Number which failed, either from "not ok" or because they never ran. + if ( defined( my $env_sw = $ENV{HARNESS_PERL_SWITCHES} ) ) { + $Switches .= ' ' . $env_sw if ( length($env_sw) ); + } -=item B<List of Failed> + # This is a bit crufty. The switches have all been joined into a + # single string so we have to try and recover them. + my ( @lib, @switches ); + for my $opt ( split( /\s+(?=-)/, $Switches ) ) { + if ( $opt =~ /^ -I (.*) $ /x ) { + push @lib, $1; + } + else { + push @switches, $opt; + } + } -A list of the tests which failed. Successive failures may be -abbreviated (ie. 15-20 to indicate that tests 15, 16, 17, 18, 19 and -20 failed). + # Do things the old way on VMS... + push @lib, _filtered_inc() if IS_VMS; + + my $args = { + timer => $Timer, + directives => $Directives, + lib => \@lib, + switches => \@switches, + verbosity => $Verbose, + }; + + if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) { + for my $opt ( split /:/, $env_opt ) { + if ( $opt =~ /^j(\d*)$/ ) { + $args->{jobs} = $1 || 9; + } + elsif ( $opt eq 'f' ) { + $args->{fork} = 1; + } + else { + die "Unknown HARNESS_OPTIONS item: $opt\n"; + } + } + } -=back + return TAP::Harness->new($args); +} +# Get the parts of @INC which are changed from the stock list AND +# preserve reordering of stock directories. +sub _filtered_inc { + my @inc = grep { !ref } @INC; #28567 -=head1 FUNCTIONS + if (IS_VMS) { -The following functions are available. + # VMS has a 255-byte limit on the length of %ENV entries, so + # toss the ones that involve perl_root, the install location + @inc = grep !/perl_root/i, @inc; -=head2 runtests( @test_files ) + } + elsif (IS_WIN32) { -This runs all the given I<@test_files> and divines whether they passed -or failed based on their output to STDOUT (details above). It prints -out each individual test which failed along with a summary report and -a how long it all took. + # Lose any trailing backslashes in the Win32 paths + s/[\\\/+]$// foreach @inc; + } -It returns true if everything was ok. Otherwise it will C<die()> with -one of the messages in the DIAGNOSTICS section. + my @default_inc = _default_inc(); -=cut + my @new_inc; + my %seen; + for my $dir (@inc) { + next if $seen{$dir}++; -sub runtests { - my(@tests) = @_; + if ( $dir eq ( $default_inc[0] || '' ) ) { + shift @default_inc; + } + else { + push @new_inc, $dir; + } - local ($\, $,); + shift @default_inc while @default_inc and $seen{ $default_inc[0] }; + } - my ($tot, $failedtests,$todo_passed) = execute_tests(tests => \@tests); - print get_results($tot, $failedtests,$todo_passed); + return @new_inc; +} - my $ok = _all_ok($tot); +{ - assert(($ok xor keys %$failedtests), - q{ok status jives with $failedtests}); + # Cache this to avoid repeatedly shelling out to Perl. + my @inc; - if (! $ok) { - die("Failed $tot->{bad}/$tot->{tests} test programs. " . - "@{[$tot->{max} - $tot->{ok}]}/$tot->{max} subtests failed.\n"); + sub _default_inc { + return @inc if @inc; + my $perl = $ENV{HARNESS_PERL} || $^X; + chomp( @inc = `$perl -le "print join qq[\\n], \@INC"` ); + return @inc; } - - return $ok; } -# my $ok = _all_ok(\%tot); -# Tells you if this test run is overall successful or not. - -sub _all_ok { - my($tot) = shift; +sub _check_sequence { + my @list = @_; + my $prev; + while ( my $next = shift @list ) { + return if defined $prev && $next <= $prev; + $prev = $next; + } - return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0; + return 1; } -# Returns all the files in a directory. This is shorthand for backwards -# compatibility on systems where C<glob()> doesn't work right. +sub execute_tests { + my %args = @_; -sub _globdir { - local *DIRH; + # TODO: Handle out option + + my $harness = _new_harness(); + my $aggregate = TAP::Parser::Aggregator->new(); + + my %tot = ( + bonus => 0, + max => 0, + ok => 0, + bad => 0, + good => 0, + files => 0, + tests => 0, + sub_skipped => 0, + todo => 0, + skipped => 0, + bench => undef, + ); + + # Install a callback so we get to see any plans the + #Â harness executes. + $harness->callback( + made_parser => sub { + my $parser = shift; + $parser->callback( + plan => sub { + my $plan = shift; + if ( $plan->directive eq 'SKIP' ) { + $tot{skipped}++; + } + } + ); + } + ); + + _aggregate( $harness, $aggregate, @{ $args{tests} } ); + + $tot{bench} = $aggregate->elapsed; + my @tests = $aggregate->descriptions; + + # TODO: Work out the circumstances under which the files + # and tests totals can differ. + $tot{files} = $tot{tests} = scalar @tests; + + my %failedtests = (); + my %todo_passed = (); + + for my $test (@tests) { + my ($parser) = $aggregate->parsers($test); + + my @failed = $parser->failed; + + my $wstat = $parser->wait; + my $estat = $parser->exit; + my $planned = $parser->tests_planned; + my @errors = $parser->parse_errors; + my $passed = $parser->passed; + my $actual_passed = $parser->actual_passed; + + my $ok_seq = _check_sequence( $parser->actual_passed ); + + # Duplicate exit, wait status semantics of old version + $estat ||= '' unless $wstat; + $wstat ||= ''; + + $tot{max} += ( $planned || 0 ); + $tot{bonus} += $parser->todo_passed; + $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed; + $tot{sub_skipped} += $parser->skipped; + $tot{todo} += $parser->todo; + + if ( @failed || $estat || @errors ) { + $tot{bad}++; + + my $huh_planned = $planned ? undef : '??'; + my $huh_errors = $ok_seq ? undef : '??'; + + $failedtests{$test} = { + 'canon' => $huh_planned + || $huh_errors + || _canon(@failed) + || '??', + 'estat' => $estat, + 'failed' => $huh_planned + || $huh_errors + || scalar @failed, + 'max' => $huh_planned || $planned, + 'name' => $test, + 'wstat' => $wstat + }; + } + else { + $tot{good}++; + } - opendir DIRH, shift; - my @f = readdir DIRH; - closedir DIRH; + my @todo = $parser->todo_passed; + if (@todo) { + $todo_passed{$test} = { + 'canon' => _canon(@todo), + 'estat' => $estat, + 'failed' => scalar @todo, + 'max' => scalar $parser->todo, + 'name' => $test, + 'wstat' => $wstat + }; + } + } - return @f; + return ( \%tot, \%failedtests, \%todo_passed ); } =head2 execute_tests( tests => \@test_files, out => \*FH ) @@ -316,624 +472,19 @@ C<$failed> should be empty if everything passed. =cut -sub execute_tests { - my %args = @_; - my @tests = @{$args{tests}}; - my $out = $args{out} || select(); - - # We allow filehandles that are symbolic refs - no strict 'refs'; - _autoflush($out); - _autoflush(\*STDERR); - - my %failedtests; - my %todo_passed; - - # Test-wide totals. - my(%tot) = ( - bonus => 0, - max => 0, - ok => 0, - files => 0, - bad => 0, - good => 0, - tests => scalar @tests, - sub_skipped => 0, - todo => 0, - skipped => 0, - bench => 0, - ); - - my @dir_files; - @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir; - my $run_start_time = new Benchmark; - - my $width = _leader_width(@tests); - foreach my $tfile (@tests) { - $Last_ML_Print = 0; # so each test prints at least once - my($leader, $ml) = _mk_leader($tfile, $width); - local $ML = $ml; - - print $out $leader; - - $tot{files}++; - - $Strap->{_seen_header} = 0; - if ( $Test::Harness::Debug ) { - print $out "# Running: ", $Strap->_command_line($tfile), "\n"; - } - my $test_start_time = $Timer ? time : 0; - my $results = $Strap->analyze_file($tfile) or - do { warn $Strap->{error}, "\n"; next }; - my $elapsed; - if ( $Timer ) { - $elapsed = time - $test_start_time; - if ( $has_time_hires ) { - $elapsed = sprintf( " %8d ms", $elapsed*1000 ); - } - else { - $elapsed = sprintf( " %8s s", $elapsed ? $elapsed : "<1" ); - } - } - else { - $elapsed = ""; - } - - # state of the current test. - my @failed = grep { !$results->details->[$_-1]{ok} } - 1..@{$results->details}; - my @todo_pass = grep { $results->details->[$_-1]{actual_ok} && - $results->details->[$_-1]{type} eq 'todo' } - 1..@{$results->details}; - - my %test = ( - ok => $results->ok, - 'next' => $Strap->{'next'}, - max => $results->max, - failed => \@failed, - todo_pass => \@todo_pass, - todo => $results->todo, - bonus => $results->bonus, - skipped => $results->skip, - skip_reason => $results->skip_reason, - skip_all => $Strap->{skip_all}, - ml => $ml, - ); - - $tot{bonus} += $results->bonus; - $tot{max} += $results->max; - $tot{ok} += $results->ok; - $tot{todo} += $results->todo; - $tot{sub_skipped} += $results->skip; - - my $estatus = $results->exit; - my $wstatus = $results->wait; - - if ( $results->passing ) { - # XXX Combine these first two - if ($test{max} and $test{skipped} + $test{bonus}) { - my @msg; - push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}") - if $test{skipped}; - if ($test{bonus}) { - my ($txt, $canon) = _canondetail($test{todo},0,'TODO passed', - @{$test{todo_pass}}); - $todo_passed{$tfile} = { - canon => $canon, - max => $test{todo}, - failed => $test{bonus}, - name => $tfile, - estat => '', - wstat => '', - }; - - push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded\n$txt"); - } - print $out "$test{ml}ok$elapsed\n ".join(', ', @msg)."\n"; - } - elsif ( $test{max} ) { - print $out "$test{ml}ok$elapsed\n"; - } - elsif ( defined $test{skip_all} and length $test{skip_all} ) { - print $out "skipped\n all skipped: $test{skip_all}\n"; - $tot{skipped}++; - } - else { - print $out "skipped\n all skipped: no reason given\n"; - $tot{skipped}++; - } - $tot{good}++; - } - else { - # List unrun tests as failures. - if ($test{'next'} <= $test{max}) { - push @{$test{failed}}, $test{'next'}..$test{max}; - } - # List overruns as failures. - else { - my $details = $results->details; - foreach my $overrun ($test{max}+1..@$details) { - next unless ref $details->[$overrun-1]; - push @{$test{failed}}, $overrun - } - } - - if ($wstatus) { - $failedtests{$tfile} = _dubious_return(\%test, \%tot, - $estatus, $wstatus); - $failedtests{$tfile}{name} = $tfile; - } - elsif ( $results->seen ) { - if (@{$test{failed}} and $test{max}) { - my ($txt, $canon) = _canondetail($test{max},$test{skipped},'Failed', - @{$test{failed}}); - print $out "$test{ml}$txt"; - $failedtests{$tfile} = { canon => $canon, - max => $test{max}, - failed => scalar @{$test{failed}}, - name => $tfile, - estat => '', - wstat => '', - }; - } - else { - print $out "Don't know which tests failed: got $test{ok} ok, ". - "expected $test{max}\n"; - $failedtests{$tfile} = { canon => '??', - max => $test{max}, - failed => '??', - name => $tfile, - estat => '', - wstat => '', - }; - } - $tot{bad}++; - } - else { - print $out "FAILED before any test output arrived\n"; - $tot{bad}++; - $failedtests{$tfile} = { canon => '??', - max => '??', - failed => '??', - name => $tfile, - estat => '', - wstat => '', - }; - } - } - - if (defined $Files_In_Dir) { - my @new_dir_files = _globdir $Files_In_Dir; - if (@new_dir_files != @dir_files) { - my %f; - @f{@new_dir_files} = (1) x @new_dir_files; - delete @f{@dir_files}; - my @f = sort keys %f; - print $out "LEAKED FILES: @f\n"; - @dir_files = @new_dir_files; - } - } - } # foreach test - $tot{bench} = timediff(new Benchmark, $run_start_time); - - $Strap->_restore_PERL5LIB; - - return(\%tot, \%failedtests, \%todo_passed); -} - -# Turns on autoflush for the handle passed -sub _autoflush { - my $flushy_fh = shift; - my $old_fh = select $flushy_fh; - $| = 1; - select $old_fh; -} - -=for private _mk_leader - - my($leader, $ml) = _mk_leader($test_file, $width); - -Generates the 't/foo........' leader for the given C<$test_file> as well -as a similar version which will overwrite the current line (by use of -\r and such). C<$ml> may be empty if Test::Harness doesn't think you're -on TTY. - -The C<$width> is the width of the "yada/blah.." string. - -=cut - -sub _mk_leader { - my($te, $width) = @_; - chomp($te); - $te =~ s/\.\w+$/./; - - if ($^O eq 'VMS') { - $te =~ s/^.*\.t\./\[.t./s; - } - my $leader = "$te" . '.' x ($width - length($te)); - my $ml = ""; - - if ( -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose ) { - $ml = "\r" . (' ' x 77) . "\r$leader" - } - - return($leader, $ml); -} - -=for private _leader_width - - my($width) = _leader_width(@test_files); - -Calculates how wide the leader should be based on the length of the -longest test name. - -=cut - -sub _leader_width { - my $maxlen = 0; - my $maxsuflen = 0; - foreach (@_) { - my $suf = /\.(\w+)$/ ? $1 : ''; - my $len = length; - my $suflen = length $suf; - $maxlen = $len if $len > $maxlen; - $maxsuflen = $suflen if $suflen > $maxsuflen; - } - # + 3 : we want three dots between the test name and the "ok" - return $maxlen + 3 - $maxsuflen; -} - -sub get_results { - my $tot = shift; - my $failedtests = shift; - my $todo_passed = shift; - - my $out = ''; - - my $bonusmsg = _bonusmsg($tot); - - if (_all_ok($tot)) { - $out .= "All tests successful$bonusmsg.\n"; - if ($tot->{bonus}) { - my($fmt_top, $fmt) = _create_fmts("Passed TODO",$todo_passed); - # Now write to formats - $out .= swrite( $fmt_top ); - for my $script (sort keys %{$todo_passed||{}}) { - my $Curtest = $todo_passed->{$script}; - $out .= swrite( $fmt, @{ $Curtest }{qw(name estat wstat max failed canon)} ); - } - } - } - elsif (!$tot->{tests}){ - die "FAILED--no tests were run for some reason.\n"; - } - elsif (!$tot->{max}) { - my $blurb = $tot->{tests}==1 ? "script" : "scripts"; - die "FAILED--$tot->{tests} test $blurb could be run, ". - "alas--no output ever seen\n"; - } - else { - my $subresults = sprintf( " %d/%d subtests failed.", - $tot->{max} - $tot->{ok}, $tot->{max} ); - - my($fmt_top, $fmt1, $fmt2) = _create_fmts("Failed Test",$failedtests); - - # Now write to formats - $out .= swrite( $fmt_top ); - for my $script (sort keys %$failedtests) { - my $Curtest = $failedtests->{$script}; - $out .= swrite( $fmt1, @{ $Curtest }{qw(name estat wstat max failed canon)} ); - $out .= swrite( $fmt2, $Curtest->{canon} ); - } - if ($tot->{bad}) { - $bonusmsg =~ s/^,\s*//; - $out .= "$bonusmsg.\n" if $bonusmsg; - $out .= "Failed $tot->{bad}/$tot->{tests} test scripts.$subresults\n"; - } - } - - $out .= sprintf("Files=%d, Tests=%d, %s\n", - $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop')); - return $out; -} - -sub swrite { - my $format = shift; - $^A = ''; - formline($format,@_); - my $out = $^A; - $^A = ''; - return $out; -} - - -my %Handlers = ( - header => \&header_handler, - test => \&test_handler, - bailout => \&bailout_handler, -); - -$Strap->set_callback(\&strap_callback); -sub strap_callback { - my($self, $line, $type, $totals) = @_; - print $line if $Verbose; - - my $meth = $Handlers{$type}; - $meth->($self, $line, $type, $totals) if $meth; -}; - - -sub header_handler { - my($self, $line, $type, $totals) = @_; - - warn "Test header seen more than once!\n" if $self->{_seen_header}; - - $self->{_seen_header}++; - - warn "1..M can only appear at the beginning or end of tests\n" - if $totals->seen && ($totals->max < $totals->seen); -}; - -sub test_handler { - my($self, $line, $type, $totals) = @_; - - my $curr = $totals->seen; - my $next = $self->{'next'}; - my $max = $totals->max; - my $detail = $totals->details->[-1]; - - if( $detail->{ok} ) { - _print_ml_less("ok $curr/$max"); - - if( $detail->{type} eq 'skip' ) { - $totals->set_skip_reason( $detail->{reason} ) - unless defined $totals->skip_reason; - $totals->set_skip_reason( 'various reasons' ) - if $totals->skip_reason ne $detail->{reason}; - } - } - else { - _print_ml("NOK $curr/$max"); - } - - if( $curr > $next ) { - print "Test output counter mismatch [test $curr]\n"; - } - elsif( $curr < $next ) { - print "Confused test output: test $curr answered after ". - "test ", $next - 1, "\n"; - } - -}; - -sub bailout_handler { - my($self, $line, $type, $totals) = @_; - - die "FAILED--Further testing stopped" . - ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n"); -}; - - -sub _print_ml { - print join '', $ML, @_ if $ML; -} - - -# Print updates only once per second. -sub _print_ml_less { - my $now = CORE::time; - if ( $Last_ML_Print != $now ) { - _print_ml(@_); - $Last_ML_Print = $now; - } -} - -sub _bonusmsg { - my($tot) = @_; - - my $bonusmsg = ''; - $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : ''). - " UNEXPECTEDLY SUCCEEDED)") - if $tot->{bonus}; - - if ($tot->{skipped}) { - $bonusmsg .= ", $tot->{skipped} test" - . ($tot->{skipped} != 1 ? 's' : ''); - if ($tot->{sub_skipped}) { - $bonusmsg .= " and $tot->{sub_skipped} subtest" - . ($tot->{sub_skipped} != 1 ? 's' : ''); - } - $bonusmsg .= ' skipped'; - } - elsif ($tot->{sub_skipped}) { - $bonusmsg .= ", $tot->{sub_skipped} subtest" - . ($tot->{sub_skipped} != 1 ? 's' : '') - . " skipped"; - } - return $bonusmsg; -} - -# Test program go boom. -sub _dubious_return { - my($test, $tot, $estatus, $wstatus) = @_; - - my $failed = '??'; - my $canon = '??'; - - printf "$test->{ml}dubious\n\tTest returned status $estatus ". - "(wstat %d, 0x%x)\n", - $wstatus,$wstatus; - print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS'; - - $tot->{bad}++; - - if ($test->{max}) { - if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) { - print "\tafter all the subtests completed successfully\n"; - $failed = 0; # But we do not set $canon! - } - else { - push @{$test->{failed}}, $test->{'next'}..$test->{max}; - $failed = @{$test->{failed}}; - (my $txt, $canon) = _canondetail($test->{max},$test->{skipped},'Failed',@{$test->{failed}}); - print "DIED. ",$txt; - } - } - - return { canon => $canon, max => $test->{max} || '??', - failed => $failed, - estat => $estatus, wstat => $wstatus, - }; -} - - -sub _create_fmts { - my $failed_str = shift; - my $failedtests = shift; - - my ($type) = split /\s/,$failed_str; - my $short = substr($type,0,4); - my $total = $short eq 'Pass' ? 'TODOs' : 'Total'; - my $middle_str = " Stat Wstat $total $short "; - my $list_str = "List of $type"; - - # Figure out our longest name string for formatting purposes. - my $max_namelen = length($failed_str); - foreach my $script (keys %$failedtests) { - my $namelen = length $failedtests->{$script}->{name}; - $max_namelen = $namelen if $namelen > $max_namelen; - } - - my $list_len = $Columns - length($middle_str) - $max_namelen; - if ($list_len < length($list_str)) { - $list_len = length($list_str); - $max_namelen = $Columns - length($middle_str) - $list_len; - if ($max_namelen < length($failed_str)) { - $max_namelen = length($failed_str); - $Columns = $max_namelen + length($middle_str) + $list_len; - } - } - - my $fmt_top = sprintf("%-${max_namelen}s", $failed_str) - . $middle_str - . $list_str . "\n" - . "-" x $Columns - . "\n"; - - my $fmt1 = "@" . "<" x ($max_namelen - 1) - . " @>> @>>>> @>>>> @>>> " - . "^" . "<" x ($list_len - 1) . "\n"; - my $fmt2 = "~~" . " " x ($Columns - $list_len - 2) . "^" - . "<" x ($list_len - 1) . "\n"; - - return($fmt_top, $fmt1, $fmt2); -} - -sub _canondetail { - my $max = shift; - my $skipped = shift; - my $type = shift; - my @detail = @_; - my %seen; - @detail = sort {$a <=> $b} grep !$seen{$_}++, @detail; - my $detail = @detail; - my @result = (); - my @canon = (); - my $min; - my $last = $min = shift @detail; - my $canon; - my $uc_type = uc($type); - if (@detail) { - for (@detail, $detail[-1]) { # don't forget the last one - if ($_ > $last+1 || $_ == $last) { - push @canon, ($min == $last) ? $last : "$min-$last"; - $min = $_; - } - $last = $_; - } - local $" = ", "; - push @result, "$uc_type tests @canon\n"; - $canon = join ' ', @canon; - } - else { - push @result, "$uc_type test $last\n"; - $canon = $last; - } - - return (join("", @result), $canon) - if $type=~/todo/i; - push @result, "\t$type $detail/$max tests, "; - if ($max) { - push @result, sprintf("%.2f",100*(1-$detail/$max)), "% okay"; - } - else { - push @result, "?% okay"; - } - my $ender = 's' x ($skipped > 1); - if ($skipped) { - my $good = $max - $detail - $skipped; - my $skipmsg = " (less $skipped skipped test$ender: $good okay, "; - if ($max) { - my $goodper = sprintf("%.2f",100*($good/$max)); - $skipmsg .= "$goodper%)"; - } - else { - $skipmsg .= "?%)"; - } - push @result, $skipmsg; - } - push @result, "\n"; - my $txt = join "", @result; - return ($txt, $canon); -} - 1; __END__ - =head1 EXPORT -C<&runtests> is exported by Test::Harness by default. +C<&runtests> is exported by C<Test::Harness> by default. C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are exported upon request. -=head1 DIAGNOSTICS - -=over 4 - -=item C<All tests successful.\nFiles=%d, Tests=%d, %s> - -If all tests are successful some statistics about the performance are -printed. - -=item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.> - -For any single script that has failing subtests statistics like the -above are printed. - -=item C<Test returned status %d (wstat %d)> - -Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> -and C<$?> are printed in a message similar to the above. - -=item C<Failed 1 test, %.2f%% okay. %s> - -=item C<Failed %d/%d tests, %.2f%% okay. %s> - -If not all tests were successful, the script dies with one of the -above messages. - -=item C<FAILED--Further testing stopped: %s> - -If a single subtest decides that further testing will not make sense, -the script dies with this message. - -=back - -=head1 ENVIRONMENT VARIABLES THAT TEST::HARNESS SETS +=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS -Test::Harness sets these before executing the individual tests. +C<Test::Harness> sets these before executing the individual tests. =over 4 @@ -944,7 +495,7 @@ are being executed through the harness or by any other means. =item C<HARNESS_VERSION> -This is the version of Test::Harness. +This is the version of C<Test::Harness>. =back @@ -952,61 +503,6 @@ This is the version of Test::Harness. =over 4 -=item C<HARNESS_COLUMNS> - -This value will be used for the width of the terminal. If it is not -set then it will default to C<COLUMNS>. If this is not set, it will -default to 80. Note that users of Bourne-sh based shells will need to -C<export COLUMNS> for this module to use that variable. - -=item C<HARNESS_COMPILE_TEST> - -When true it will make harness attempt to compile the test using -C<perlcc> before running it. - -B<NOTE> This currently only works when sitting in the perl source -directory! - -=item C<HARNESS_DEBUG> - -If true, Test::Harness will print debugging information about itself as -it runs the tests. This is different from C<HARNESS_VERBOSE>, which prints -the output from the test being run. Setting C<$Test::Harness::Debug> will -override this, or you can use the C<-d> switch in the F<prove> utility. - -=item C<HARNESS_FILELEAK_IN_DIR> - -When set to the name of a directory, harness will check after each -test whether new files appeared in that directory, and report them as - - LEAKED FILES: scr.tmp 0 my.db - -If relative, directory name is with respect to the current directory at -the moment runtests() was called. Putting absolute path into -C<HARNESS_FILELEAK_IN_DIR> may give more predictable results. - -=item C<HARNESS_NOTTY> - -When set to a true value, forces it to behave as though STDOUT were -not a console. You may need to set this if you don't want harness to -output more frequent progress messages using carriage returns. Some -consoles may not handle carriage returns properly (which results in a -somewhat messy output). - -=item C<HARNESS_PERL> - -Usually your tests will be run by C<$^X>, the currently-executing Perl. -However, you may want to have it run by a different executable, such as -a threading perl, or a different version. - -If you're using the F<prove> utility, you can use the C<--perl> switch. - -=item C<HARNESS_PERL_SWITCHES> - -Its value will be prepended to the switches used to invoke perl on -each test. For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will -run all tests with all warnings enabled. - =item C<HARNESS_TIMER> Setting this to true will make the harness display the number of @@ -1015,155 +511,60 @@ switch. =item C<HARNESS_VERBOSE> -If true, Test::Harness will output the verbose results of running -its tests. Setting C<$Test::Harness::verbose> will override this, -or you can use the C<-v> switch in the F<prove> utility. - -If true, Test::Harness will output the verbose results of running +If true, C<Test::Harness> will output the verbose results of running its tests. Setting C<$Test::Harness::verbose> will override this, or you can use the C<-v> switch in the F<prove> utility. -=item C<HARNESS_STRAP_CLASS> +=item C<HARNESS_OPTIONS> -Defines the Test::Harness::Straps subclass to use. The value may either -be a filename or a class name. +Provide additional options to the harness. Currently supported options are: -If HARNESS_STRAP_CLASS is a class name, the class must be in C<@INC> -like any other class. +=over -If HARNESS_STRAP_CLASS is a filename, the .pm file must return the name -of the class, instead of the canonical "1". +=item C<< j<n> >> -=back - -=head1 EXAMPLE - -Here's how Test::Harness tests itself - - $ cd ~/src/devel/Test-Harness - $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose); - $verbose=0; runtests @ARGV;' t/*.t - Using /home/schwern/src/devel/Test-Harness/blib - t/base..............ok - t/nonumbers.........ok - t/ok................ok - t/test-harness......ok - All tests successful. - Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU) - -=head1 SEE ALSO - -The included F<prove> utility for running test scripts from the command line, -L<Test> and L<Test::Simple> for writing test scripts, L<Benchmark> for -the underlying timing routines, and L<Devel::Cover> for test coverage -analysis. - -=head1 TODO - -Provide a way of running tests quietly (ie. no printing) for automated -validation of tests. This will probably take the form of a version -of runtests() which rather than printing its output returns raw data -on the state of the tests. (Partially done in Test::Harness::Straps) - -Document the format. - -Fix HARNESS_COMPILE_TEST without breaking its core usage. +Run <n> (default 9) parallel jobs. -Figure a way to report test names in the failure summary. +=item C<< f >> -Rework the test summary so long test names are not truncated as badly. -(Partially done with new skip test styles) +Use forked parallelism. -Add option for coverage analysis. - -Trap STDERR. - -Implement Straps total_results() - -Remember exit code - -Completely redo the print summary code. - -Straps->analyze_file() not taint clean, don't know if it can be - -Fix that damned VMS nit. - -Add a test for verbose. +=back -Change internal list of test results to a hash. +Multiple options may be separated by colons: -Fix stats display when there's an overrun. + HARNESS_OPTIONS=j9:f make test -Fix so perls with spaces in the filename work. +=back -Keeping whittling away at _run_all_tests() +=head1 SEE ALSO -Clean up how the summary is printed. Get rid of those damned formats. +L<TAP::Harness> =head1 BUGS Please report any bugs or feature requests to C<bug-test-harness at rt.cpan.org>, or through the web interface at -L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. -I will be notified, and then you'll automatically be notified of progress on -your bug as I make changes. - -=head1 SUPPORT - -You can find documentation for this module with the F<perldoc> command. - - perldoc Test::Harness - -You can get docs for F<prove> with - - prove --man - -You can also look for information at: - -=over 4 - -=item * AnnoCPAN: Annotated CPAN documentation - -L<http://annocpan.org/dist/Test-Harness> - -=item * CPAN Ratings - -L<http://cpanratings.perl.org/d/Test-Harness> - -=item * RT: CPAN's request tracker - -L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Harness> - -=item * Search CPAN - -L<http://search.cpan.org/dist/Test-Harness> - -=back - -=head1 SOURCE CODE - -The source code repository for Test::Harness is at -L<http://svn.perl.org/modules/Test-Harness>. +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be +notified, and then you'll automatically be notified of progress on your bug +as I make changes. =head1 AUTHORS -Either Tim Bunce or Andreas Koenig, we don't know. What we know for -sure is, that it was inspired by Larry Wall's F<TEST> script that came -with perl distributions for ages. Numerous anonymous contributors -exist. Andreas Koenig held the torch for many years, and then -Michael G Schwern. +Andy Armstrong C<< <andy@hexten.net> >> -Current maintainer is Andy Lester C<< <andy at petdance.com> >>. +L<Test::Harness> (on which this module is based) has this attribution: -=head1 COPYRIGHT + Either Tim Bunce or Andreas Koenig, we don't know. What we know for + sure is, that it was inspired by Larry Wall's F<TEST> script that came + with perl distributions for ages. Numerous anonymous contributors + exist. Andreas Koenig held the torch for many years, and then + Michael G Schwern. -Copyright 2002-2006 -by Michael G Schwern C<< <schwern at pobox.com> >>, -Andy Lester C<< <andy at petdance.com> >>. +=head1 LICENCE AND COPYRIGHT -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. +Copyright (c) 2007, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved. -See L<http://www.perl.com/perl/misc/Artistic.html>. +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. -=cut diff --git a/lib/Test/Harness/Assert.pm b/lib/Test/Harness/Assert.pm deleted file mode 100644 index 29f6c7ada9..0000000000 --- a/lib/Test/Harness/Assert.pm +++ /dev/null @@ -1,64 +0,0 @@ -package Test::Harness::Assert; - -use strict; -require Exporter; -use vars qw($VERSION @EXPORT @ISA); - -$VERSION = '0.02'; - -@ISA = qw(Exporter); -@EXPORT = qw(assert); - - -=head1 NAME - -Test::Harness::Assert - simple assert - -=head1 SYNOPSIS - - ### FOR INTERNAL USE ONLY ### - - use Test::Harness::Assert; - - assert( EXPR, $name ); - -=head1 DESCRIPTION - -A simple assert routine since we don't have Carp::Assert handy. - -B<For internal use by Test::Harness ONLY!> - -=head1 FUNCTIONS - -=head2 C<assert()> - - assert( EXPR, $name ); - -If the expression is false the program aborts. - -=cut - -sub assert ($;$) { - my($assert, $name) = @_; - - unless( $assert ) { - require Carp; - my $msg = 'Assert failed'; - $msg .= " - '$name'" if defined $name; - $msg .= '!'; - Carp::croak($msg); - } - -} - -=head1 AUTHOR - -Michael G Schwern C<< <schwern at pobox.com> >> - -=head1 SEE ALSO - -L<Carp::Assert> - -=cut - -1; diff --git a/lib/Test/Harness/Changes b/lib/Test/Harness/Changes index 9be4fcdedb..e397b88507 100644 --- a/lib/Test/Harness/Changes +++ b/lib/Test/Harness/Changes @@ -1,727 +1,568 @@ -Revision history for Perl extension Test::Harness - -NEXT - [FIXES] - * prove's --perl=/path/to/file wasn't taking a value. - * prove's version number was not getting incremented. From now on, - prove's $VERSION will match Test::Harness's $VERSION, and I added - a test to make sure this is the case. - - [ENHANCEMENTS] - * Added test straps overload via HARNESS_STRAP_OVERLOAD environment - variable. prove now takes a --strap=class parameter. Thanks, - Adam Kennedy. - -2.63_01 Fri Jun 30 16:59:50 CDT 2006 - [ENHANCEMENTS] - * Failed tests used to say "NOK x", and now say "NOK x/y". - Thanks to Will Coleda. - - * Added the Test::Harness::Results object, so we have a well-defined - object, and not just a hash that we pass around. Thanks to YAPC::NA - 2006 Hackathon! - -2.62 Thu Jun 8 14:11:57 CDT 2006 - [FIXES] - * Restored the behavior of dying if any subtests failed. This is a - pretty crucial bug that I should have fixed long ago. Not having this - means that CPANPLUS will install modules even if their tests fail. :-( - -2.60 Wed May 24 14:48:44 CDT 2006 - [FIXES] - * Fixed the headers in the summary failure table. - -2.58 Sat May 13 22:53:53 CDT 2006 - No changes. Released to the world with a non-beta number. - -2.57_06 Sun Apr 23 00:55:43 CDT 2006 - [THINGS THAT MIGHT BREAK YOUR CODE] - * Anything that displays a percentage of tests passed has been - removed. Output at the end of failing runs is now different. - - [FIXES] - * Fixed the TODO-passing patch from 2.57_05. - - [ENHANCEMENTS] - * The unnecessary display of percentages of tests passing and failing - have been removed. Tests are not a percentage game. - - * Caches the results of _default_inc(), which is expensive because - of shelling out to get the pathnames. Benchmarking was showing that - 15% of Test::Harness's time was spent in this function. For test - suites with many test files, this can be significant. With this - speedup, the "make test" for the Perl core speeds up 2.5%. - Thanks to Nicholas Clark for finding this. - - [DOCUMENTATION] - * Fixed HARNESS_PERL_SWITCHES typo. Thanks, Andreas Koenig. - - * Added docs on HARNESS_TIMER and --timer. Thanks, Mike O'Regan. - -2.57_05 Wed Apr 19 00:31:10 CDT 2006 - [ENHANCEMENTS] - * Now shows details of the tests that unexpectedly pass, instead of - just giving a number. Thanks, demerphq! - - [INTERNALS] - * Fixed globbing to work under Perls before 5.6.0. Before Perl 5.6.0, - prove just uses the internal glob() function. - -2.57_04 Mon Apr 17 13:35:10 CDT 2006 - [ENHANCEMENTS] - * prove's globbing is now done with File::Glob::bsd_glob(). - Otherwise, "prove c:\program files\svk\t\*" fails because glob() - considers it to be two patterns, splitting on whitespace. Thanks to - Audrey Tang. - - [DOCUMENTATION] - * Added information about other TAP implementations in other languages. - -2.57_03 Dec 31 2005 - - [THINGS THAT MAY BREAK YOUR CODE] - * Internal functions _run_all_tests() and _show_results() no longer - exist. You shouldn't have been using them anyway since they're - prepended with underscores. - - [INTERNALS] - * Added the ability to send test output to a filehandle of - one's choosing. Two internal functions are now exposed: - execute_tests() and get_results() (formerly _run_all_tests() and - _show_results()). This should allow CPANPLUS to work properly - with Module::Build. Thanks to Ken Williams. - - [DOCUMENTATION] - * Hid the documentation for the private methods in Test::Harness::Straps. - -2.57_02 Fri Dec 30 23:51:17 CST 2005 - [THINGS THAT MAY BREAK YOUR CODE] - * prove's --ext option has been removed. I'm betting that nobody used it. - - [ENHANCEMENTS] - * prove can now take -w and -W switches, analogous to those in perl. - This means that "prove -wlb t/*.t" is exactly the same as "make test". - Thanks to Rob Kinyon. - * Started a Test::Harness::Util module for code that may be reused - by other Harness-using modules. - - [INTERNALS] - * The t/prove*.t tests now use $^X to call prove. Thanks to Yves Orton. - * Test::Harness::Straps no longer uses Win32::GetShortPathName(). - Thanks to Gisle Aas. - -2.57_01 Mon Dec 26 01:39:07 CST 2005 - [FIXES] - * Removed code and docs mentioning HARNESS_IGNORE_EXITCODE, which - is not used anywhere. - - [ENHANCEMENTS] - * If we have hi-res timings, then they're shown in integer - milliseconds, rather than fractional seconds. - - * Added the --perl switch to prove. - - [DOCUMENTATION] - * Added links to CPAN support sites. - -2.56 Wed Sep 28 16:04:00 CDT 2005 - [FIXES] - * Incorporate bleadperl patch to fix Test::Harness on VMS. - -2.54 Wed Sep 28 09:52:19 CDT 2005 - [FIXES] - * Test counts were wrong, so wouldn't install on Perls < 5.8.0. - -2.53_02 Thu Aug 25 21:37:01 CDT 2005 - [FIXES] - * File order in prove is now sorted within the directory. It's not - the sorting that's important as much as the deterministic results. - Thanks to Adam Kennedy and Casey West for pointing this out, - independently of each other, with 12 hours of the other. - - [INTERNALS] - * Fix calls to podusage() to not use the DATA typeglob. Thanks sungo. - -2.53_01 Sun Jul 10 10:45:27 CDT 2005 - [FIXES] - * If we go over 100,000 tests, it used to print out a warning for - every test over 100,000. Now, we stop after the first. Thanks to - Sebastien Aperghis-Tramoni. - -2.52 Sun Jun 26 23:05:19 CDT 2005 - No changes - -2.51_02 - [ENHANCEMENTS] - * The Test::Harness timer is now off by default. Set HARNESS_TIMER - true if you want it. Added --timer flag to prove. - -2.50_01 - [FIXES] - * Call CORE::time() to figure out if we should print when we're - printing once per second. Otherwise, we're using Time::HiRes' - version of it. Thanks, Nicholas Clark. - -2.50 Tue Jun 21 14:32:12 CDT 2005 - [FIXES] - * Added some includes in t/strap-analyze.t to make Cygwin happy. - -2.49_02 Tue Jun 21 09:54:44 CDT 2005 - [FIXES] - * Added some includes in t/test_harness.t to make Cygwin happy. - -2.49_01 Fri Jun 10 15:37:31 CDT 2005 - [ENHANCEMENTS] - * Now shows elapsed time in 1000ths of a second if Time::HiRes - is available. - - [FIXES] - * Test::Harness::Iterator didn't have a 1; at the end. Thanks to - Steve Peters for finding it. - -2.48 Fri Apr 22 22:41:46 CDT 2005 - Released after weeks of non-complaint. - -2.47_03 Wed Mar 2 16:52:55 CST 2005 - [THINGS THAT MIGHT BREAK YOUR CODE] - * Test::Harness now requires Perl 5.005_03 or above. - - [FIXES] - * Fixed incorrect "confused by tests in wrong order" error in 2.47_02. - -2.47_02 Tue Mar 1 23:15:47 CST 2005 - [THINGS THAT MIGHT BREAK YOUR CODE] - * Test directives for skip tests used to be anything that matches - /^skip/i, like the word "skipped", but now it must match - /^skip\s+/i. - - [ENHANCEMENTS] - * T::H now sets environment variable HARNESS_VERSION, in case a test - program wants to know what version of T::H it's running under. - -2.47_01 Mon Feb 21 01:14:13 CST 2005 - [FIXES] - * Fixed a problem submitted by Craig Berry: - - Several of the Test::Harness tests now fail on VMS with the - following warning: - - Can't find string terminator "]" anywhere before EOF at -e line 1. - - The problem is that when a command is piped to the shell and that - command has a newline character embedded in it, the part after - the newline is invisible to the shell. The patch below corrects - that by escaping the newline so it is not subject to variable - interpolation until it gets to the child's Perl one-liner. - - [ENHANCEMENTS] - * Test::Harness::Straps now has diagnostic gathering without changing - how tests are run. It also adds these messages by default. - Note that the new method, _is_diagnostic(), is for internal - use only. It may change soon. Thanks to chromatic. - - [DOCUMENTATION] - * Expanded Test::Harness::TAP.pod, and added examples. - - * Fixed a crucial documentation typo in Test::Harness::Straps. - -2.46 Thu Jan 20 11:50:59 CST 2005 - Released. - -2.45_02 Fri Dec 31 14:57:33 CST 2004 - [ENHANCEMENTS] - * Turns off buffering on both STDERR and STDOUT, so that the two - output handles don't get out of sync with each other. Thanks to - David Wheeler. - - * No longer requires, or supports, the HARNESS_OK_SLOW environment - variable. Test counts are only updated once per second, which - used to require having HARNESS_OK_SLOW set. - -2.45_01 Fri Dec 17 22:39:17 CST 2004 - [THINGS THAT MIGHT BREAK YOUR CODE] - * Test::Harness now requires Perl 5.004_05. - - * We no longer try to print a stack if a coredump is detected. - - [FIXES] - * Reverted Test::Harness::Iterator::next()'s use of readline, since - it fails under Perl 5.5.4. - - * We no longer try to print a stack if a coredump is detected. - This means that the external problems we've had with wait.ph - now disappear. This resolves a number of problems that various - Linux distros have, and closes a couple of RT tickets like #2729 - and #7716. - - [ENHANCEMENTS] - * Added Test::Harness->strap() method to access the internal strap. - - [DOCUMENTATION] - * Obfuscated the rt.cpan.org email address. The damage is already - done, but at least we'll have it hidden going forward. - -2.44 Tue Nov 30 18:38:17 CST 2004 - [INTERNALS] - * De-anonymized the callbacks and handlers in Test::Harness, mostly - so I can profile better. - - * Checks _is_header() only if _is_line() fails first. No point - in checking every line of the input for something that can only - occur once. - - * Inline the _detailize() function, which was getting called once - per line of input. Reduced execution time about 5-7%. - - * Removed unnecessary temporary variables in Test::Harness::Straps - and in Test::Harness::Iterator. - -2.43_02 Thu Nov 25 00:20:36 CST 2004 - [ENHANCEMENTS] - * Added more debug output if $Test::Harness::Debug is on. - - [FIXES] - * Test::Harness now removes default paths from the paths that it - sets in PERL5LIB. This fixes RT #5649. Thanks, Schwern. - - [THINGS THAT MIGHT BREAK YOUR CODE] - * Test::Harness::Straps' constructor no longer will work as an - object method. You can't say $strap->new any more, but that's - OK because you never really wanted to anyway. - -2.43_01 - [FIXES] - * Added workaround for local $ENV{} bug on Cygwin to - t/prove-switches.t. See the following RT tickets for details. - - https://rt.cpan.org/Ticket/Display.html?id=6452 - http://rt.perl.org/rt3/Ticket/Display.html?id=30952 - - -2.42 Wed Apr 28 22:13:11 CDT 2004 - [ENHANCEMENTS] - * prove -v now sets TEST_VERBOSE in case your tests rely on them. - * prove globs the command line, since Win32's shell doesn't. - - [FIXES] - * Cross-platform test fixes on t/prove-globbing.t - - -2.40 Tue Dec 30 20:38:59 CST 2003 - [FIXES] - * Test::Harness::Straps should now properly quote on VMS. - - [ENHANCEMENTS] - * prove now takes a -l option to add lib/ to @INC. Now when you're - building a module, you don't have to do a make before you run - the prove. Thanks to David Wheeler for the idea. - - [INTERNALS] - * Internal functions corestatus() and canonfailed() prepended with - underscores, to indicate such. - - * Gratuitous text-only changes in Test::Harness::Iterator. - - * All tests now do their use_ok() in a BEGIN block. Some of the - use_ok() calls were too much of a hassle to put into a BEGIN block, - so I changed them to regular use calls. - - -2.38 Mon Nov 24 22:36:18 CST 2003 - Released. See changes below. - -2.37_03 Tue Nov 18 23:51:38 CST 2003 - [ENHANCEMENTS] - * prove -V now shows the Perl version being used. - * Now there's a HARNESS_DEBUG flag that shows diagnostics as the - harness runs the tests. This is different from HARNESS_VERBOSE, - which shows test output, but not information about the harness +Revision history for Test-Harness + +3.05 2007-12-09 + - Skip unicode.t if Encode unavailable + - Support for .proverc files. + - Clarified prove documentation. + +3.04 2007-12-02 + - Fixed output leakage with really_quiet set. + - Progress reports for tests without plans now show + "143/?" instead of "143/0". + - Made TAP::Harness::runtests support aliases for test names. + - Made it possible to pass command line args to test programs + from prove, TAP::Harness, TAP::Parser. + - Added --state switch to prove. + +3.03 2007-11-17 + - Fixed some little bugs-waiting-to-happen inside + TAP::Parser::Grammar. + - Added parser_args callback to TAP::Harness. + - Made @INC propagation even more compatible with 2.64 so that + parrot still works *and* #30796 is fixed. + +3.02 2007-11-15 + - Process I/O now unbuffered, uses sysread, plays better with + select. Fixes #30740. + - Made Test::Harness @INC propagation more compatible with 2.64. + Was breaking Parrot's test suite. + - Added HARNESS_OPTIONS (#30676) + +3.01 2007-11-12 + - Fix for RHEL incpush.patch related failure. + - Output real time of test completion with --timer + - prove -b adds blib/auto to @INC + - made SKIP plan parsing even more liberal for pre-v13 TAP + +3.00 2007-11-06 + - Non-dev release. No changes since 2.99_09. + +2.99_09 2007-11-05 + - Implemented TODO-in-PLAN syntax for TAP version 12 and earlier. + +2.99_08 2007-11-04 + - Tiny changes. New version pushed to get some smoke coverage. + +2.99_07 2007-11-01 + - Fix for #21938: Unable to handle circular links + - Fix for #24926: prove -b and -l should use absolute paths + - Fixed prove switches. Big oops. How the hell did we miss that? + - Consolidated quiet, really_quiet, verbose into verbosity. + - Various VMS related fixes to tests + +2.99_06 2007-10-30 + - Added skip_all method to TAP::Parser. + - Display reason for skipped tests. + - make test now self tests. + +2.99_05 2007-10-30 + - Fix for occasional rogue -1 exit code on Windows. + - Fix for @INC handling under CPANPLUS. + - Added real time to prove --timer output + - Improved prove error message in case where 't' not found and + no tests named. + +2.99_04 2007-10-11 + - Fixed bug where 'All tests successful' would not be printed if bonus + tests are seen. + - Fixed bug where 'Result: FAIL' would be printed at the end of a test + run if there were unexpectedly succeeding tests. + - Added -M, -P switches to allow arbitrary modules to be loaded + by prove. We haven't yet defined what they'll do once they + load but it's a start... + - Added testing under simulated non-forking platforms. + +2.99_03 2007-10-06 + - Refactored all display specific code out of TAP::Harness. + - Relaxed strict parsing of skip plan for pre v13 TAP. + - Elapsed hi-res time is now displayed in integer milliseconds + instead of fractional seconds. + - prove stops running if any command-line switches are invalid. + - prove -v would try to print an undef. + - Added support for multiplexed and forked parallel tests. Use + prove -j 9 to run tests in parallel and prove -j 9 --fork to + fork. These features are experimental and currently + unavailable on Windows. + - Rationalized the management of the environment that we give to + test scripts (PERL5LIB, PERL5OPT, switches). + - Fixed handling of STDIN (we no longer close it) for test + scripts. + - Performance enhancements. Parser is now 30% - 40% faster. + +2.99_02 2007-09-07 + - Ensure prove (and App::Prove) sort any recursively + discovered tests + - It is now possible to register multiple callback handlers for + a particular event. + - Added before_runtests, after_runtests callbacks to + TAP::Harness. + - Moved logic of prove program into App::Prove. + - Added simple machine readable summary. + - Performance improvement: The processing pipeline within + TAP::Parser is now a closure which speeds up access to the + various attribtes it needs. + - Performance improvement: Test count spinner now updates + exponentially less frequently as the count increases which + saves a lot of I/O on big tests. + - More improvements in test coverage from Leif. + - Fixes to TAP spooling - now captures YAML blocks correctly. + - Fix YAMLish handling of empty arrays, hashes. + - Renamed TAP::Harness::Compatible to Test::Harness, + runtests to prove. + - Fixes to @INC handling. We didn't always pass the correct path + to subprocesses. + - We now observe any switches in HARNESS_PERL_SWITCHES. + - Changes to output formatting for greater compatibility with + Test::Harness 2.64. + - Added unicode test coverage and fixed a couple of + unicode issues. + - Additions to documentation. + - Added support for non-forking Perls. If forking isn't + available we fall back to open and disable stream merging. + - Added support for simulating non-forking Perls to improve our + test coverage. + +======================================================================== +Version numbers below this point relate to TAP::Parser - which was the +name of this version of Test::Harness during its development. +======================================================================== + +0.54 + - Optimized I/O for common case of 'runtests -l' + - Croak if supplied an empty (0 lines) Perl script. + - Made T::P::Result::YAML return literal input YAML correctly. + - Merged speed-ups from speedy branch. + +0.53 18 August 2007 + - Fixed a few docs nits. + - Added -V (--version) switch to runtests. Suggested by markjugg on + Perlmonks. + - Fixed failing t/030-grammer.t under 5.9.5. Exact cause still + unknown; something to do with localisation of $1 et all I think. + - Fixed use of three arg open in t/compat/test-harness-compat; was + failing on 5.6.2. + - Fixed runtests --exec option. T::H wasn't passing the exec option + to T::P. + - Merged Leif Eriksen's coverage enhancing changes to + t/080-aggregator.t, t/030-grammar.t + - Made various changes so that we test cleanly on 5.0.5. + - Many more coverage enhancements by Leif. + - Applied Michael Peters' patch to add an EOF callback to + TAP::Parser. + - Added --reverse option to runtests to run tests in reverse order. + - Made runtests exit with non-zero status if the test run had + problems. + - Stopped TAP::Parser::Iterator::Process from trampling on STDIN. + +0.52 14 July 2007 + - Incorporate Schwern's investigations into TAP versions. + Unversioned TAP is now TAP v12. The lowest explicit version number + that can be specified is 13. + - Renumbered tests to eliminate gaps. + - Killed execrc. The '--exec' switch to runtests handles all of this for + us. + - Refactored T::P::Iterator into + T::P::Iterator::(Array|Process|Stream) so that we have a + process specific iterator with which to experiment with + STDOUT/STDERR merging. + - Removed vestigial exit status handling from T::P::I::Stream. + - Removed unused pid interface from T::P::I::Process. + - Fixed infinite recursion in T::P::I::Stream and added regression + coverage for same. + - Added tests for T::P::I::Process. + - TAP::Harness now displays the first five TAP syntax errors and + explains how to pass the -p flag to runtests to see them all. + - Added merge option to TAP::Parser::Iterator::Process, + TAP::Parser::Source, TAP::Parser and TAP::Harness. + - Added --merge option to runtests to enable STDOUT/STDERR merging. + This behaviour used to be the default. + - Made T::P::I::Process use open3 for both merged and non-merged + streams so that it works on Windows. + - Implemented Eric Wilhelm's IO::Select based multiple stream + handler so that STDERR is piped to us even if stream merging is + turned off. This tends to reduce the temporal skew between the + two streams so that error messages appear closer to their + correct location. + - Altered the T::P::Grammar interface so that it gets a stream + rather than the next line from the stream in preparation for + making it handle YAML diagnostics. + - Implemented YAML syntax. Currently YAML may only follow a + test result. The first line of YAML is '---' and the last + line is '...'. + - Made grammar version-aware. Different grammars may now be selected + depending on the TAP version being parsed. + - Added formatter delegate mechanism for test results. + - Added prototype stream based YAML(ish) parser. + - Added more tests for T::P::YAMLish + - Altered T::P::Grammar to use T::P::YAMLish + - Removed T::P::YAML + - Added raw source capture to T::P::YAMLish + - Added support for double quoted hash keys + - Added TAP::Parser::YAMLish::Writer and renamed T::P::YAMLish as + T::P::YAMLish::Reader. + - Added extra TAP::Parser::YAMLish::Writer output options + - Inline YAML documents must now be indented by at least one space + - Fixed broken dependencies in bin/prove + - Make library paths absolute before running tests in case tests + chdir before loading modules. + - Added libs and switches handling to T::H::Compatible. This and the + previous change fix [24926] + - Added PERLLIB to libraries stripped in _default_inc [12030] + - Our version of prove now handles directories containing circular + links correctly [21938] + - Set TAP_VERSION env var in Parser [11595] + - Added setup, teardown hooks to T::P::I::Process to facilitate the + setup and cleanup of the test script's environment + - Any additional libs added to the command line are also added to + PERL5LIB for the duration of a test run so that any Perl children + of the test script inherit the same library paths. + - Fixed handling of single quoted hash keys in T::P::Y::Reader + - Made runtests return the TAP::Parser::Aggregator + - Fixed t/120-harness.t has failures if TAP::Harness::Color cannot + load optional modules [27125] - thanks DROLSKY + - Fixed parsing of \# in test description +0.51 12 March 2007 + - 'execrc' file now allows 'regex' matches for tests. + - rename 'TAPx' --> 'TAP' + - Reimplemented the parse logic of TAP::Parser as a state machine. + - Removed various ad-hoc state variables from TAP::Parser and moved + their logic into the state machine. + - Removed now-unused is_first / is_last methods from Iterator and + simplified remaining logic to suit. + - Removed now-redundant t/140-varsource.t. + - Implemented TAP version syntax. + - Tidied TAP::Harness::Compatible documentation + - Removed redundant modules below TAP::Harness::Compatible + - Removed unused compatibility tests + +0.50_07 5 March 2007 + - Fixed bug where we erroneously checked the test number instead of number + of tests run to determine if we've run more tests than we planned. + - Add a --directives switch to 'runtests' which only shows test results + with directives (such as 'TODO' or 'SKIP'). + - Removed some dead code from TAPx::Parser. + - Added color support for Windows using Win32::Console. + - Made Color::failure_output reset colors before printing + the trailing newline. + - Corrected some issues with the 'runtests' docs and removed some + performance notes which no longer seem accurate. + - Fixed bug whereby if tests without file extensions were included then + the spacing of the result leaders would be off. + - execrc file is now a YAML file. + - Removed white background on the test failures. It was too garish for + me. Just more proof that we need better ways of overriding color + support. + - Started work on TAPx::Harness::Compatible. Right now it's mainly just + a direct lift of Test::Harness to make sure the tests work. + - Commented out use Data::Dumper::Simple in T::Harness.pm - it's not + a core module. + - Added next_raw to TAPx::Parser::Iterator which skips any fixes for + quirky TAP that are implemented by next. Used to support + TAPx::Harness::Compatible::Iterator + - Applied our version number to all T::H::Compatible modules + - Removed T::H::C::Assert. It's documented as being private to + Test::Harness and we're not going to need it. + - Refactored runtests to call aggregate_tests to expose the + interface we need for the compatibility layer. + - Make it possible to pass an end time to summary so that it needn't + be called immediately after the tests complete. + - Moved callback handling into TAPx::Base and altered TAPx::Parser + to use it. + - Made TAPx::Harness into a subclass of TAPx::Base and implemented + made_parser callback. + - Moved the dispatch of callbacks out of run and into next so that + they're called when TAPx::Harness iterates through the results. + - Implemented PERL_TEST_HARNESS_DUMP_TAP which names a directory + into which the raw TAP of any tests run via TAPx::Harness will + be written. + - Rewrote the TAPx::Grammar->tokenize method to return a + TAPx::Parser::Result object. Code is much cleaner now. + - Moved the official grammar from TAPx::Parser to TAPx::Parser::Grammar, + provided a link and updated the grammar. + - Fixed bug where a properly escaped '# TODO' line in a test description + would still be reported as a TODO test. + - Added patches/ExtUtils-MakeMaker-6.31.patch - a patch against EUMM + that makes test_harness use TAPx::Harness instead of Test::Harness + if PERL_EUMM_USE_TAPX is true and TAPx::Harness is installed. In + other words cause 'make test' for EUMM based models to use + TAPx::Harness. + - Added support for timer option to TAPx::Harness which causes the + elapsed time for each test to be displayed. + - Setup tapx-dev@hexten.net mailing list. + - Fixed accumulating @$exec bug in TAPx::Harness. + - Made runtests pass '--exec' option as an array. + - (#24679) TAPx::Harness now reports failure for tests that die + after completing all subtests. + - Added in_todo attribute on TAPx::Parser which is true while the + most recently seen test was a TODO. + - (#24728) TAPx::Harness now supresses diagnostics from failed + TODOs. Not sure if the semantics of this are correct yet. + +0.50_06 18 January 2007 + - Fixed doc typo in examples/README [rt.cpan.org #24409] + - Colored test output is now the default for 'runtests' unless + you're running under windows or -t STDOUT is false. + [rt.cpan.org #24310] + - Removed the .t extension from t/source_tests/*.t since those are + 'test tests' which caused false negatives when running recursive + tests. [Adrian Howard] + - Somewhere along the way, the exit status started working again. + Go figure. + - Factored color output so that disabling it under Windows is + cleaner. + - Added explicit switch to :crlf layer after open3 under Windows. + open3 defaults to raw mode resulting in spurious \r characters input + parsed input. + - Made Iterator do an explicit wait for subprocess termination. + Needed to get process status correctly on Windows. + - Fixed bug which didn't allow t/010-regression.t to be run directly + via Perl unless you specified Perl's full path. + - Removed SIG{CHLD} handler (which we shouldn't need I think because + we explicitly waitpid) and made binmode ':crlf' conditional on + IS_WIN32. On Mac OS these two things combined to expose a problem + which meant that output from test scripts was sometimes lost. + - Made t/110-source.t use File::Spec->catfile to build path to + test script. + - Made Iterator::FH init is_first, is_last to 0 rather than undef + for consistency with array iterator. + - Added t/120-varsource.t to test is_first and is_last semantics + over files with small numbers of lines. + - Added check for valid callback keys. + - Added t/130-results.t for Result classes. + +0.50_05 15 January 2007 + - Removed debugging code accidentally left in bin/runtests. + - Removed 'local $/ = ...' from the iterator. Hopefully that will fix the + line ending bug, but I don't know about the wstat problem. + +0.50_04 14 January 2007 + - BACKWARDS IMCOMPATIBLE: Renamed all '::Results' classes to '::Result' + because they represent a single result. + - Fixed bug where piping would break verbose output. + - IPC::Open3::open3 now takes a @command list rather than a $command + string. This should make it work under Windows. + - Added 'stdout_sterr' sample test back to regression tests. IPC::Open3 + appears to make it work. + - Bug fix: don't print 'All tests successful' if no tests are run. + - Refactored 'runtests' to make it a bit easier to follow. + - Bug fix: Junk and comments now allowed before a leading plan. + - HARNESS_ACTIVE and HARNESS_VERSION environment variables now set. + - Renamed 'problems' in TAPx::Parser and TAPx::Aggregator to + 'has_problems'. + +0.50_03 08 January 2007 + + - Fixed bug where '-q' or '-Q' with colored tests weren't suppressing all + information. + - Fixed an annoying MANIFEST nit. + - Made '-h' for runtests now report help. Using a new harness requires + the full --harness switch. + - Added 'problems' method to TAPx::Parser and TAPx::Parser::Aggregator. + - Deprecatd 'todo_failed' in favor of 'todo_passed' + - Add -I switch to runtests. + - Fixed runtests doc nit (smylers) + - Removed TAPx::Parser::Builder. + - A few more POD nits taken care of. + - Completely removed all traces of C<--merge> as IPC::Open3 seems to be + working. + - Moved the tprove* examples to examples/bin in hopes of them no longer + showing up in CPAN's docs. + - Made the 'unexpectedly succeeded' message clearer (Adam Kennedy) + +0.50_02 06 January 2007 + - Added some files I left out of the manifest (reported by Florian + Ragwitz). + - Added strict to Makefile.PL and changed @PROGRAM to @program (reported + Florian Ragwitz). + +0.50_01 06 January 2007 + - Added a new example which shows to how test Perl, Ruby, and URLs all at + the same time using 'execrc' files. + - Fixed the diagnostic format mangling bug. + - We no longer override Test::Builder to merge streams. Instead, we go + ahead and use IPC::Open3. It remains to be seen whether or not this is + a good idea. + - Fixed vms nit: for failing tests, vms often has the 'not' on a line by itself. - * Added _command_line() to the Strap API. - - [FIXES] - * Bad interaction with Module::Build: The strap was only checking - $ENV{HARNESS_PERL_SWITCHES} for definedness, but not emptiness. - It now also strips any leading or trailing whitesapce from the - switches. - * Test::Harness and prove only quote those parms that actually need - to be quoted: Have some whitespace and aren't already quoted. - -2.36 Fri Nov 14 09:24:44 CST 2003 - [FIXES] - * t/prove-includes.t properly ignores PROVE_SWITCHES that you may - already have set. - -2.35_02 Thu Nov 13 09:57:36 CST 2003 - [ENHANCEMENTS] - * prove's --blib now works just like the blib pragma. - -2.35_01 Wed Nov 12 23:08:45 CST 2003 - [FIXES] - * Fixed taint-handling and path preservation under MacOS. Thanks to - Schwern for the patch and the tests. - - * Preserves case of -t or -T in the shebang line of the test. - - [ENHANCEMENTS] - * Added -t to prove analogous to Perl's -t. Removed the --taint - switch. - - * prove can take default options from the PROVE_SWITCHES variable. - - * Added HARNESS_PERL to allow you to specify the Perl interpreter - to run the tests as. - - * prove's --perl switch sets the HARNESS_PERL on the fly for you. - - * Quotes the switches and filename in the subprogram. This helps - with filenames with spaces that are subject to shell mangling. - - -2.34 Sat Nov 8 22:09:15 CST 2003 - [FIXES] - * Allowed prove to run on Perl versions < 5.6.0. - - [ENHANCEMENTS] - * Command-line switches to prove may now be stacked. - * Added check for proper Pod::Usage version. - * "make clean" does a better job of cleaning up after itself. - - -2.32 Fri Nov 7 09:41:21 CST 2003 - Test::Harness now includes a powerful development tool to help - programmers work with automated tests. The prove utility runs - test files against the harness, like a "make test", but with many - advantages: - - * prove is designed as a development tool - Perl users typically run the test harness through a makefile via - "make test". That's fine for module distributions, but it's - suboptimal for a test/code/debug development cycle. - - * prove is granular - prove lets your run against only the files you want to check. - Running "prove t/live/ t/master.t" checks every *.t in t/live, plus - t/master.t. - - * prove has an easy verbose mode - To get full test program output from "make test", you must set - "HARNESS_VERBOSE" in the environment. prove has a "-v" option. - - * prove can run under taint mode - prove's "-T" runs your tests under "perl -T". - - * prove can shuffle tests - You can use prove's "--shuffle" option to try to excite problems - that don't show up when tests are run in the same order every time. - - * Not everything is a module - More and more users are using Perl's testing tools outside the - context of a module distribution, and may not even use a makefile at - all. - - Prove requires Pod::Usage, which is standard after Perl 5.004. - - I'm very excited about prove, and hope that developers will begin - adopting it to their coding cycles. I welcome your comments at - andy@petdance.com. - - There are also some minor bug fixes in Test::Harness itself, listed - below in the 2.31_* notes. - - -2.31_05 Thu Nov 6 14:56:22 CST 2003 - [FIXES] - - If a MacPerl script had a shebang with -T, the -T wouldn't get - passed as a switch. - - Removed the -T on three *.t files, which didn't need them, and - which were causing problems. - - Conditionally installs bin/prove, depending on whether Pod::Usage - is available, which prove needs. - - Removed old leftover code from Makefile.PL. - -2.31_04 Mon Nov 3 23:36:06 CST 2003 - Minor tweaks here and there, almost ready to release. - -2.31_03 Mon Nov 3 08:50:36 CST 2003 - [FEATURES] - - prove is almost feature-complete. Removed the handling of - --exclude for excluding certain tests. It may go back in the - future. - - prove -d is now debug. Dry is prove -D. - -2.31_02 Fri Oct 31 23:46:03 CST 2003 - [FEATURES] - - Added many more switches to prove: -d for dry run, and -b for - blib. - - [FIXES] - - T:H:Straps now recognizes MSWin32 in $^0. - - RT#3811: Could do regex matching on garbage in _is_test(). - Fixed by Yves Orton - - RT#3827: Strips backslashes from and normalizes @INC entries - for Win32. Fixed by Yves Orton. - - [INTERNALS] - - Added $self->{_is_macos} to the T:H:Strap object. - - t/test-harness.t sorts its test results, rather than relying on - internal key order. - -2.31_01 - [FEATURES] - - Added "prove" script to run a test or set of tests through the - harness. Thanks to Curtis Poe for the foundation. - - [DOCUMENTATION] - - Fixed POD problem in Test::Harness::Assert - -2.30 Thu Aug 14 20:04:00 CDT 2003 - No functional changes in this version. It's only to make some doc - tweaks, and bump up the version number in T:H:Straps. - - [DOCUMENTATION] - - Changed Schwern to Andy as the maintainer. - - Incorporated the TODO file into Harness.pm proper. - - Cleaned up formatting in Test::Harness::Straps. - -2.29 Wed Jul 17 14:08:00 CDT 2003 - - Released as 2.29. - -2.28_91 Sun Jul 13 00:10:00 CDT 2003 - [ENHANCEMENTS] - - Added support for HARNESS_OK_SLOW. This will make a significant - speedup for slower connections. - - Folded in some changes from bleadperl that spiff up the - failure reports. - - [INTERNALS] - - Added some isa_ok() checks to the tests. - - All Test::Harness* modules are used by use_ok() - - Fixed the prototype for the canonfailed() function, not that - it matters since it's never called without parens. - -2.28_90 Sat Jul 05 20:21:00 CDT 2003 - [ENHANCEMENTS] - - Now, when you run a test harnessed, the numbers don't fly by one - at a time, one update per second. This significantly speeds - up the run time for running thousands of tests. *COUGH* - Regexp::Common *COUGH* - -2.28 Thu Apr 24 14:39:00 CDT 2003 - - No functional changes. - -2.27_05 Mon Apr 21 15:55:00 CDT 2003 - - No functional changes. - - Fixed circular depency in the test suite. Thanks, Rob Brown. - -2.27_04 Sat Apr 12 21:42:00 CDT 2003 - - Added test for $Test::Harness::Switches patch below. - -2.27_03 Thu Apr 03 10:47:00 CDT 2003 - - Fixed straps not respecting $Test::Harness::Switches. Thanks - to Miyagawa for the patch. - - Added t/pod.t to test POD validity. - -2.27_02 Mon Mar 24 13:17:00 CDT 2003 -2.27_01 Sun Mar 23 19:46:00 CDT 2003 - - Handed over to Andy Lester for further maintenance. - - Fixed when the path to perl contains spaces on Windows - * Stas Bekman noticed that tests with no output at all were - interpreted as passing - - MacPerl test tweak for busted exit codes (bleadperl 17345) - - Abigail and Nick Clark both hit the 100000 "huge test that will - suck up all your memory" limit with legit tests. Made the check - smarter to allow large, planned tests to work. - - Partial fix of stats display when a test fails only because there's - too many tests. - - Made wait.ph and WCOREDUMP anti-vommit protection more robust in - cases where wait.ph loads but WCOREDUMP() pukes when run. - - Added a LICENSE. - - Ilya noticed the per test skip reason was accumlating between tests. - -2.26 Wed Jun 19 16:58:02 EDT 2002 - - Workaround for MacPerl's lack of a working putenv. It will never - see the PERL5LIB environment variable (perl@16942). - -2.25 Sun Jun 16 03:00:33 EDT 2002 - - $Strap is now a global to allow Test::Harness::Straps - experimentation. - - Little spelling nit in a diagnostic. - - Chris Richmond noted that the runtests() docs were wrong. It will - die, not return false, when any tests fail. This is silly, but - historically necessary for 'make test'. Docs corrected. - - MacPerl test fixes from Pudge. (mutation of bleadperl@16989) - - Undef warning introduced in 2.24 on skipped tests with no reasons - fixed. - * Test::Harness now depends on File::Spec - -2.24 Wed May 29 19:02:18 EDT 2002 - * Nikola Knezevic found a bug when tests are completely skipped - but no reason is given it was considered a failure. - * Made Test::Harness::Straps->analyze_file & Test::Harness a bit - more graceful when the test doesn't exist. - -2.23 Wed May 22 12:59:47 EDT 2002 - - reason for all skip wasn't being displayed. Broken in 2.20. - - Changed the wait status tests to conform with POSIX standards. - - Quieted some SYSTEM$ABORT noise leaking out from dying test tests - on VMS. - -2.22 Fri May 17 19:01:35 EDT 2002 - - Fixed parsing of #!/usr/bin/perl-current to not see a -t. - (RT #574) - - Fixed exit codes on MPE/iX - -2.21 Mon May 6 00:43:22 EDT 2002 - - removed a bunch of dead code left over after 2.20's gutting. - - The fix for the $^X "bug" added in 2.02 has been removed. It - caused more trouble than the old bug (I'd never seen a problem - before anyway) - - 2.20 broke $verbose - -2.20 Sat May 4 22:31:20 EDT 2002 - * An almost complete conversion of the Test::Harness test parsing - to use Test::Harness::Straps. - -2.04 Tue Apr 30 00:54:49 EDT 2002 - * Changing the output format of skips - - Taking into account VMS's special exit codes in the tests. - -2.03 Thu Apr 25 01:01:34 EDT 2002 - * $^X fix made safer. - - Noise from loading wait.ph to analyze core files supressed - - MJD found a situation where a test could run Test::Harness - out of memory. Protecting against that specific case. - - Made the 1..M docs a bit clearer. - - Fixed TODO tests so Test::Harness does not display a NOK for + - Fixed bugs where unplanned tests were not reporting as a failure (test + number greater than tests planned). + - TAPx::Parser constructor can now take an 'exec' option to tell it what + to execute to create the stream (huge performance boost). + - Added TAPx::Parser::Source. This allows us to run tests in just about + any programming language. + - Renamed the filename() method to source() in TAPx::Parser::Source::Perl. + - We now cache the @INC values found for TAPx::Parser::Source::Perl. + - Added two test harnesses, TAPx::Harness and TAPx::Harness::Color. + - Removed references to manual stream construction from TAPx::Parser + documentation. Users should not (usually) need to worry about streams. + - Added bin/runtests utility. This is very similar to 'prove'. + - Renumbered tests to make it easier to add new ones. + - Corrected some minor documentation nits. + - Makefile.PL is no longer auto-generated (it's built by hand). + - Fixed regression test bug where driving tests through the harness I'm + testing caused things to break. + - BUG: exit() values are now broken. I don't know how to capture them + with IPC::Open3. However, since no one appears to be using them, this + might not be an issue. + +0.41 12 December 2006 + - Fixed (?) 10-regression.t test which failed on Windows. Removed the + segfault test as it has no meaning on Windows. Reported by PSINNOTT + <link@redbrick.dcu.ie> and fix recommended by Schwern based on his + Test::Harness experience. + http://rt.cpan.org/Ticket/Display.html?id=21624 + +0.40 05 December 2006 + - Removed TAPx::Parser::Streamed and folded its functionality into + TAPx::Parser. + - Fixed bug where sometimes is_good_plan() would return a false positive + (exposed by refactoring). + - A number of tiny performance enhancements. + +0.33 22 September 2006 + - OK, I'm getting ticked off by some of the comments on Perl-QA so I + rushed this out the door and broke it :( I'm backing out one test and + slowing down a bit. + +0.32 22 September 2006 + - Applied patch from Schwern which fixed the Builder package name (TAPx:: + instead of TAPX:: -- stupid case-insensitive package names!). + [rt.cpan.org #21605] + +0.31 21 September 2006 + - Fixed bug where Carp::croak without parens could cause Perl to fail to + compile on some platforms. [Andreas J. Koenig] + - Eliminated the non-portable redirect of STDERR to STDOUT (2>&1) and + fixed the synchronization issue. This involves overridding + Test::Builder::failure_output() in a very sneaky way. I may have to + back this out. + - Renamed boolean methods to begin with 'is_'. The methods they replace + are documented, deprecated, and will not be removed prior to version + 1.00. + +0.30 17 September 2006 + - Fixed bug where no output would still claim to have a good plan. + - Fixed bug where no output would cause parser to die. + - Fixed bug where failing to specify a plan would be two parse errors + instead of one. + - Fixed bug where a correct plan count in an incorrect place would still + report as a 'good_plan'. + - Fixed bug where comments could accidently be misparsed as directives. + - Eliminated testing of internal structure of result objects. The other + tests cover this. + - Allow hash marks in descriptions. This was causing a problem because + many test suites (Regexp::Common and Perl core) allowed them to exist. + - Added support for SKIP directives in plans. + - Did some work simplifying &TAPx::Parser::_initialize. It's not great, + but it's better than it was. + - TODO tests now always pass, regardless of actual_passed status. + - Removed 'use warnings' and now use -w + - 'switches' may now be passed to the TAPx::Parser constructor. + - Added 'exit' status. + - Added 'wait' status. + - Eliminated 'use base'. This is part of the plan to make TAPx::Parser + compatible with older versions of Perl. + - Added 'source' key to the TAPx::Parser constructor. Making new parsers + is now much easier. + - Renamed iterator first() and last() methods to is_first() and is_last(). + Credit: Aristotle. + - Planned tests != tests run is now a parse error. It was really stupid + of me not to do that in the first place. + - Added massive regression test suite in t/100-regression.t + - Updated the grammar to show that comments are allowed. + - Comments are now permitted after an ending plan. + +0.22 13 September 2006 + - Removed buggy support for multi-line chunks from streams. If your + streams or iterators return anything but single lines, this is a bug. + - Fixed bug whereby blank lines in TAP would confuse the parser. Reported + by Torsten Schoenfeld. + - Added first() and last() methods to the iterator. + - TAPx::Parser::Source::Perl now has a 'switches' method which allows + switches to be passed to the perl executable running the test file. + This allows tprove to accept a '-l' argument to force lib/ to be + included in Perl's @INC. + +0.21 8 September 2006 + - Included experimental GTK interface written by Torsten Schoenfeld. + - Fixed bad docs in examples/tprove_color + - Applied patch from Shlomi Fish fixing bug where runs from one stream + could leak into another when bailing out. [rt.cpan.org #21379] + - Fixed some typos in the POD. + - Corrected the grammar to allow for a plan of "1..0" (infinite stream). + - Started to add proper acknowledgements. + +0.20 2 September 2006 + - Fixed bug reported by GEOFFR. When no tap output was found, an + "Unitialized value" warning occurred. [rt.cpan.org #21205] + - Updated tprove to now report a test failure when no tap output found. + - Removed examples/tprove_color2 as tprove_color now works. + - Vastly improved callback system and updated the docs for how to use them. - - Test::Harness::Straps->analyze_file() docs were not clear as to - its effects - -2.02 Thu Mar 14 18:06:04 EST 2002 - * Ken Williams fixed the long standing $^X bug. - * Added HARNESS_VERBOSE - * Fixed a bug where Test::Harness::Straps was considering a test that - is ok but died as passing. - - Added the exit and wait codes of the test to the - analyze_file() results. - -2.01 Thu Dec 27 18:54:36 EST 2001 - * Added 'passing' to the results to tell you if the test passed - * Added Test::Harness::Straps example (examples/mini_harness.plx) - * Header-at-end tests were being interpreted as failing sometimes - - The 'skip_all' results from analyze* was not being set - - analyze_fh() and analyze_file() now work more efficiently, reading - line-by-line instead of slurping as before. - -2.00 Sun Dec 23 19:13:57 EST 2001 - - Fixed a warning on VMS. - - Removed a little unnecessary code from analyze_file() - - Made sure filehandles are getting closed - - analyze() now considers "not \nok" to be a failure (VMSism) - but Test::Harness still doesn't. - -2.00_05 Mon Dec 17 22:08:02 EST 2001 - * Wasn't filtering @INC properly when a test is run with -T, caused the - command line to be too long on VMS. VMS should be 100% now. - - Little bug in the skip 'various reasons' logic. - - Minor POD nit in 5.004_04 - - Little speling mistak - -2.00_04 Sun Dec 16 00:33:32 EST 2001 - * Major Test::Harness::Straps doc bug. - -2.00_03 Sat Dec 15 23:52:17 EST 2001 - * First release candidate - * 'summary' is now 'details' - * Test #1 is now element 0 on the details array. It works out better - that way. - * analyze_file() is more portable, but no longer taint clean - * analyze_file() properly preserves @INC and handles -T switches - - minor mistake in the test header line parsing - -1.26 Mon Nov 12 15:44:01 EST 2001 - * An excuse to upload a new version to CPAN to get Test::Harness - back on the index. - -2.00_00 Sat Sep 29 00:12:03 EDT 2001 - * Partial gutting of the internals - * Added Test::Harness::Straps - -1.25 Tue Aug 7 08:51:09 EDT 2001 - * Fixed a bug with tests failing if they're all skipped - reported by Stas Bekman. - - Fixed a very minor warning in 5.004_04 - - Fixed displaying filenames not from @ARGV - - Merging with bleadperl - - minor fixes to the filename in the report - - '[no reason given]' skip reason - -1.24 Tue Aug 7 08:51:09 EDT 2001 - - Added internal information about number of todo tests - -1.23 Tue Jul 31 15:06:47 EDT 2001 - - Merged in Ilya's "various reasons" patch - * Fixed "not ok 23 - some name # TODO" style tests - -1.22 Mon Jun 25 02:00:02 EDT 2001 - * Fixed bug with failing tests using header at end. - - Documented how Test::Harness deals with garbage input - - Turned on test counter mismatch warning - -1.21 Wed May 23 19:22:53 BST 2001 - * No longer considered unstable. Merging back with the perl core. - - Fixed minor nit about the report summary - - Added docs on the meaning of the failure report - - Minor POD nits fixed mirroring perl change 9176 - - TODO and SEE ALSO expanded - -1.20 Wed Mar 14 23:09:20 GMT 2001 by Michael G Schwern *UNSTABLE* - * Fixed and tested with 5.004! - - Added EXAMPLE docs - - Added TODO docs - - Now uneffected by -l, $\ or $, - -1.19 Sat Mar 10 00:43:29 GMT 2001 by Michael G Schwern *UNSTABLE* - - More internal reworking - * Removed use of experimental /(?>...)/ feature for backwards compat - * Removed use of open(my $fh, $file) for backwards compatibility - * Removed use of Tie::StdHandle in tests for backwards compat - * Added dire warning that this is unstable. - - Added some tests from the old CPAN release - -1.18 Mon Mar 5 17:35:11 GMT 2001 by Michael G Schwern - * Under new management! - * Test::Harness is now being concurrently shipped on CPAN as well - as in the core. - - Switched "our" for "use vars" and moved the minimum version back - to 5.004. This may be optimistic. - - -*** Missing version history to be extracted from Perl changes *** - - -1.07 Fri Feb 23 1996 by Andreas Koenig - - Gisle sent me a documentation patch that showed me, that the - unless(/^#/) is unnessessary. Applied the patch and deleted the block - checking for "comment" lines. -- All lines are comment lines that do - not match /^1\.\.([0-9]+)/ or /^(not\s+)?ok\b/. - - Ilyaz request to print "ok (empty test case)" whenever we say 1..0 - implemented. - - Harness now doesn't abort anymore if we received confused test output, - just warns instead. - -1.05 Wed Jan 31 1996 by Andreas Koenig - - More updates on docu and introduced the liberality that the script - output may omit the test numbers. - -1.03 Mon January 28 1996 by Andreas Koenig - - Added the statistics for subtests. Updated the documentation. - -1.02 by Andreas Koenig - - This version reports a list of the tests that failed accompanied by - some trivial statistics. The older (unnumbered) version stopped - processing after the first failed test. - - Additionally it reports the exit status if there is one. - - + - Changed TAPx::Parser::Source::Perl to use Symbol::gensym() instead of a + hard-to-guess filehandle name. + +0.12 30 July 2006 + - Added a test colorization script + - Callback support added. + - Added TAPx::Parser::Source::Perl. + - Added TAPx::Parser::Aggregator. + - Added version numbers to all classes. + - Added 'todo_failed' test result and parser. + - 00-load.t now loads all classes instead of having individual tests load + their supporting classes. + - Changed $parser->results to $parser->next + +0.11 25 July, 2006 + - Renamed is_skip and is_todo to has_skip and has_todo. Much less + confusing since a result responding true to those also responded true to + is_test. + - Added simplistic bin/tprove to run tests. Much harder than I thought + and much code stolen from Test::Harness. + - Modified stolen iterator to fix a bug with stream handling when extra + newlines were encountered. + - Added TAPx::Parser::Iterator (stolen from Test::Harness::Iterator) + - Normalized internal structure of result objects. + - All tokens now have a 'type' key. This greatly simplifies internals. + - Copied much result POD info into the main docs. + - Corrected the bug report URLs. + - Minor updates to the grammar listed in the POD. + +0.10 23 July, 2006 + - Oh my Larry, we gots docs! + - _parse and _tap are now private methods. + - Stream support has been added. + - Moved the grammar into its own class. + - Pulled remaining parser functionality out of lexer. + - Added type() method to Results(). + - Parse errors no longer croak(). Instead, they are available through the + parse_errors() method. + - Added good_plan() method. + - tests_planned != tests_run is no longer a parse error. + - Renamed test_count() to tests_run(). + - Renamed num_tests() to tests_planned(). + +0.03 17 July, 2006 + - 'Bail out!' is now handled. + - The parser is now data driven, thus skipping a huge if/else chain + - We now track all TODOs, SKIPs, passes and fails by test number. + - Removed all non-core modules. + - Store original line for each TAP line. Available through + $result->raw(). + - Renamed test is_ok() to passed() and added actual_passed(). The former + method takes into account TODO tests and the latter returns the actual + pass/fail status. + - Fixed a bug where SKIP tests would not be identified correctly. + +0.02 8 July, 2006 + - Moved some lexer responsibility to the parser. This will allow us to + eventually parse streams. + - Properly track passed/failed tests, even accounting for TODO. + - Added support for comments and unknown lines. + - Allow explicit and inferred test numbers to be mixed. + - Allow escaped hashes in the test description. + - Renamed to TAPx::Parser. Will probably rename it again. + +0.01 Date/time + - First version, unreleased on an unsuspecting world. + - No, you'll never know when ... diff --git a/lib/Test/Harness/Iterator.pm b/lib/Test/Harness/Iterator.pm deleted file mode 100644 index 2648cea707..0000000000 --- a/lib/Test/Harness/Iterator.pm +++ /dev/null @@ -1,70 +0,0 @@ -package Test::Harness::Iterator; - -use strict; -use vars qw($VERSION); -$VERSION = 0.02; - -=head1 NAME - -Test::Harness::Iterator - Internal Test::Harness Iterator - -=head1 SYNOPSIS - - use Test::Harness::Iterator; - my $it = Test::Harness::Iterator->new(\*TEST); - my $it = Test::Harness::Iterator->new(\@array); - - my $line = $it->next; - -=head1 DESCRIPTION - -B<FOR INTERNAL USE ONLY!> - -This is a simple iterator wrapper for arrays and filehandles. - -=head2 new() - -Create an iterator. - -=head2 next() - -Iterate through it, of course. - -=cut - -sub new { - my($proto, $thing) = @_; - - my $self = {}; - if( ref $thing eq 'GLOB' ) { - bless $self, 'Test::Harness::Iterator::FH'; - $self->{fh} = $thing; - } - elsif( ref $thing eq 'ARRAY' ) { - bless $self, 'Test::Harness::Iterator::ARRAY'; - $self->{idx} = 0; - $self->{array} = $thing; - } - else { - warn "Can't iterate with a ", ref $thing; - } - - return $self; -} - -package Test::Harness::Iterator::FH; -sub next { - my $fh = $_[0]->{fh}; - - # readline() doesn't work so good on 5.5.4. - return scalar <$fh>; -} - - -package Test::Harness::Iterator::ARRAY; -sub next { - my $self = shift; - return $self->{array}->[$self->{idx}++]; -} - -"Steve Peters, Master Of True Value Finding, was here."; diff --git a/lib/Test/Harness/Point.pm b/lib/Test/Harness/Point.pm deleted file mode 100644 index df0706ac61..0000000000 --- a/lib/Test/Harness/Point.pm +++ /dev/null @@ -1,143 +0,0 @@ -# -*- Mode: cperl; cperl-indent-level: 4 -*- -package Test::Harness::Point; - -use strict; -use vars qw($VERSION); -$VERSION = '0.01'; - -=head1 NAME - -Test::Harness::Point - object for tracking a single test point - -=head1 SYNOPSIS - -One Test::Harness::Point object represents a single test point. - -=head1 CONSTRUCTION - -=head2 new() - - my $point = new Test::Harness::Point; - -Create a test point object. - -=cut - -sub new { - my $class = shift; - my $self = bless {}, $class; - - return $self; -} - -=head1 from_test_line( $line ) - -Constructor from a TAP test line, or empty return if the test line -is not a test line. - -=cut - -sub from_test_line { - my $class = shift; - my $line = shift or return; - - # We pulverize the line down into pieces in three parts. - my ($not, $number, $extra) = ($line =~ /^(not )?ok\b(?:\s+(\d+))?\s*(.*)/) or return; - - my $point = $class->new; - $point->set_number( $number ); - $point->set_ok( !$not ); - - if ( $extra ) { - my ($description,$directive) = split( /(?:[^\\]|^)#/, $extra, 2 ); - $description =~ s/^- //; # Test::More puts it in there - $point->set_description( $description ); - if ( $directive ) { - $point->set_directive( $directive ); - } - } # if $extra - - return $point; -} # from_test_line() - -=head1 ACCESSORS - -Each of the following fields has a getter and setter method. - -=over 4 - -=item * ok - -=item * number - -=cut - -sub ok { my $self = shift; $self->{ok} } -sub set_ok { - my $self = shift; - my $ok = shift; - $self->{ok} = $ok ? 1 : 0; -} -sub pass { - my $self = shift; - - return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0; -} - -sub number { my $self = shift; $self->{number} } -sub set_number { my $self = shift; $self->{number} = shift } - -sub description { my $self = shift; $self->{description} } -sub set_description { - my $self = shift; - $self->{description} = shift; - $self->{name} = $self->{description}; # history -} - -sub directive { my $self = shift; $self->{directive} } -sub set_directive { - my $self = shift; - my $directive = shift; - - $directive =~ s/^\s+//; - $directive =~ s/\s+$//; - $self->{directive} = $directive; - - my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/); - $self->set_directive_type( $type ); - $reason = "" unless defined $reason; - $self->{directive_reason} = $reason; -} -sub set_directive_type { - my $self = shift; - $self->{directive_type} = lc shift; - $self->{type} = $self->{directive_type}; # History -} -sub set_directive_reason { - my $self = shift; - $self->{directive_reason} = shift; -} -sub directive_type { my $self = shift; $self->{directive_type} } -sub type { my $self = shift; $self->{directive_type} } -sub directive_reason{ my $self = shift; $self->{directive_reason} } -sub reason { my $self = shift; $self->{directive_reason} } -sub is_todo { - my $self = shift; - my $type = $self->directive_type; - return $type && ( $type eq 'todo' ); -} -sub is_skip { - my $self = shift; - my $type = $self->directive_type; - return $type && ( $type eq 'skip' ); -} - -sub diagnostics { - my $self = shift; - return @{$self->{diagnostics}} if wantarray; - return join( "\n", @{$self->{diagnostics}} ); -} -sub add_diagnostic { my $self = shift; push @{$self->{diagnostics}}, @_ } - - -1; diff --git a/lib/Test/Harness/Results.pm b/lib/Test/Harness/Results.pm deleted file mode 100644 index f4f4c4eca0..0000000000 --- a/lib/Test/Harness/Results.pm +++ /dev/null @@ -1,182 +0,0 @@ -# -*- Mode: cperl; cperl-indent-level: 4 -*- -package Test::Harness::Results; - -use strict; -use vars qw($VERSION); -$VERSION = '0.01'; - -=head1 NAME - -Test::Harness::Results - object for tracking results from a single test file - -=head1 SYNOPSIS - -One Test::Harness::Results object represents the results from one -test file getting analyzed. - -=head1 CONSTRUCTION - -=head2 new() - - my $results = new Test::Harness::Results; - -Create a test point object. Typically, however, you'll not create -one yourself, but access a Results object returned to you by -Test::Harness::Results. - -=cut - -sub new { - my $class = shift; - my $self = bless {}, $class; - - return $self; -} - -=head1 ACCESSORS - -The following data points are defined: - - passing true if the whole test is considered a pass - (or skipped), false if its a failure - - exit the exit code of the test run, if from a file - wait the wait code of the test run, if from a file - - max total tests which should have been run - seen total tests actually seen - skip_all if the whole test was skipped, this will - contain the reason. - - ok number of tests which passed - (including todo and skips) - - todo number of todo tests seen - bonus number of todo tests which - unexpectedly passed - - skip number of tests skipped - -So a successful test should have max == seen == ok. - - -There is one final item, the details. - - details an array ref reporting the result of - each test looks like this: - - $results{details}[$test_num - 1] = - { ok => is the test considered ok? - actual_ok => did it literally say 'ok'? - name => name of the test (if any) - diagnostics => test diagnostics (if any) - type => 'skip' or 'todo' (if any) - reason => reason for the above (if any) - }; - -Element 0 of the details is test #1. I tried it with element 1 being -#1 and 0 being empty, this is less awkward. - - -Each of the following fields has a getter and setter method. - -=over 4 - -=item * wait - -=item * exit - -=cut - -sub set_wait { my $self = shift; $self->{wait} = shift } -sub wait { - my $self = shift; - return $self->{wait} || 0; -} - -sub set_skip_all { my $self = shift; $self->{skip_all} = shift } -sub skip_all { - my $self = shift; - return $self->{skip_all}; -} - -sub inc_max { my $self = shift; $self->{max} += (@_ ? shift : 1) } -sub max { - my $self = shift; - return $self->{max} || 0; -} - -sub set_passing { my $self = shift; $self->{passing} = shift } -sub passing { - my $self = shift; - return $self->{passing} || 0; -} - -sub inc_ok { my $self = shift; $self->{ok} += (@_ ? shift : 1) } -sub ok { - my $self = shift; - return $self->{ok} || 0; -} - -sub set_exit { - my $self = shift; - if ($^O eq 'VMS') { - eval { - use vmsish q(status); - $self->{exit} = shift; # must be in same scope as pragma - } - } - else { - $self->{exit} = shift; - } -} -sub exit { - my $self = shift; - return $self->{exit} || 0; -} - -sub inc_bonus { my $self = shift; $self->{bonus}++ } -sub bonus { - my $self = shift; - return $self->{bonus} || 0; -} - -sub set_skip_reason { my $self = shift; $self->{skip_reason} = shift } -sub skip_reason { - my $self = shift; - return $self->{skip_reason} || 0; -} - -sub inc_skip { my $self = shift; $self->{skip}++ } -sub skip { - my $self = shift; - return $self->{skip} || 0; -} - -sub inc_todo { my $self = shift; $self->{todo}++ } -sub todo { - my $self = shift; - return $self->{todo} || 0; -} - -sub inc_seen { my $self = shift; $self->{seen}++ } -sub seen { - my $self = shift; - return $self->{seen} || 0; -} - -sub set_details { - my $self = shift; - my $index = shift; - my $details = shift; - - my $array = ($self->{details} ||= []); - $array->[$index-1] = $details; -} - -sub details { - my $self = shift; - return $self->{details} || []; -} - -1; diff --git a/lib/Test/Harness/Straps.pm b/lib/Test/Harness/Straps.pm deleted file mode 100644 index 3ee529c2a0..0000000000 --- a/lib/Test/Harness/Straps.pm +++ /dev/null @@ -1,648 +0,0 @@ -# -*- Mode: cperl; cperl-indent-level: 4 -*- -package Test::Harness::Straps; - -use strict; -use vars qw($VERSION); -$VERSION = '0.26_01'; - -use Config; -use Test::Harness::Assert; -use Test::Harness::Iterator; -use Test::Harness::Point; -use Test::Harness::Results; - -# Flags used as return values from our methods. Just for internal -# clarification. -my $YES = (1==1); -my $NO = !$YES; - -=head1 NAME - -Test::Harness::Straps - detailed analysis of test results - -=head1 SYNOPSIS - - use Test::Harness::Straps; - - my $strap = Test::Harness::Straps->new; - - # Various ways to interpret a test - my $results = $strap->analyze($name, \@test_output); - my $results = $strap->analyze_fh($name, $test_filehandle); - my $results = $strap->analyze_file($test_file); - - # UNIMPLEMENTED - my %total = $strap->total_results; - - # Altering the behavior of the strap UNIMPLEMENTED - my $verbose_output = $strap->dump_verbose(); - $strap->dump_verbose_fh($output_filehandle); - - -=head1 DESCRIPTION - -B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change -in incompatible ways. It is otherwise stable. - -Test::Harness is limited to printing out its results. This makes -analysis of the test results difficult for anything but a human. To -make it easier for programs to work with test results, we provide -Test::Harness::Straps. Instead of printing the results, straps -provide them as raw data. You can also configure how the tests are to -be run. - -The interface is currently incomplete. I<Please> contact the author -if you'd like a feature added or something change or just have -comments. - -=head1 CONSTRUCTION - -=head2 new() - - my $strap = Test::Harness::Straps->new; - -Initialize a new strap. - -=cut - -sub new { - my $class = shift; - my $self = bless {}, $class; - - $self->_init; - - return $self; -} - -=for private $strap->_init - - $strap->_init; - -Initialize the internal state of a strap to make it ready for parsing. - -=cut - -sub _init { - my($self) = shift; - - $self->{_is_vms} = ( $^O eq 'VMS' ); - $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ ); - $self->{_is_macos} = ( $^O eq 'MacOS' ); -} - -=head1 ANALYSIS - -=head2 $strap->analyze( $name, \@output_lines ) - - my $results = $strap->analyze($name, \@test_output); - -Analyzes the output of a single test, assigning it the given C<$name> -for use in the total report. Returns the C<$results> of the test. -See L<Results>. - -C<@test_output> should be the raw output from the test, including -newlines. - -=cut - -sub analyze { - my($self, $name, $test_output) = @_; - - my $it = Test::Harness::Iterator->new($test_output); - return $self->_analyze_iterator($name, $it); -} - - -sub _analyze_iterator { - my($self, $name, $it) = @_; - - $self->_reset_file_state; - $self->{file} = $name; - - my $results = Test::Harness::Results->new; - - # Set them up here so callbacks can have them. - $self->{totals}{$name} = $results; - while( defined(my $line = $it->next) ) { - $self->_analyze_line($line, $results); - last if $self->{saw_bailout}; - } - - $results->set_skip_all( $self->{skip_all} ) if defined $self->{skip_all}; - - my $passed = - (($results->max == 0) && defined $results->skip_all) || - ($results->max && - $results->seen && - $results->max == $results->seen && - $results->max == $results->ok); - - $results->set_passing( $passed ? 1 : 0 ); - - return $results; -} - - -sub _analyze_line { - my $self = shift; - my $line = shift; - my $results = shift; - - $self->{line}++; - - my $linetype; - my $point = Test::Harness::Point->from_test_line( $line ); - if ( $point ) { - $linetype = 'test'; - - $results->inc_seen; - $point->set_number( $self->{'next'} ) unless $point->number; - - # sometimes the 'not ' and the 'ok' are on different lines, - # happens often on VMS if you do: - # print "not " unless $test; - # print "ok $num\n"; - if ( $self->{lone_not_line} && ($self->{lone_not_line} == $self->{line} - 1) ) { - $point->set_ok( 0 ); - } - - if ( $self->{todo}{$point->number} ) { - $point->set_directive_type( 'todo' ); - } - - if ( $point->is_todo ) { - $results->inc_todo; - $results->inc_bonus if $point->ok; - } - elsif ( $point->is_skip ) { - $results->inc_skip; - } - - $results->inc_ok if $point->pass; - - if ( ($point->number > 100_000) && ($point->number > ($self->{max}||100_000)) ) { - if ( !$self->{too_many_tests}++ ) { - warn "Enormous test number seen [test ", $point->number, "]\n"; - warn "Can't detailize, too big.\n"; - } - } - else { - my $details = { - ok => $point->pass, - actual_ok => $point->ok, - name => _def_or_blank( $point->description ), - type => _def_or_blank( $point->directive_type ), - reason => _def_or_blank( $point->directive_reason ), - }; - - assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) ); - $results->set_details( $point->number, $details ); - } - } # test point - elsif ( $line =~ /^not\s+$/ ) { - $linetype = 'other'; - # Sometimes the "not " and "ok" will be on separate lines on VMS. - # We catch this and remember we saw it. - $self->{lone_not_line} = $self->{line}; - } - elsif ( $self->_is_header($line) ) { - $linetype = 'header'; - - $self->{saw_header}++; - - $results->inc_max( $self->{max} ); - } - elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) { - $linetype = 'bailout'; - $self->{saw_bailout} = 1; - } - elsif (my $diagnostics = $self->_is_diagnostic_line( $line )) { - $linetype = 'other'; - # XXX We can throw this away, really. - my $test = $results->details->[-1]; - $test->{diagnostics} ||= ''; - $test->{diagnostics} .= $diagnostics; - } - else { - $linetype = 'other'; - } - - $self->callback->($self, $line, $linetype, $results) if $self->callback; - - $self->{'next'} = $point->number + 1 if $point; -} # _analyze_line - - -sub _is_diagnostic_line { - my ($self, $line) = @_; - return if index( $line, '# Looks like you failed' ) == 0; - $line =~ s/^#\s//; - return $line; -} - -=for private $strap->analyze_fh( $name, $test_filehandle ) - - my $results = $strap->analyze_fh($name, $test_filehandle); - -Like C<analyze>, but it reads from the given filehandle. - -=cut - -sub analyze_fh { - my($self, $name, $fh) = @_; - - my $it = Test::Harness::Iterator->new($fh); - return $self->_analyze_iterator($name, $it); -} - -=head2 $strap->analyze_file( $test_file ) - - my $results = $strap->analyze_file($test_file); - -Like C<analyze>, but it runs the given C<$test_file> and parses its -results. It will also use that name for the total report. - -=cut - -sub analyze_file { - my($self, $file) = @_; - - unless( -e $file ) { - $self->{error} = "$file does not exist"; - return; - } - - unless( -r $file ) { - $self->{error} = "$file is not readable"; - return; - } - - local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; - if ( $Test::Harness::Debug ) { - local $^W=0; # ignore undef warnings - print "# PERL5LIB=$ENV{PERL5LIB}\n"; - } - - # *sigh* this breaks under taint, but open -| is unportable. - my $line = $self->_command_line($file); - - unless ( open(FILE, "$line|" )) { - print "can't run $file. $!\n"; - return; - } - - my $results = $self->analyze_fh($file, \*FILE); - my $exit = close FILE; - - $results->set_wait($?); - if ( $? && $self->{_is_vms} ) { - $results->set_exit($?); - } - else { - $results->set_exit( _wait2exit($?) ); - } - $results->set_passing(0) unless $? == 0; - - $self->_restore_PERL5LIB(); - - return $results; -} - - -eval { require POSIX; &POSIX::WEXITSTATUS(0) }; -if( $@ ) { - *_wait2exit = sub { $_[0] >> 8 }; -} -else { - *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) } -} - -=for private $strap->_command_line( $file ) - -Returns the full command line that will be run to test I<$file>. - -=cut - -sub _command_line { - my $self = shift; - my $file = shift; - - my $command = $self->_command(); - my $switches = $self->_switches($file); - - $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/); - my $line = "$command $switches $file"; - - return $line; -} - - -=for private $strap->_command() - -Returns the command that runs the test. Combine this with C<_switches()> -to build a command line. - -Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}> -to use a different Perl than what you're running the harness under. -This might be to run a threaded Perl, for example. - -You can also overload this method if you've built your own strap subclass, -such as a PHP interpreter for a PHP-based strap. - -=cut - -sub _command { - my $self = shift; - - return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; - #return qq["$^X"] if $self->{_is_win32} && ($^X =~ /[^\w\.\/\\]/); - return qq["$^X"] if $^X =~ /\s/ and $^X !~ /^["']/; - return $^X; -} - - -=for private $strap->_switches( $file ) - -Formats and returns the switches necessary to run the test. - -=cut - -sub _switches { - my($self, $file) = @_; - - my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} ); - my @derived_switches; - - local *TEST; - open(TEST, $file) or print "can't open $file. $!\n"; - my $shebang = <TEST>; - close(TEST) or print "can't close $file. $!\n"; - - my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ ); - push( @derived_switches, "-$1" ) if $taint; - - # When taint mode is on, PERL5LIB is ignored. So we need to put - # all that on the command line as -Is. - # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not. - if ( $taint || $self->{_is_macos} ) { - my @inc = $self->_filtered_INC; - push @derived_switches, map { "-I$_" } @inc; - } - - # Quote the argument if there's any whitespace in it, or if - # we're VMS, since VMS requires all parms quoted. Also, don't quote - # it if it's already quoted. - for ( @derived_switches ) { - $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ ); - } - return join( " ", @existing_switches, @derived_switches ); -} - -=for private $strap->_cleaned_switches( @switches_from_user ) - -Returns only defined, non-blank, trimmed switches from the parms passed. - -=cut - -sub _cleaned_switches { - my $self = shift; - - local $_; - - my @switches; - for ( @_ ) { - my $switch = $_; - next unless defined $switch; - $switch =~ s/^\s+//; - $switch =~ s/\s+$//; - push( @switches, $switch ) if $switch ne ""; - } - - return @switches; -} - -=for private $strap->_INC2PERL5LIB - - local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; - -Takes the current value of C<@INC> and turns it into something suitable -for putting onto C<PERL5LIB>. - -=cut - -sub _INC2PERL5LIB { - my($self) = shift; - - $self->{_old5lib} = $ENV{PERL5LIB}; - - return join $Config{path_sep}, $self->_filtered_INC; -} - -=for private $strap->_filtered_INC() - - my @filtered_inc = $self->_filtered_INC; - -Shortens C<@INC> by removing redundant and unnecessary entries. -Necessary for OSes with limited command line lengths, like VMS. - -=cut - -sub _filtered_INC { - my($self, @inc) = @_; - @inc = @INC unless @inc; - - if( $self->{_is_vms} ) { - # VMS has a 255-byte limit on the length of %ENV entries, so - # toss the ones that involve perl_root, the install location - @inc = grep !/perl_root/i, @inc; - - } - elsif ( $self->{_is_win32} ) { - # Lose any trailing backslashes in the Win32 paths - s/[\\\/+]$// foreach @inc; - } - - my %seen; - $seen{$_}++ foreach $self->_default_inc(); - @inc = grep !$seen{$_}++, @inc; - - return @inc; -} - - -{ # Without caching, _default_inc() takes a huge amount of time - my %cache; - sub _default_inc { - my $self = shift; - my $perl = $self->_command; - $cache{$perl} ||= [do { - local $ENV{PERL5LIB}; - my @inc =`$perl -le "print join qq[\\n], \@INC"`; - chomp @inc; - }]; - return @{$cache{$perl}}; - } -} - - -=for private $strap->_restore_PERL5LIB() - - $self->_restore_PERL5LIB; - -This restores the original value of the C<PERL5LIB> environment variable. -Necessary on VMS, otherwise a no-op. - -=cut - -sub _restore_PERL5LIB { - my($self) = shift; - - return unless $self->{_is_vms}; - - if (defined $self->{_old5lib}) { - $ENV{PERL5LIB} = $self->{_old5lib}; - } -} - -=head1 Parsing - -Methods for identifying what sort of line you're looking at. - -=for private _is_diagnostic - - my $is_diagnostic = $strap->_is_diagnostic($line, \$comment); - -Checks if the given line is a comment. If so, it will place it into -C<$comment> (sans #). - -=cut - -sub _is_diagnostic { - my($self, $line, $comment) = @_; - - if( $line =~ /^\s*\#(.*)/ ) { - $$comment = $1; - return $YES; - } - else { - return $NO; - } -} - -=for private _is_header - - my $is_header = $strap->_is_header($line); - -Checks if the given line is a header (1..M) line. If so, it places how -many tests there will be in C<< $strap->{max} >>, a list of which tests -are todo in C<< $strap->{todo} >> and if the whole test was skipped -C<< $strap->{skip_all} >> contains the reason. - -=cut - -# Regex for parsing a header. Will be run with /x -my $Extra_Header_Re = <<'REGEX'; - ^ - (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set - (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason -REGEX - -sub _is_header { - my($self, $line) = @_; - - if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) { - $self->{max} = $max; - assert( $self->{max} >= 0, 'Max # of tests looks right' ); - - if( defined $extra ) { - my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo; - - $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo; - - if( $self->{max} == 0 ) { - $reason = '' unless defined $skip and $skip =~ /^Skip/i; - } - - $self->{skip_all} = $reason; - } - - return $YES; - } - else { - return $NO; - } -} - -=for private _is_bail_out - - my $is_bail_out = $strap->_is_bail_out($line, \$reason); - -Checks if the line is a "Bail out!". Places the reason for bailing -(if any) in $reason. - -=cut - -sub _is_bail_out { - my($self, $line, $reason) = @_; - - if( $line =~ /^Bail out!\s*(.*)/i ) { - $$reason = $1 if $1; - return $YES; - } - else { - return $NO; - } -} - -=for private _reset_file_state - - $strap->_reset_file_state; - -Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>, -etc. so it's ready to parse the next file. - -=cut - -sub _reset_file_state { - my($self) = shift; - - delete @{$self}{qw(max skip_all todo too_many_tests)}; - $self->{line} = 0; - $self->{saw_header} = 0; - $self->{saw_bailout}= 0; - $self->{lone_not_line} = 0; - $self->{bailout_reason} = ''; - $self->{'next'} = 1; -} - -=head1 EXAMPLES - -See F<examples/mini_harness.plx> for an example of use. - -=head1 AUTHOR - -Michael G Schwern C<< <schwern at pobox.com> >>, currently maintained by -Andy Lester C<< <andy at petdance.com> >>. - -=head1 SEE ALSO - -L<Test::Harness> - -=cut - -sub _def_or_blank { - return $_[0] if defined $_[0]; - return ""; -} - -sub set_callback { - my $self = shift; - $self->{callback} = shift; -} - -sub callback { - my $self = shift; - return $self->{callback}; -} - -1; diff --git a/lib/Test/Harness/TAP.pod b/lib/Test/Harness/TAP.pod deleted file mode 100644 index deb506dbeb..0000000000 --- a/lib/Test/Harness/TAP.pod +++ /dev/null @@ -1,492 +0,0 @@ -=head1 NAME - -Test::Harness::TAP - Documentation for the TAP format - -=head1 SYNOPSIS - -TAP, the Test Anything Protocol, is Perl's simple text-based interface -between testing modules such as Test::More and the test harness -Test::Harness. - -=head1 TODO - -Exit code of the process. - -=head1 THE TAP FORMAT - -TAP's general format is: - - 1..N - ok 1 Description # Directive - # Diagnostic - .... - ok 47 Description - ok 48 Description - more tests.... - -For example, a test file's output might look like: - - 1..4 - ok 1 - Input file opened - not ok 2 - First line of the input valid - ok 3 - Read the rest of the file - not ok 4 - Summarized correctly # TODO Not written yet - -=head1 HARNESS BEHAVIOR - -In this document, the "harness" is any program analyzing TAP output. -Typically this will be Perl's I<prove> program, or the underlying -C<Test::Harness::runtests> subroutine. - -A harness must only read TAP output from standard output and not -from standard error. Lines written to standard output matching -C</^(not )?ok\b/> must be interpreted as test lines. All other -lines must not be considered test output. - -=head1 TESTS LINES AND THE PLAN - -=head2 The plan - -The plan tells how many tests will be run, or how many tests have -run. It's a check that the test file hasn't stopped prematurely. -It must appear once, whether at the beginning or end of the output. - -The plan is usually the first line of TAP output and it specifies how -many test points are to follow. For example, - - 1..10 - -means you plan on running 10 tests. This is a safeguard in case your test -file dies silently in the middle of its run. The plan is optional but if -there is a plan before the test points it must be the first non-diagnostic -line output by the test file. - -In certain instances a test file may not know how many test points -it will ultimately be running. In this case the plan can be the last -non-diagnostic line in the output. - -The plan cannot appear in the middle of the output, nor can it appear more -than once. - -=head2 The test line - -The core of TAP is the test line. A test file prints one test line test -point executed. There must be at least one test line in TAP output. Each -test line comprises the following elements: - -=over 4 - -=item * C<ok> or C<not ok> - -This tells whether the test point passed or failed. It must be -at the beginning of the line. C</^not ok/> indicates a failed test -point. C</^ok/> is a successful test point. This is the only mandatory -part of the line. - -Note that unlike the Directives below, C<ok> and C<not ok> are -case-sensitive. - -=item * Test number - -TAP expects the C<ok> or C<not ok> to be followed by a test point -number. If there is no number the harness must maintain -its own counter until the script supplies test numbers again. So -the following test output - - 1..6 - not ok - ok - not ok - ok - ok - -has five tests. The sixth is missing. Test::Harness will generate - - FAILED tests 1, 3, 6 - Failed 3/6 tests, 50.00% okay - -=item * Description - -Any text after the test number but before a C<#> is the description of -the test point. - - ok 42 this is the description of the test - -Descriptions should not begin with a digit so that they are not confused -with the test point number. - -The harness may do whatever it wants with the description. - -=item * Directive - -The test point may include a directive, following a hash on the -test line. There are currently two directives allowed: C<TODO> and -C<SKIP>. These are discussed below. - -=back - -To summarize: - -=over 4 - -=item * ok/not ok (required) - -=item * Test number (recommended) - -=item * Description (recommended) - -=item * Directive (only when necessary) - -=back - -=head1 DIRECTIVES - -Directives are special notes that follow a C<#> on the test line. -Only two are currently defined: C<TODO> and C<SKIP>. Note that -these two keywords are not case-sensitive. - -=head2 TODO tests - -If the directive starts with C<# TODO>, the test is counted as a -todo test, and the text after C<TODO> is the explanation. - - not ok 13 # TODO bend space and time - -Note that if the TODO has an explanation it must be separated from -C<TODO> by a space. - -These tests represent a feature to be implemented or a bug to be fixed -and act as something of an executable "things to do" list. They are -B<not> expected to succeed. Should a todo test point begin succeeding, -the harness should report it as a bonus. This indicates that whatever -you were supposed to do has been done and you should promote this to a -normal test point. - -=head2 Skipping tests - -If the directive starts with C<# SKIP>, the test is counted as having -been skipped. If the whole test file succeeds, the count of skipped -tests is included in the generated output. The harness should report -the text after C< # SKIP\S*\s+> as a reason for skipping. - - ok 23 # skip Insufficient flogiston pressure. - -Similarly, one can include an explanation in a plan line, -emitted if the test file is skipped completely: - - 1..0 # Skipped: WWW::Mechanize not installed - -=head1 OTHER LINES - -=head2 Bail out! - -As an emergency measure a test script can decide that further tests -are useless (e.g. missing dependencies) and testing should stop -immediately. In that case the test script prints the magic words - - Bail out! - -to standard output. Any message after these words must be displayed -by the interpreter as the reason why testing must be stopped, as -in - - Bail out! MySQL is not running. - -=head2 Diagnostics - -Additional information may be put into the testing output on separate -lines. Diagnostic lines should begin with a C<#>, which the harness must -ignore, at least as far as analyzing the test results. The harness is -free, however, to display the diagnostics. Typically diagnostics are -used to provide information about the environment in which test file is -running, or to delineate a group of tests. - - ... - ok 18 - Closed database connection - # End of database section. - # This starts the network part of the test. - # Daemon started on port 2112 - ok 19 - Opened socket - ... - ok 47 - Closed socket - # End of network tests - -=head2 Anything else - -Any output line that is not a plan, a test line or a diagnostic is -incorrect. How a harness handles the incorrect line is undefined. -Test::Harness silently ignores incorrect lines, but will become more -stringent in the future. - -=head1 EXAMPLES - -All names, places, and events depicted in any example are wholly -fictitious and bear no resemblance to, connection with, or relation to any -real entity. Any such similarity is purely coincidental, unintentional, -and unintended. - -=head2 Common with explanation - -The following TAP listing declares that six tests follow as well as -provides handy feedback as to what the test is about to do. All six -tests pass. - - 1..6 - # - # Create a new Board and Tile, then place - # the Tile onto the board. - # - ok 1 - The object isa Board - ok 2 - Board size is zero - ok 3 - The object isa Tile - ok 4 - Get possible places to put the Tile - ok 5 - Placing the tile produces no error - ok 6 - Board size is 1 - -=head2 Unknown amount and failures - -This hypothetical test program ensures that a handful of servers are -online and network-accessible. Because it retrieves the hypothetical -servers from a database, it doesn't know exactly how many servers it -will need to ping. Thus, the test count is declared at the bottom after -all the test points have run. Also, two of the tests fail. - - ok 1 - retrieving servers from the database - # need to ping 6 servers - ok 2 - pinged diamond - ok 3 - pinged ruby - not ok 4 - pinged saphire - ok 5 - pinged onyx - not ok 6 - pinged quartz - ok 7 - pinged gold - 1..7 - -=head2 Giving up - -This listing reports that a pile of tests are going to be run. However, -the first test fails, reportedly because a connection to the database -could not be established. The program decided that continuing was -pointless and exited. - - 1..573 - not ok 1 - database handle - Bail out! Couldn't connect to database. - -=head2 Skipping a few - -The following listing plans on running 5 tests. However, our program -decided to not run tests 2 thru 5 at all. To properly report this, -the tests are marked as being skipped. - - 1..5 - ok 1 - approved operating system - # $^0 is solaris - ok 2 - # SKIP no /sys directory - ok 3 - # SKIP no /sys directory - ok 4 - # SKIP no /sys directory - ok 5 - # SKIP no /sys directory - -=head2 Skipping everything - -This listing shows that the entire listing is a skip. No tests were run. - - 1..0 # skip because English-to-French translator isn't installed - -=head2 Got spare tuits? - -The following example reports that four tests are run and the last two -tests failed. However, because the failing tests are marked as things -to do later, they are considered successes. Thus, a harness should report -this entire listing as a success. - - 1..4 - ok 1 - Creating test program - ok 2 - Test program runs, no error - not ok 3 - infinite loop # TODO halting problem unsolved - not ok 4 - infinite loop 2 # TODO halting problem unsolved - -=head2 Creative liberties - -This listing shows an alternate output where the test numbers aren't -provided. The test also reports the state of a ficticious board game in -diagnostic form. Finally, the test count is reported at the end. - - ok - created Board - ok - ok - ok - ok - ok - ok - ok - # +------+------+------+------+ - # | |16G | |05C | - # | |G N C | |C C G | - # | | G | | C +| - # +------+------+------+------+ - # |10C |01G | |03C | - # |R N G |G A G | |C C C | - # | R | G | | C +| - # +------+------+------+------+ - # | |01G |17C |00C | - # | |G A G |G N R |R N R | - # | | G | R | G | - # +------+------+------+------+ - ok - board has 7 tiles + starter tile - 1..9 - -=head1 Non-Perl TAP - -In Perl, we use Test::Simple and Test::More to generate TAP output. -Other languages have solutions that generate TAP, so that they can take -advantage of Test::Harness. - -The following sections are provided by their maintainers, and may not -be up-to-date. - -=head2 C/C++ - -libtap makes it easy to write test programs in C that produce -TAP-compatible output. Modeled on the Test::More API, libtap contains -all the functions you need to: - -=over 4 - -=item * Specify a test plan - -=item * Run tests - -=item * Skip tests in certain situations - -=item * Have TODO tests - -=item * Produce TAP compatible diagnostics - -=back - -More information about libtap, including download links, checksums, -anonymous access to the Subersion repository, and a bug tracking -system, can be found at: - - http://jc.ngo.org.uk/trac-bin/trac.cgi/wiki/LibTap - -(Nik Clayton, April 17, 2006) - -=head2 Python - -PyTap will, when it's done, provide a simple, assertive (Test::More-like) -interface for writing tests in Python. It will output TAP and will -include the functionality found in Test::Builder and Test::More. It will -try to make it easy to add more test code (so you can write your own -C<TAP.StringDiff>, for example. - -Right now, it's got a fair bit of the basics needed to emulate Test::More, -and I think it's easy to add more stuff -- just like Test::Builder, -there's a singleton that you can get at easily. - -I need to better identify and finish implementing the most basic tests. -I am not a Python guru, I just use it from time to time, so my aim may -not be true. I need to write tests for it, which means either relying -on Perl for the tester tester, or writing one in Python. - -Here's a sample test, as found in my Subversion: - - from TAP.Simple import * - - plan(15) - - ok(1) - ok(1, "everything is OK!") - ok(0, "always fails") - - is_ok(10, 10, "is ten ten?") - is_ok(ok, ok, "even ok is ok!") - ok(id(ok), "ok is not the null pointer") - ok(True, "the Truth will set you ok") - ok(not False, "and nothing but the truth") - ok(False, "and we'll know if you lie to us") - - isa_ok(10, int, "10") - isa_ok('ok', str, "some string") - - ok(0, "zero is true", todo="be more like Ruby!") - ok(None, "none is true", skip="not possible in this universe") - - eq_ok("not", "equal", "two strings are not equal"); - -(Ricardo Signes, April 17, 2006) - -=head2 JavaScript - -Test.Simple looks and acts just like TAP, although in reality it's -tracking test results in an object rather than scraping them from a -print buffer. - - http://openjsan.org/doc/t/th/theory/Test/Simple/ - -(David Wheeler, April 17, 2006) - -=head2 PHP - -All the big PHP players now produce TAP - -=over - -=item * phpt - -Outputs TAP by default as of the yet-to-be-released PEAR 1.5.0 - - http://pear.php.net/PEAR - -=item * PHPUnit - -Has a TAP logger (since 2.3.4) - - http://www.phpunit.de/wiki/Main_Page - -=item * SimpleTest - -There's a third-party TAP reporting extension for SimpleTest - - http://www.digitalsandwich.com/archives/51-Updated-Simpletest+Apache-Test.html - -=item * Apache-Test - -Apache-Test's PHP writes TAP by default and includes the standalone -test-more.php - - http://search.cpan.org/dist/Apache-Test/ - -=back - -(Geoffrey Young, April 17, 2006) - -=head1 AUTHORS - -Andy Lester, based on the original Test::Harness documentation by Michael Schwern. - -=head1 ACKNOWLEDGEMENTS - -Thanks to -Pete Krawczyk, -Paul Johnson, -Ian Langworth -and Nik Clayton -for help and contributions on this document. - -The basis for the TAP format was created by Larry Wall in the -original test script for Perl 1. Tim Bunce and Andreas Koenig -developed it further with their modifications to Test::Harness. - -=head1 COPYRIGHT - -Copyright 2003-2005 by -Michael G Schwern C<< <schwern@pobox.com> >>, -Andy Lester C<< <andy@petdance.com> >>. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See L<http://www.perl.com/perl/misc/Artistic.html>. - -=cut diff --git a/lib/Test/Harness/Util.pm b/lib/Test/Harness/Util.pm deleted file mode 100644 index 0cda2fee6f..0000000000 --- a/lib/Test/Harness/Util.pm +++ /dev/null @@ -1,133 +0,0 @@ -package Test::Harness::Util; - -use strict; -use vars qw($VERSION); -$VERSION = '0.01'; - -use File::Spec; -use Exporter; -use vars qw( @ISA @EXPORT @EXPORT_OK ); - -@ISA = qw( Exporter ); -@EXPORT = (); -@EXPORT_OK = qw( all_in shuffle blibdirs ); - -=head1 NAME - -Test::Harness::Util - Utility functions for Test::Harness::* - -=head1 SYNOPSIS - -Utility functions for Test::Harness::* - -=head1 PUBLIC FUNCTIONS - -The following are all available to be imported to your module. No symbols -are exported by default. - -=head2 all_in( {parm => value, parm => value} ) - -Finds all the F<*.t> in a directory. Knows to skip F<.svn> and F<CVS> -directories. - -Valid parms are: - -=over - -=item start - -Starting point for the search. Defaults to ".". - -=item recurse - -Flag to say whether it should recurse. Default to true. - -=back - -=cut - -sub all_in { - my $parms = shift; - my %parms = ( - start => ".", - recurse => 1, - %$parms, - ); - - my @hits = (); - my $start = $parms{start}; - - local *DH; - if ( opendir( DH, $start ) ) { - my @files = sort readdir DH; - closedir DH; - for my $file ( @files ) { - next if $file eq File::Spec->updir || $file eq File::Spec->curdir; - next if $file eq ".svn"; - next if $file eq "CVS"; - - my $currfile = File::Spec->catfile( $start, $file ); - if ( -d $currfile ) { - push( @hits, all_in( { %parms, start => $currfile } ) ) if $parms{recurse}; - } - else { - push( @hits, $currfile ) if $currfile =~ /\.t$/; - } - } - } - else { - warn "$start: $!\n"; - } - - return @hits; -} - -=head1 shuffle( @list ) - -Returns a shuffled copy of I<@list>. - -=cut - -sub shuffle { - # Fisher-Yates shuffle - my $i = @_; - while ($i) { - my $j = rand $i--; - @_[$i, $j] = @_[$j, $i]; - } -} - - -=head2 blibdir() - -Finds all the blib directories. Stolen directly from blib.pm - -=cut - -sub blibdirs { - my $dir = File::Spec->curdir; - if ($^O eq 'VMS') { - ($dir = VMS::Filespec::unixify($dir)) =~ s-/\z--; - } - my $archdir = "arch"; - if ( $^O eq "MacOS" ) { - # Double up the MP::A so that it's not used only once. - $archdir = $MacPerl::Architecture = $MacPerl::Architecture; - } - - my $i = 5; - while ($i--) { - my $blib = File::Spec->catdir( $dir, "blib" ); - my $blib_lib = File::Spec->catdir( $blib, "lib" ); - my $blib_arch = File::Spec->catdir( $blib, $archdir ); - - if ( -d $blib && -d $blib_arch && -d $blib_lib ) { - return ($blib_arch,$blib_lib); - } - $dir = File::Spec->catdir($dir, File::Spec->updir); - } - warn "$0: Cannot find blib\n"; - return; -} - -1; diff --git a/lib/Test/Harness/bin/prove b/lib/Test/Harness/bin/prove index fb5bf0f0dc..ec58d7a234 100644 --- a/lib/Test/Harness/bin/prove +++ b/lib/Test/Harness/bin/prove @@ -1,292 +1,244 @@ #!/usr/bin/perl -w use strict; +use App::Prove; -use Test::Harness; -use Test::Harness::Util qw( all_in blibdirs shuffle ); - -use Getopt::Long; -use Pod::Usage 1.12; -use File::Spec; - -use vars qw( $VERSION ); -$VERSION = '2.64'; - -my $shuffle = 0; -my $dry = 0; -my $blib = 0; -my $lib = 0; -my $recurse = 0; -my @includes = (); -my @switches = (); - -# Allow cuddling the paths with the -I -@ARGV = map { /^(-I)(.+)/ ? ($1,$2) : $_ } @ARGV; - -# Stick any default switches at the beginning, so they can be overridden -# by the command line switches. -unshift @ARGV, split( ' ', $ENV{PROVE_SWITCHES} ) if defined $ENV{PROVE_SWITCHES}; - -Getopt::Long::Configure( 'no_ignore_case' ); -Getopt::Long::Configure( 'bundling' ); -GetOptions( - 'b|blib' => \$blib, - 'd|debug' => \$Test::Harness::debug, - 'D|dry' => \$dry, - 'h|help|?' => sub {pod2usage({-verbose => 1}); exit}, - 'H|man' => sub {pod2usage({-verbose => 2}); exit}, - 'I=s@' => \@includes, - 'l|lib' => \$lib, - 'perl=s' => \$ENV{HARNESS_PERL}, - 'r|recurse' => \$recurse, - 's|shuffle' => \$shuffle, - 't' => sub { unshift @switches, '-t' }, # Always want -t up front - 'T' => sub { unshift @switches, '-T' }, # Always want -T up front - 'w' => sub { push @switches, '-w' }, - 'W' => sub { push @switches, '-W' }, - 'strap=s' => \$ENV{HARNESS_STRAP_CLASS}, - 'timer' => \$Test::Harness::Timer, - 'v|verbose' => \$Test::Harness::verbose, - 'V|version' => sub { print_version(); exit; }, -) or exit 1; - -$ENV{TEST_VERBOSE} = 1 if $Test::Harness::verbose; - -# Handle blib includes -if ( $blib ) { - my @blibdirs = blibdirs(); - if ( @blibdirs ) { - unshift @includes, @blibdirs; - } - else { - warn "No blib directories found.\n"; - } -} - -# Handle lib includes -if ( $lib ) { - unshift @includes, 'lib'; -} - -# Build up TH switches -push( @switches, map { /\s/ && !/^".*"$/ ? qq["-I$_"] : "-I$_" } @includes ); -$Test::Harness::Switches = join( ' ', @switches ); -print "# \$Test::Harness::Switches: $Test::Harness::Switches\n" if $Test::Harness::debug; - -@ARGV = File::Spec->curdir unless @ARGV; -my @argv_globbed; -my @tests; -if ( $] >= 5.006001 ) { - require File::Glob; - @argv_globbed = map { File::Glob::bsd_glob($_) } @ARGV; -} -else { - @argv_globbed = map { glob } @ARGV; -} - -for ( @argv_globbed ) { - push( @tests, -d $_ ? all_in( { recurse => $recurse, start => $_ } ) : $_ ) -} - -if ( @tests ) { - shuffle(@tests) if $shuffle; - if ( $dry ) { - print join( "\n", @tests, '' ); - } - else { - print "# ", scalar @tests, " tests to run\n" if $Test::Harness::debug; - runtests(@tests); - } -} - -sub print_version { - printf( "prove v%s, using Test::Harness v%s and Perl v%vd\n", - $VERSION, $Test::Harness::VERSION, $^V ); -} +my $app = App::Prove->new; +$app->process_args(@ARGV); +$app->run; __END__ =head1 NAME -prove -- A command-line tool for running tests against Test::Harness +prove - Run tests through a TAP harness. -=head1 SYNOPSIS +=head1 USAGE -prove [options] [files/directories] + prove [options] [files or directories] =head1 OPTIONS - -b, --blib Adds blib/lib to the path for your tests, a la "use blib" - -d, --debug Includes extra debugging information - -D, --dry Dry run: Show the tests to run, but don't run them - -h, --help Display this help - -H, --man Longer manpage for prove - -I Add libraries to @INC, as Perl's -I - -l, --lib Add lib to the path for your tests - --perl Sets the name of the Perl executable to use - -r, --recurse Recursively descend into directories - -s, --shuffle Run the tests in a random order - --strap Define strap class to use - -T Enable tainting checks - -t Enable tainting warnings - --timer Print elapsed time after each test file - -v, --verbose Display standard output of test scripts while running them - -V, --version Display version info +Boolean options: -Single-character options may be stacked. Default options may be set by -specifying the PROVE_SWITCHES environment variable. + -v, --verbose Print all test lines. + -l, --lib Add 'lib' to the path for your tests (-Ilib). + -b, --blib Add 'blib/lib' to the path for your tests (-Iblib/lib). + -s, --shuffle Run the tests in random order. + -c, --color Colored test output (default). + --nocolor Do not color test output. + -f, --failures Only show failed tests. + --fork Fork to run harness in multiple processes + -m, --merge Merge test scripts' STDERR with their STDOUT. + -r, --recurse Recursively descend into directories. + --reverse Run the tests in reverse order. + -q, --quiet Suppress some test output while running tests. + -Q, --QUIET Only print summary results. + -p, --parse Show full list of TAP parse errors, if any. + --directives Only show results with TODO or SKIP directives. + --timer Print elapsed time after each test. + -T Enable tainting checks. + -t Enable tainting warnings. + -W Enable fatal warnings. + -w Enable warnings. + -h, --help Display this help + -?, Display this help + -H, --man Longer manpage for prove + --norc Don't process default .proverc -=head1 OVERVIEW +Options that take arguments: -F<prove> is a command-line interface to the test-running functionality -of C<Test::Harness>. With no arguments, it will run all tests in the -current directory. + -I Library paths to include. + -P Load plugin (searches App::Prove::Plugin::*.) + -M Load a module. + -e, --exec Interpreter to run the tests ('' for compiled tests.) + --harness Define test harness to use. See TAP::Harness. + --formatter Result formatter to use. See TAP::Harness. + -a, --archive Store the resulting TAP in an archive file. + -j, --jobs N Run N test jobs in parallel (try 9.) + --state=opts Control prove's persistent state. + --rc=rcfile Process options from rcfile -Shell metacharacters may be used with command lines options and will be exanded -via C<File::Glob::bsd_glob>. +=head1 NOTES -=head1 PROVE VS. "MAKE TEST" +=head2 .proverc -F<prove> has a number of advantages over C<make test> when doing development. +If F<~/.proverc> or F<./.proverc> exist they will be read and any +options they contain processed before the command line options. Options +in F<.proverc> are specified in the same way as command line options: -=over 4 + # .proverc + --state=hot,fast,save + -j9 --fork -=item * F<prove> is designed as a development tool +Additional option files may be specified with the C<--rc> option. +Default option file processing is disabled by the C<--norc> option. -Perl users typically run the test harness through a makefile via -C<make test>. That's fine for module distributions, but it's -suboptimal for a test/code/debug development cycle. +Under Windows and VMS the option file is named F<_proverc> rather than +F<.proverc> and is sought only in the current directory. -=item * F<prove> is granular +=head2 Reading from C<STDIN> -F<prove> lets your run against only the files you want to check. -Running C<prove t/live/ t/master.t> checks every F<*.t> in F<t/live>, -plus F<t/master.t>. +If you have a list of tests (or URLs, or anything else you want to test) in a +file, you can add them to your tests by using a '-': -=item * F<prove> has an easy verbose mode + prove - < my_list_of_things_to_test.txt -F<prove> has a C<-v> option to see the raw output from the tests. -To do this with C<make test>, you must set C<HARNESS_VERBOSE=1> in -the environment. +See the C<README> in the C<examples> directory of this distribution. -=item * F<prove> can run under taint mode +=head2 Default Test Directory -F<prove>'s C<-T> runs your tests under C<perl -T>, and C<-t> runs them -under C<perl -t>. +If no files or directories are supplied, C<prove> looks for all files +matching the pattern C<t/*.t>. -=item * F<prove> can shuffle tests +=head2 Colored Test Output -You can use F<prove>'s C<--shuffle> option to try to excite problems -that don't show up when tests are run in the same order every time. +Colored test output is the default, but if output is not to a +terminal, color is disabled. You can override this by adding the +C<--color> switch. -=item * F<prove> doesn't rely on a make tool +Color support requires L<Term::ANSIColor> on Unix-like platforms and +L<Win32::Console> windows. If the necessary module is not installed +colored output will not be available. -Not everyone wants to write a makefile, or use L<ExtUtils::MakeMaker> -to do so. F<prove> has no external dependencies. +=head2 Arguments to Tests -=item * Not everything is a module +It is possible to supply arguments to tests. To do so separate them from +prove's own arguments with the arisdottle, '::'. For example -More and more users are using Perl's testing tools outside the -context of a module distribution, and may not even use a makefile -at all. + prove -v t/mytest.t :: --url http://example.com + +would run F<t/mytest.t> with the options '--url http://example.com'. +When running multiple tests they will each receive the same arguments. -=back +=head2 C<--exec> -=head1 COMMAND LINE OPTIONS +Normally you can just pass a list of Perl tests and the harness will know how +to execute them. However, if your tests are not written in Perl or if you +want all tests invoked exactly the same way, use the C<-e>, or C<--exec> +switch: -=head2 -b, --blib + prove --exec '/usr/bin/ruby -w' t/ + prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/ + prove --exec '/path/to/my/customer/exec' -Adds blib/lib to the path for your tests, a la "use blib". +=head2 C<--merge> -=head2 -d, --debug +If you need to make sure your diagnostics are displayed in the correct +order relative to test results you can use the C<--merge> option to +merge the test scripts' STDERR into their STDOUT. -Include debug information about how F<prove> is being run. This -option doesn't show the output from the test scripts. That's handled -by -v,--verbose. +This guarantees that STDOUT (where the test results appear) and STDOUT +(where the diagnostics appear) will stay in sync. The harness will +display any diagnostics your tests emit on STDERR. -=head2 -D, --dry +Caveat: this is a bit of a kludge. In particular note that if anything +that appears on STDERR looks like a test result the test harness will +get confused. Use this option only if you understand the consequences +and can live with the risk. -Dry run: Show the tests to run, but don't run them. +=head2 C<--state> -=head2 -I +You can ask C<prove> to remember the state of previous test runs and +select and/or order the tests to be run this time based on that +saved state. -Add libraries to @INC, as Perl's -I. +The C<--state> switch requires an argument which must be a comma +separated list of one or more of the following options. -=head2 -l, --lib +=over -Add C<lib> to @INC. Equivalent to C<-Ilib>. +=item C<last> -=head2 --perl +Run the same tests as the last time the state was saved. This makes it +possible, for example, to recreate the ordering of a shuffled test. -Sets the C<HARNESS_PERL> environment variable, which controls what -Perl executable will run the tests. + # Run all tests in random order + $ prove -b --state=save --shuffle -=head2 -r, --recurse + # Run them again in the same order + $ prove -b --state=last -Descends into subdirectories of any directories specified, looking for tests. +=item C<failed> -=head2 -s, --shuffle +Run only the tests that failed on the last run. -Sometimes tests are accidentally dependent on tests that have been -run before. This switch will shuffle the tests to be run prior to -running them, thus ensuring that hidden dependencies in the test -order are likely to be revealed. The author hopes the run the -algorithm on the preceding sentence to see if he can produce something -slightly less awkward. + # Run all tests +e $ prove -b --state=save + + # Run failures + $ prove -b --state=failed -=head2 --strap +If you also specify the C<save> option newly passing tests will be +excluded from subsequent runs. -Sets the HARNESS_STRAP_CLASS variable to set which Test::Harness::Straps -variable to use in running the tests. + # Repeat until no more failures + $ prove -b --state=failed,save -=head2 -t +=item C<passed> -Runs test programs under perl's -t taint warning mode. +Run only the passed tests from last time. Useful to make sure that no +new problems have been introduced. -=head2 -T +=item C<all> -Runs test programs under perl's -T taint mode. +Run all tests in normal order. Multple options may be specified, so to +run all tests with the failures from last time first: -=head2 --timer + $ prove -b --state=failed,all,save -Print elapsed time after each test file +=item C<hot> -=head2 -v, --verbose +Run the tests that most recently failed first. The last failure time of +each test is stored. The C<hot> option causes tests to be run in most-recent- +failure order. -Display standard output of test scripts while running them. Also sets -TEST_VERBOSE in case your tests rely on them. + $ prove -b --state=hot,save -=head2 -V, --version +Tests that have never failed will not be selected. To run all tests with +the most recently failed first use -Display version info. + $ prove -b --state=hot,all,save -=head1 BUGS +This combination of options may also be specified thus -Please use the CPAN bug ticketing system at L<http://rt.cpan.org/>. -You can also mail bugs, fixes and enhancements to -C<< <bug-test-harness@rt.cpan.org> >>. + $ prove -b --state=adrian -=head1 TODO +=item C<todo> -=over 4 +Run any tests with todos. -=item * +=item C<slow> -Shuffled tests must be recreatable +Run the tests in slowest to fastest order. This is useful in conjunction +with the C<-j> parallel testing switch to ensure that your slowest tests +start running first. -=back + $ prove -b --state=slow -j9 + +=item C<fast> -=head1 AUTHORS +Run test tests in fastest to slowest order. -Andy Lester C<< <andy at petdance.com> >> +=item C<new> -=head1 COPYRIGHT +Run the tests in newest to oldest order. -Copyright 2004-2006 by Andy Lester C<< <andy at petdance.com> >>. +=item C<old> -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. +Run the tests in oldest to newest order. -See L<http://www.perl.com/perl/misc/Artistic.html>. +=item C<save> + +Save the state on exit. The state is stored in a file called F<.prove> +(F<_prove> on Windows and VMS) in the current directory. + +=back + +The C<--state> switch may be used more than once. + + $ prove -b --state=hot --state=all,save =cut + +# vim:ts=4:sw=4:et:sta diff --git a/lib/Test/Harness/t/000-load.t b/lib/Test/Harness/t/000-load.t new file mode 100644 index 0000000000..7989b618f3 --- /dev/null +++ b/lib/Test/Harness/t/000-load.t @@ -0,0 +1,49 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 58; + +BEGIN { + + # TAP::Parser must come first + my @classes = qw( + TAP::Parser + App::Prove + App::Prove::State + TAP::Base + TAP::Formatter::Color + TAP::Formatter::Console::ParallelSession + TAP::Formatter::Console::Session + TAP::Formatter::Console + TAP::Harness + TAP::Parser::Aggregator + TAP::Parser::Grammar + TAP::Parser::Iterator::Array + TAP::Parser::Iterator::Process + TAP::Parser::Iterator::Stream + TAP::Parser::Iterator + TAP::Parser::Multiplexer + TAP::Parser::Result::Bailout + TAP::Parser::Result::Comment + TAP::Parser::Result::Plan + TAP::Parser::Result::Test + TAP::Parser::Result::Unknown + TAP::Parser::Result::Version + TAP::Parser::Result::YAML + TAP::Parser::Result + TAP::Parser::Source::Perl + TAP::Parser::Source + TAP::Parser::YAMLish::Reader + TAP::Parser::YAMLish::Writer + Test::Harness + ); + + foreach my $class (@classes) { + use_ok $class or BAIL_OUT("Could not load $class"); + is $class->VERSION, TAP::Parser->VERSION, + "... and $class should have the correct version"; + } + diag("Testing Test::Harness $Test::Harness::VERSION, Perl $], $^X"); +} diff --git a/lib/Test/Harness/t/aggregator.t b/lib/Test/Harness/t/aggregator.t new file mode 100644 index 0000000000..441e2ba47c --- /dev/null +++ b/lib/Test/Harness/t/aggregator.t @@ -0,0 +1,304 @@ +#!/usr/bin/perl -wT + + +use strict; +use lib 't/lib'; + +use Test::More tests => 79; + +use TAP::Parser; +use TAP::Parser::Iterator; +use TAP::Parser::Aggregator; + +my $tap = <<'END_TAP'; +1..5 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 # skip we have no description +END_TAP + +my $stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] ); +isa_ok $stream, 'TAP::Parser::Iterator'; + +my $parser1 = TAP::Parser->new( { stream => $stream } ); +isa_ok $parser1, 'TAP::Parser'; + +$parser1->run; + +$tap = <<'END_TAP'; +1..7 +ok 1 - gentlemen, start your engines +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 +ok 6 - you shall not pass! # TODO should have failed +not ok 7 - Gandalf wins. Game over. # TODO 'bout time! +END_TAP + +my $parser2 = TAP::Parser->new( { tap => $tap } ); +isa_ok $parser2, 'TAP::Parser'; +$parser2->run; + +can_ok 'TAP::Parser::Aggregator', 'new'; +my $agg = TAP::Parser::Aggregator->new; +isa_ok $agg, 'TAP::Parser::Aggregator'; + +can_ok $agg, 'add'; +ok $agg->add( 'tap1', $parser1 ), '... and calling it should succeed'; +ok $agg->add( 'tap2', $parser2 ), '... even if we add more than one parser'; +eval { $agg->add( 'tap1', $parser1 ) }; +like $@, qr/^You already have a parser for \Q(tap1)/, + '... but trying to reuse a description should be fatal'; + +can_ok $agg, 'parsers'; +is scalar $agg->parsers, 2, + '... and it should report how many parsers it has'; +is_deeply [ $agg->parsers ], [ $parser1, $parser2 ], + '... or which parsers it has'; +is_deeply $agg->parsers('tap2'), $parser2, '... or reporting a single parser'; +is_deeply [ $agg->parsers(qw(tap2 tap1)) ], [ $parser2, $parser1 ], + '... or a group'; + +# test aggregate results + +can_ok $agg, 'passed'; +is $agg->passed, 10, + '... and we should have the correct number of passed tests'; +is_deeply [ $agg->passed ], [qw(tap1 tap2)], + '... and be able to get their descriptions'; + +can_ok $agg, 'failed'; +is $agg->failed, 2, + '... and we should have the correct number of failed tests'; +is_deeply [ $agg->failed ], [qw(tap1 tap2)], + '... and be able to get their descriptions'; + +can_ok $agg, 'todo'; +is $agg->todo, 4, '... and we should have the correct number of todo tests'; +is_deeply [ $agg->todo ], [qw(tap1 tap2)], + '... and be able to get their descriptions'; + +can_ok $agg, 'skipped'; +is $agg->skipped, 1, + '... and we should have the correct number of skipped tests'; +is_deeply [ $agg->skipped ], [qw(tap1)], + '... and be able to get their descriptions'; + +can_ok $agg, 'parse_errors'; +is $agg->parse_errors, 0, '... and the correct number of parse errors'; +is_deeply [ $agg->parse_errors ], [], + '... and be able to get their descriptions'; + +can_ok $agg, 'todo_passed'; +is $agg->todo_passed, 1, + '... and the correct number of unexpectedly succeeded tests'; +is_deeply [ $agg->todo_passed ], [qw(tap2)], + '... and be able to get their descriptions'; + +can_ok $agg, 'total'; +is $agg->total, $agg->passed + $agg->failed, + '... and we should have the correct number of total tests'; + +can_ok $agg, 'has_problems'; +ok $agg->has_problems, '... and it should report true if there are problems'; + +can_ok $agg, 'has_errors'; +ok $agg->has_errors, '... and it should report true if there are errors'; + +can_ok $agg, 'get_status'; +is $agg->get_status, 'FAIL', '... and it should tell us the tests failed'; + +can_ok $agg, 'all_passed'; +ok !$agg->all_passed, '... and it should tell us not all tests passed'; + +# coverage testing + +# _get_parsers +# bad descriptions +# currently the $agg object has descriptions tap1 and tap2 +# call _get_parsers with another description. +# $agg will call its _croak method +my @die; + +eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $agg->_get_parsers('no_such_parser_for'); +}; + +is @die, 1, + 'coverage tests for missing parsers... and we caught just one death message'; +like pop(@die), + qr/^A parser for \(no_such_parser_for\) could not be found at /, + '... and it was the expected death message'; + +# _get_parsers in scalar context + +my $gp = $agg->_get_parsers(qw(tap1 tap2)) + ; # should return ref to array containing parsers for tap1 and tap2 + +is @$gp, 2, + 'coverage tests for _get_parser in scalar context... and we got the right number of parsers'; +isa_ok( $_, 'TAP::Parser' ) foreach (@$gp); + +# _get_parsers +# todo_failed - this is a deprecated method, so it (and these tests) +# can be removed eventually. However, it is showing up in the coverage +# as never tested. +my @warn; + +eval { + local $SIG{__WARN__} = sub { push @warn, @_ }; + + $agg->todo_failed(); +}; + +# check the warning, making sure to capture the fullstops correctly (not +# as "any char" matches) +is @warn, 1, + 'coverage tests for deprecated todo_failed... and just one warning caught'; +like pop(@warn), + qr/^"todo_failed" is deprecated[.] Please use "todo_passed"[.] See the docs[.] at/, + '... and it was the expected warning'; + +# has_problems +# this has a large number of conditions 'OR'd together, so the tests get +# a little complicated here + +# currently, we have covered the cases of failed() being true and none +# of the summary methods failing + +# we need to set up test cases for +# 1. !failed && todo_passed +# 2. !failed && !todo_passed && parse_errors +# 3. !failed && !todo_passed && !parse_errors && exit +# 4. !failed && !todo_passed && !parse_errors && !exit && wait + +# note there is nothing wrong per se with the has_problems logic, these +# are simply coverage tests + +# 1. !failed && todo_passed + +$agg = TAP::Parser::Aggregator->new(); +isa_ok $agg, 'TAP::Parser::Aggregator'; + +$tap = <<'END_TAP'; +1..1 +ok 1 - you shall not pass! # TODO should have failed +END_TAP + +my $parser3 = TAP::Parser->new( { tap => $tap } ); +isa_ok $parser3, 'TAP::Parser'; +$parser3->run; + +$agg->add( 'tap3', $parser3 ); + +is $agg->passed, 1, + 'coverage tests for !failed && todo_passed... and we should have the correct number of passed tests'; +is $agg->failed, 0, + '... and we should have the correct number of failed tests'; +is $agg->todo_passed, 1, + '... and the correct number of unexpectedly succeeded tests'; +ok $agg->has_problems, + '... and it should report true that there are problems'; +is $agg->get_status, 'PASS', + '... and the status should be passing'; +ok !$agg->has_errors, + '.... but it should not report any errors'; +ok $agg->all_passed, + '... bonus tests should be passing tests, too'; + +# 2. !failed && !todo_passed && parse_errors + +$agg = TAP::Parser::Aggregator->new(); + +$tap = <<'END_TAP'; +1..-1 +END_TAP + +my $parser4 = TAP::Parser->new( { tap => $tap } ); +isa_ok $parser4, 'TAP::Parser'; +$parser4->run; + +$agg->add( 'tap4', $parser4 ); + +is $agg->passed, 0, + 'coverage tests for !failed && !todo_passed && parse_errors... and we should have the correct number of passed tests'; +is $agg->failed, 0, + '... and we should have the correct number of failed tests'; +is $agg->todo_passed, 0, + '... and the correct number of unexpectedly succeeded tests'; +is $agg->parse_errors, 1, '... and the correct number of parse errors'; +ok $agg->has_problems, + '... and it should report true that there are problems'; + +# 3. !failed && !todo_passed && !parse_errors && exit +# now this is a little harder to emulate cleanly through creating tap +# fragments and parsing, as exit and wait collect OS-status codes. +# so we'll get a little funky with $agg and push exit and wait descriptions +# in it - not very friendly to internal rep changes. + +$agg = TAP::Parser::Aggregator->new(); + +$tap = <<'END_TAP'; +1..1 +ok 1 - you shall not pass! +END_TAP + +my $parser5 = TAP::Parser->new( { tap => $tap } ); +$parser5->run; + +$agg->add( 'tap', $parser5 ); + +push @{ $agg->{descriptions_for_exit} }, 'one possible reason'; +$agg->{exit}++; + +is $agg->passed, 1, + 'coverage tests for !failed && !todo_passed && !parse_errors... and we should have the correct number of passed tests'; +is $agg->failed, 0, + '... and we should have the correct number of failed tests'; +is $agg->todo_passed, 0, + '... and the correct number of unexpectedly succeeded tests'; +is $agg->parse_errors, 0, '... and the correct number of parse errors'; + +my @exits = $agg->exit; + +is @exits, 1, '... and the correct number of exits'; +is pop(@exits), 'one possible reason', + '... and we collected the right exit reason'; + +ok $agg->has_problems, + '... and it should report true that there are problems'; + +# 4. !failed && !todo_passed && !parse_errors && !exit && wait + +$agg = TAP::Parser::Aggregator->new(); + +$agg->add( 'tap', $parser5 ); + +push @{ $agg->{descriptions_for_wait} }, 'another possible reason'; +$agg->{wait}++; + +is $agg->passed, 1, + 'coverage tests for !failed && !todo_passed && !parse_errors && !exit... and we should have the correct number of passed tests'; +is $agg->failed, 0, + '... and we should have the correct number of failed tests'; +is $agg->todo_passed, 0, + '... and the correct number of unexpectedly succeeded tests'; +is $agg->parse_errors, 0, '... and the correct number of parse errors'; +is $agg->exit, 0, '... and the correct number of exits'; + +my @waits = $agg->wait; + +is @waits, 1, '... and the correct number of waits'; +is pop(@waits), 'another possible reason', + '... and we collected the right wait reason'; + +ok $agg->has_problems, + '... and it should report true that there are problems'; diff --git a/lib/Test/Harness/t/bailout.t b/lib/Test/Harness/t/bailout.t new file mode 100755 index 0000000000..e10b133e0f --- /dev/null +++ b/lib/Test/Harness/t/bailout.t @@ -0,0 +1,114 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 33; + +use TAP::Parser; + +my $tap = <<'END_TAP'; +1..4 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +Bail out! We ran out of foobar. +END_TAP +my $parser = TAP::Parser->new( { tap => $tap } ); +isa_ok $parser, 'TAP::Parser', + '... we should be able to parse bailed out tests'; + +my @results; +while ( my $result = $parser->next ) { + push @results => $result; +} + +can_ok $parser, 'passed'; +is $parser->passed, 3, + '... and we shold have the correct number of passed tests'; +is_deeply [ $parser->passed ], [ 1, 2, 3 ], + '... and get a list of the passed tests'; + +can_ok $parser, 'failed'; +is $parser->failed, 1, '... and the correct number of failed tests'; +is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests'; + +can_ok $parser, 'actual_passed'; +is $parser->actual_passed, 2, + '... and we shold have the correct number of actually passed tests'; +is_deeply [ $parser->actual_passed ], [ 1, 3 ], + '... and get a list of the actually passed tests'; + +can_ok $parser, 'actual_failed'; +is $parser->actual_failed, 2, + '... and the correct number of actually failed tests'; +is_deeply [ $parser->actual_failed ], [ 2, 4 ], + '... or get a list of the actually failed tests'; + +can_ok $parser, 'todo'; +is $parser->todo, 1, + '... and we should have the correct number of TODO tests'; +is_deeply [ $parser->todo ], [2], '... and get a list of the TODO tests'; + +ok !$parser->skipped, + '... and we should have the correct number of skipped tests'; + +# check the plan + +can_ok $parser, 'plan'; +is $parser->plan, '1..4', '... and we should have the correct plan'; +is $parser->tests_planned, 4, '... and the correct number of tests'; + +# results() is sane? + +ok @results, 'The parser should return results'; +is scalar @results, 8, '... and there should be one for each line'; + +# check the test plan + +my $result = shift @results; +ok $result->is_plan, 'We should have a plan'; + +# a normal, passing test + +my $test = shift @results; +ok $test->is_test, '... and a test'; + +# junk lines should be preserved + +my $unknown = shift @results; +ok $unknown->is_unknown, '... and an unknown line'; + +# a failing test, which also happens to have a directive + +my $failed = shift @results; +ok $failed->is_test, '... and another test'; + +# comments + +my $comment = shift @results; +ok $comment->is_comment, '... and a comment'; + +# another normal, passing test + +$test = shift @results; +ok $test->is_test, '... and another test'; + +# a failing test + +$failed = shift @results; +ok $failed->is_test, '... and yet another test'; + +# ok 5 # skip we have no description +# skipped test +my $bailout = shift @results; +ok $bailout->is_bailout, 'And finally we should have a bailout'; +is $bailout->as_string, 'We ran out of foobar.', + '... and as_string() should return the explanation'; +is $bailout->raw, 'Bail out! We ran out of foobar.', + '... and raw() should return the explanation'; +is $bailout->explanation, 'We ran out of foobar.', + '... and it should have the correct explanation'; diff --git a/lib/Test/Harness/t/base.t b/lib/Test/Harness/t/base.t index 5ad05e90f7..25197f6f76 100644 --- a/lib/Test/Harness/t/base.t +++ b/lib/Test/Harness/t/base.t @@ -1,15 +1,173 @@ -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't'; - @INC = '../lib'; +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 38; + +use TAP::Base; + +{ + + # No callbacks allowed + can_ok 'TAP::Base', 'new'; + my $base = TAP::Base->new(); + isa_ok $base, 'TAP::Base', 'object of correct type'; + foreach my $method (qw(callback _croak _callback_for _initialize)) { + can_ok $base, $method; } + + eval { + $base->callback( + some_event => sub { + + # do nothing + } + ); + }; + like( $@, qr/No callbacks/, 'no callbacks allowed croaks OK' ); + my $cb = $base->_callback_for('some_event'); + ok( !$cb, 'no callback installed' ); +} + +{ + + # No callbacks allowed, constructor should croak + eval { + my $base = TAP::Base->new( + { callbacks => { + some_event => sub { + + # do nothing + } + } + } + ); + }; + like( + $@, qr/No callbacks/, + 'no callbacks in constructor croaks OK' + ); } +package CallbackOK; + +use TAP::Base; +use vars qw(@ISA); +@ISA = 'TAP::Base'; + +sub _initialize { + my $self = shift; + my $args = shift; + $self->SUPER::_initialize( $args, [qw( nice_event other_event )] ); + return $self; +} + +package main; +{ + my $base = CallbackOK->new(); + isa_ok $base, 'TAP::Base'; + + eval { + $base->callback( + some_event => sub { + + # do nothing + } + ); + }; + like( $@, qr/Callback some_event/, 'illegal callback croaks OK' ); + + my ( $nice, $other ) = ( 0, 0 ); + + eval { + $base->callback( other_event => sub { $other-- } ); + $base->callback( nice_event => sub { $nice++; return shift() . 'OK' } + ); + }; + + ok( !$@, 'callbacks installed OK' ); + + my $nice_cbs = $base->_callback_for('nice_event'); + is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' ); + is( scalar @$nice_cbs, 1, 'right number of callbacks' ); + my $nice_cb = $nice_cbs->[0]; + ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' ); + my $got = $nice_cb->('Is '); + is( $got, 'Is OK', 'args passed to callback' ); + cmp_ok( $nice, '==', 1, 'callback calls the right sub' ); + + my $other_cbs = $base->_callback_for('other_event'); + is( ref $other_cbs, 'ARRAY', 'callbacks type ok' ); + is( scalar @$other_cbs, 1, 'right number of callbacks' ); + my $other_cb = $other_cbs->[0]; + ok( ref $other_cb eq 'CODE', 'callback for other_event returned' ); + $other_cb->(); + cmp_ok( $other, '==', -1, 'callback calls the right sub' ); + + my @got = $base->_make_callback( 'nice_event', 'I am ' ); + is( scalar @got, 1, 'right number of results' ); + is( $got[0], 'I am OK', 'callback via _make_callback works' ); +} + +{ + my ( $nice, $other ) = ( 0, 0 ); + + my $base = CallbackOK->new( + { callbacks => { + nice_event => sub { $nice++ } + } + } + ); + + isa_ok $base, 'TAP::Base', 'object creation with callback succeeds'; + + eval { + $base->callback( + some_event => sub { + + # do nothing + } + ); + }; + like( $@, qr/Callback some_event/, 'illegal callback croaks OK' ); + + eval { + $base->callback( other_event => sub { $other-- } ); + }; + + ok( !$@, 'callback installed OK' ); + + my $nice_cbs = $base->_callback_for('nice_event'); + is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' ); + is( scalar @$nice_cbs, 1, 'right number of callbacks' ); + my $nice_cb = $nice_cbs->[0]; + ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' ); + $nice_cb->(); + cmp_ok( $nice, '==', 1, 'callback calls the right sub' ); + + my $other_cbs = $base->_callback_for('other_event'); + is( ref $other_cbs, 'ARRAY', 'callbacks type ok' ); + is( scalar @$other_cbs, 1, 'right number of callbacks' ); + my $other_cb = $other_cbs->[0]; + ok( ref $other_cb eq 'CODE', 'callback for other_event returned' ); + $other_cb->(); + cmp_ok( $other, '==', -1, 'callback calls the right sub' ); + + # my @got = $base->_make_callback( 'nice_event', 'I am ' ); + # is ( scalar @got, 1, 'right number of results' ); + # is( $got[0], 'I am OK', 'callback via _make_callback works' ); + + my $status = undef; -print "1..1\n"; + # Stack another callback + $base->callback( other_event => sub { $status = 'OK'; return 'Aye' } ); -unless (eval 'require Test::Harness') { - print "not ok 1\n"; -} else { - print "ok 1\n"; + my $new_cbs = $base->_callback_for('other_event'); + is( ref $new_cbs, 'ARRAY', 'callbacks type ok' ); + is( scalar @$new_cbs, 2, 'right number of callbacks' ); + my $new_cb = $new_cbs->[1]; + ok( ref $new_cb eq 'CODE', 'callback for new_event returned' ); + my @got = $new_cb->(); + is( $status, 'OK', 'new callback called OK' ); } diff --git a/lib/Test/Harness/t/callbacks.t b/lib/Test/Harness/t/callbacks.t new file mode 100644 index 0000000000..b23762102c --- /dev/null +++ b/lib/Test/Harness/t/callbacks.t @@ -0,0 +1,114 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 10; + +use TAP::Parser; +use TAP::Parser::Iterator; + +my $tap = <<'END_TAP'; +1..5 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 # skip we have no description +END_TAP + +my @tests; +my $plan_output; +my $todo = 0; +my $skip = 0; +my %callbacks = ( + test => sub { + my $test = shift; + push @tests => $test; + $todo++ if $test->has_todo; + $skip++ if $test->has_skip; + }, + plan => sub { + my $plan = shift; + $plan_output = $plan->as_string; + } +); + +my $stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] ); +my $parser = TAP::Parser->new( + { stream => $stream, + callbacks => \%callbacks, + } +); + +can_ok $parser, 'run'; +$parser->run; +is $plan_output, '1..5', 'Plan callbacks should succeed'; +is scalar @tests, $parser->tests_run, '... as should the test callbacks'; + +@tests = (); +$plan_output = ''; +$todo = 0; +$skip = 0; +my $else = 0; +my $all = 0; +my $end = 0; +%callbacks = ( + test => sub { + my $test = shift; + push @tests => $test; + $todo++ if $test->has_todo; + $skip++ if $test->has_skip; + }, + plan => sub { + my $plan = shift; + $plan_output = $plan->as_string; + }, + EOF => sub { + $end = 1 if $all == 8; + }, + ELSE => sub { + $else++; + }, + ALL => sub { + $all++; + }, +); + +$stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] ); +$parser = TAP::Parser->new( + { stream => $stream, + callbacks => \%callbacks, + } +); + +can_ok $parser, 'run'; +$parser->run; +is $plan_output, '1..5', 'Plan callbacks should succeed'; +is scalar @tests, $parser->tests_run, '... as should the test callbacks'; +is $else, 2, '... and the correct number of "ELSE" lines should be seen'; +is $all, 8, '... and the correct total number of lines should be seen'; +is $end, 1, 'EOF callback correctly called'; + +# Check callback name policing + +%callbacks = ( + sometest => sub { }, + plan => sub { }, + random => sub { }, + ALL => sub { }, + ELSES => sub { }, +); + +$stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] ); +eval { + $parser = TAP::Parser->new( + { stream => $stream, + callbacks => \%callbacks, + } + ); +}; + +like $@, qr/Callback/, 'Bad callback keys faulted'; diff --git a/lib/Test/Harness/t/compat/env.t b/lib/Test/Harness/t/compat/env.t new file mode 100644 index 0000000000..ac5c096213 --- /dev/null +++ b/lib/Test/Harness/t/compat/env.t @@ -0,0 +1,39 @@ +#!/usr/bin/perl -w + +# Test that env vars are honoured. + +use strict; +use lib 't/lib'; + +use Test::More ( + $^O eq 'VMS' + ? ( skip_all => 'VMS' ) + : ( tests => 1 ) +); + +use Test::Harness; + +# HARNESS_PERL_SWITCHES + +my $test_template = <<'END'; +#!/usr/bin/perl + +use Test::More tests => 1; + +is $ENV{HARNESS_PERL_SWITCHES}, '-w'; +END + +open TEST, ">env_check_t.tmp"; +print TEST $test_template; +close TEST; + +END { unlink 'env_check_t.tmp'; } + +{ + local $ENV{HARNESS_PERL_SWITCHES} = '-w'; + my ( $tot, $failed ) + = Test::Harness::execute_tests( tests => ['env_check_t.tmp'] ); + is $tot->{bad}, 0; +} + +1; diff --git a/lib/Test/Harness/t/compat/failure.t b/lib/Test/Harness/t/compat/failure.t new file mode 100644 index 0000000000..c1b902bab0 --- /dev/null +++ b/lib/Test/Harness/t/compat/failure.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More tests => 5; + +use File::Spec; +use Test::Harness; + +{ + + #todo_skip 'Harness compatibility incomplete', 5; + #local $TODO = 'Harness compatibility incomplete'; + my $died; + + sub prepare_for_death { + $died = 0; + return sub { $died = 1 } + } + + my $curdir = File::Spec->curdir; + my $sample_tests + = $ENV{PERL_CORE} + ? File::Spec->catdir( $curdir, 'lib', 'sample-tests' ) + : File::Spec->catdir( $curdir, 't', 'sample-tests' ); + + { + local $SIG{__DIE__} = prepare_for_death(); + eval { _runtests( File::Spec->catfile( $sample_tests, "simple" ) ); }; + ok( !$@, "simple lives" ); + is( $died, 0, "Death never happened" ); + } + + { + local $SIG{__DIE__} = prepare_for_death(); + eval { + _runtests( File::Spec->catfile( $sample_tests, "too_many" ) ); + }; + ok( $@, "error OK" ); + ok( $@ =~ m[Failed 1/1], "too_many dies" ); + is( $died, 1, "Death happened" ); + } +} + +sub _runtests { + my (@tests) = @_; + + local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; + local $ENV{HARNESS_VERBOSE} = 0; + local $ENV{HARNESS_DEBUG} = 0; + local $ENV{HARNESS_TIMER} = 0; + + local $Test::Harness::Verbose = -9; + + runtests(@tests); +} + +# vim:ts=4:sw=4:et:sta diff --git a/lib/Test/Harness/t/compat/inc-propagation.t b/lib/Test/Harness/t/compat/inc-propagation.t new file mode 100644 index 0000000000..0b953832c3 --- /dev/null +++ b/lib/Test/Harness/t/compat/inc-propagation.t @@ -0,0 +1,81 @@ +#!/usr/bin/perl -w + +# Test that @INC is propogated from the harness process to the test +# process. + +use strict; +use lib 't/lib'; + +sub has_crazy_patch { + my $sentinel = 'blirpzoffle'; + local $ENV{PERL5LIB} = $sentinel; + my $command = join ' ', + map {qq{"$_"}} ( $^X, '-e', 'print join q(:), @INC' ); + my $path = `$command`; + my @got = ( $path =~ /($sentinel)/g ); + return @got > 1; +} + +use Test::More ( + $^O eq 'VMS' ? ( skip_all => 'VMS' ) + : has_crazy_patch() ? ( skip_all => 'Incompatible @INC patch' ) + : ( tests => 2 ) +); + +use Data::Dumper; +use Test::Harness; + +# Change @INC so we ensure it's preserved. +use lib 'wibble'; + +# TODO: Disabled until we find out why it's breaking on Windows. It's +# not strictly a TODO because it seems pretty likely that it's a Windows +# problem rather than a problem with Test::Harness. + +# Put a stock directory near the beginning. +# use lib $INC[$#INC-2]; + +my $inc = Data::Dumper->new( [ \@INC ] )->Terse(1)->Purity(1)->Dump; +my $taint_inc + = Data::Dumper->new( [ [ grep { $_ ne '.' } @INC ] ] )->Terse(1)->Purity(1) + ->Dump; + +my $test_template = <<'END'; +#!/usr/bin/perl %s + +use Test::More tests => 2; + +sub _strip_dups { + my %%dups; + # Drop '.' which sneaks in on some platforms + return grep { $_ ne '.' } grep { !$dups{$_}++ } @_; +} + +# Make sure we did something sensible with PERL5LIB +like $ENV{PERL5LIB}, qr{wibble}; + +is_deeply( + [_strip_dups(@INC)], + [_strip_dups(@{%s})], + '@INC propagated to test' +) or do { + diag join ",\n", _strip_dups(@INC); + diag '-----------------'; + diag join ",\n", _strip_dups(@{%s}); +}; +END + +open TEST, ">inc_check.t.tmp"; +printf TEST $test_template, '', $inc, $inc; +close TEST; + +open TEST, ">inc_check_taint.t.tmp"; +printf TEST $test_template, '-T', $taint_inc, $taint_inc; +close TEST; +END { 1 while unlink 'inc_check_taint.t.tmp', 'inc_check.t.tmp'; } + +for my $test ( 'inc_check_taint.t.tmp', 'inc_check.t.tmp' ) { + my ( $tot, $failed ) = Test::Harness::execute_tests( tests => [$test] ); + is $tot->{bad}, 0; +} +1; diff --git a/lib/Test/Harness/t/compat/inc_taint.t b/lib/Test/Harness/t/compat/inc_taint.t new file mode 100644 index 0000000000..f0101c396f --- /dev/null +++ b/lib/Test/Harness/t/compat/inc_taint.t @@ -0,0 +1,45 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + use lib 't/lib'; + } +} + +use strict; + +use Test::More tests => 1; + +use Dev::Null; + +use Test::Harness; + +sub _all_ok { + my ($tot) = shift; + return $tot->{bad} == 0 + && ( $tot->{max} || $tot->{skipped} ) ? 1 : 0; +} + +{ + local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; + local $Test::Harness::Verbose = -9; + + push @INC, 'examples'; + + tie *NULL, 'Dev::Null' or die $!; + select NULL; + my ( $tot, $failed ) = Test::Harness::execute_tests( + tests => [ + $ENV{PERL_CORE} + ? 'lib/sample-tests/inc_taint' + : 't/sample-tests/inc_taint' + ] + ); + select STDOUT; + + ok( _all_ok($tot), 'tests with taint on preserve @INC' ); +} diff --git a/lib/Test/Harness/t/compat/nonumbers.t b/lib/Test/Harness/t/compat/nonumbers.t new file mode 100644 index 0000000000..144a7599b2 --- /dev/null +++ b/lib/Test/Harness/t/compat/nonumbers.t @@ -0,0 +1,14 @@ +if ( $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE} ) { + print "1..0 # Skip: t/TEST needs numbers\n"; + exit; +} + +print <<END; +1..6 +ok +ok +ok +ok +ok +ok +END diff --git a/lib/Test/Harness/t/compat/regression.t b/lib/Test/Harness/t/compat/regression.t new file mode 100644 index 0000000000..d8105c9f7f --- /dev/null +++ b/lib/Test/Harness/t/compat/regression.t @@ -0,0 +1,16 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More tests => 1; +use Test::Harness; + +{ + #28567 + unshift @INC, 'wibble'; + my @before = Test::Harness::_filtered_inc(); + unshift @INC, sub {die}; + my @after = Test::Harness::_filtered_inc(); + is_deeply \@after, \@before, 'subref removed from @INC'; +} diff --git a/lib/Test/Harness/t/compat/test-harness-compat.t b/lib/Test/Harness/t/compat/test-harness-compat.t new file mode 100644 index 0000000000..5709d7a185 --- /dev/null +++ b/lib/Test/Harness/t/compat/test-harness-compat.t @@ -0,0 +1,853 @@ +#!/usr/bin/perl -w + +BEGIN { + if ($ENV{PERL_CORE}) { + # FIXME + print "1..0 # Skip until we figure out why it exists with no output just after the plan\n"; + exit 0; + } +} + +use strict; +use lib 't/lib'; + +use Test::More; + +use File::Spec; + +use Test::Harness qw(execute_tests); + +# unset this global when self-testing ('testcover' and etc issue) +local $ENV{HARNESS_PERL_SWITCHES}; + +{ + + # if the harness wants to save the resulting TAP we shouldn't + # do it for our internal calls + local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; + + my $TEST_DIR = 't/sample-tests'; + my $PER_LOOP = 4; + + my $results = { + 'descriptive' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 5, + 'ok' => 5, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + join( + ',', qw( + descriptive die die_head_end die_last_minute duplicates + head_end head_fail inc_taint junk_before_plan lone_not_bug + no_nums no_output schwern sequence_misparse shbang_misparse + simple simple_fail skip skip_nomsg skipall skipall_nomsg + stdout_stderr switches taint todo_inline + todo_misparse too_many vms_nit + ) + ) => { + 'failed' => { + 't/sample-tests/die' => { + 'canon' => '??', + 'estat' => 1, + 'failed' => '??', + 'max' => '??', + 'name' => 't/sample-tests/die', + 'wstat' => '256' + }, + 't/sample-tests/die_head_end' => { + 'canon' => '??', + 'estat' => 1, + 'failed' => '??', + 'max' => '??', + 'name' => 't/sample-tests/die_head_end', + 'wstat' => '256' + }, + 't/sample-tests/die_last_minute' => { + 'canon' => '??', + 'estat' => 1, + 'failed' => 0, + 'max' => 4, + 'name' => 't/sample-tests/die_last_minute', + 'wstat' => '256' + }, + 't/sample-tests/duplicates' => { + 'canon' => '??', + 'estat' => '', + 'failed' => '??', + 'max' => 10, + 'name' => 't/sample-tests/duplicates', + 'wstat' => '' + }, + 't/sample-tests/head_fail' => { + 'canon' => 2, + 'estat' => '', + 'failed' => 1, + 'max' => 4, + 'name' => 't/sample-tests/head_fail', + 'wstat' => '' + }, + 't/sample-tests/inc_taint' => { + 'canon' => 1, + 'estat' => 1, + 'failed' => 1, + 'max' => 1, + 'name' => 't/sample-tests/inc_taint', + 'wstat' => '256' + }, + 't/sample-tests/no_nums' => { + 'canon' => 3, + 'estat' => '', + 'failed' => 1, + 'max' => 5, + 'name' => 't/sample-tests/no_nums', + 'wstat' => '' + }, + 't/sample-tests/no_output' => { + 'canon' => '??', + 'estat' => '', + 'failed' => '??', + 'max' => '??', + 'name' => 't/sample-tests/no_output', + 'wstat' => '' + }, + 't/sample-tests/simple_fail' => { + 'canon' => '2 5', + 'estat' => '', + 'failed' => 2, + 'max' => 5, + 'name' => 't/sample-tests/simple_fail', + 'wstat' => '' + }, + 't/sample-tests/switches' => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 1, + 'name' => 't/sample-tests/switches', + 'wstat' => '' + }, + 't/sample-tests/todo_misparse' => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 1, + 'name' => 't/sample-tests/todo_misparse', + 'wstat' => '' + }, + 't/sample-tests/too_many' => { + 'canon' => '4-7', + 'estat' => 4, + 'failed' => 4, + 'max' => 3, + 'name' => 't/sample-tests/too_many', + 'wstat' => '1024' + }, + 't/sample-tests/vms_nit' => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 2, + 'name' => 't/sample-tests/vms_nit', + 'wstat' => '' + } + }, + 'todo' => { + 't/sample-tests/todo_inline' => { + 'canon' => 2, + 'estat' => '', + 'failed' => 1, + 'max' => 2, + 'name' => 't/sample-tests/todo_inline', + 'wstat' => '' + } + }, + 'totals' => { + 'bad' => 13, + 'bonus' => 1, + 'files' => 28, + 'good' => 15, + 'max' => 77, + 'ok' => 78, + 'skipped' => 2, + 'sub_skipped' => 2, + 'tests' => 28, + 'todo' => 2 + } + }, + 'die' => { + 'failed' => { + 't/sample-tests/die' => { + 'canon' => '??', + 'estat' => 1, + 'failed' => '??', + 'max' => '??', + 'name' => 't/sample-tests/die', + 'wstat' => '256' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 0, + 'ok' => 0, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'die_head_end' => { + 'failed' => { + 't/sample-tests/die_head_end' => { + 'canon' => '??', + 'estat' => 1, + 'failed' => '??', + 'max' => '??', + 'name' => 't/sample-tests/die_head_end', + 'wstat' => '256' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 0, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'die_last_minute' => { + 'failed' => { + 't/sample-tests/die_last_minute' => { + 'canon' => '??', + 'estat' => 1, + 'failed' => 0, + 'max' => 4, + 'name' => 't/sample-tests/die_last_minute', + 'wstat' => '256' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 4, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'duplicates' => { + 'failed' => { + 't/sample-tests/duplicates' => { + 'canon' => '??', + 'estat' => '', + 'failed' => '??', + 'max' => 10, + 'name' => 't/sample-tests/duplicates', + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 10, + 'ok' => 11, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'head_end' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 4, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'head_fail' => { + 'failed' => { + 't/sample-tests/head_fail' => { + 'canon' => 2, + 'estat' => '', + 'failed' => 1, + 'max' => 4, + 'name' => 't/sample-tests/head_fail', + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 4, + 'ok' => 3, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'inc_taint' => { + 'failed' => { + 't/sample-tests/inc_taint' => { + 'canon' => 1, + 'estat' => 1, + 'failed' => 1, + 'max' => 1, + 'name' => 't/sample-tests/inc_taint', + 'wstat' => '256' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 1, + 'ok' => 0, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'junk_before_plan' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 1, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'lone_not_bug' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 4, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'no_nums' => { + 'failed' => { + 't/sample-tests/no_nums' => { + 'canon' => 3, + 'estat' => '', + 'failed' => 1, + 'max' => 5, + 'name' => 't/sample-tests/no_nums', + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 5, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'no_output' => { + 'failed' => { + 't/sample-tests/no_output' => { + 'canon' => '??', + 'estat' => '', + 'failed' => '??', + 'max' => '??', + 'name' => 't/sample-tests/no_output', + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 0, + 'ok' => 0, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'schwern' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 1, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'sequence_misparse' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 5, + 'ok' => 5, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'shbang_misparse' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 2, + 'ok' => 2, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'simple' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 5, + 'ok' => 5, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'simple_fail' => { + 'failed' => { + 't/sample-tests/simple_fail' => { + 'canon' => '2 5', + 'estat' => '', + 'failed' => 2, + 'max' => 5, + 'name' => 't/sample-tests/simple_fail', + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 5, + 'ok' => 3, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'skip' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 5, + 'ok' => 5, + 'skipped' => 0, + 'sub_skipped' => 1, + 'tests' => 1, + 'todo' => 0 + } + }, + 'skip_nomsg' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 1, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 1, + 'tests' => 1, + 'todo' => 0 + } + }, + 'skipall' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 0, + 'ok' => 0, + 'skipped' => 1, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'skipall_nomsg' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 0, + 'ok' => 0, + 'skipped' => 1, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'stdout_stderr' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 4, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'switches' => { + 'failed' => { + 't/sample-tests/switches' => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 1, + 'name' => 't/sample-tests/switches', + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 1, + 'ok' => 0, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'taint' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 1, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'taint_warn' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 1, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + }, + 'require' => 5.008001, + }, + 'todo_inline' => { + 'failed' => {}, + 'todo' => { + 't/sample-tests/todo_inline' => { + 'canon' => 2, + 'estat' => '', + 'failed' => 1, + 'max' => 2, + 'name' => 't/sample-tests/todo_inline', + 'wstat' => '' + } + }, + 'totals' => { + 'bad' => 0, + 'bonus' => 1, + 'files' => 1, + 'good' => 1, + 'max' => 3, + 'ok' => 3, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 2 + } + }, + 'todo_misparse' => { + 'failed' => { + 't/sample-tests/todo_misparse' => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 1, + 'name' => 't/sample-tests/todo_misparse', + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 1, + 'ok' => 0, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'too_many' => { + 'failed' => { + 't/sample-tests/too_many' => { + 'canon' => '4-7', + 'estat' => 4, + 'failed' => 4, + 'max' => 3, + 'name' => 't/sample-tests/too_many', + 'wstat' => '1024' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 3, + 'ok' => 7, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'vms_nit' => { + 'failed' => { + 't/sample-tests/vms_nit' => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 2, + 'name' => 't/sample-tests/vms_nit', + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 2, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + } + }; + + my $num_tests = ( keys %$results ) * $PER_LOOP; + + plan tests => $num_tests; + + sub local_name { + my $name = shift; + return File::Spec->catfile( split /\//, $name ); + } + + sub local_result { + my $hash = shift; + my $new = {}; + + while ( my ( $file, $want ) = each %$hash ) { + if ( exists $want->{name} ) { + $want->{name} = local_name( $want->{name} ); + } + $new->{ local_name($file) } = $want; + } + return $new; + } + + sub vague_status { + my $hash = shift; + return $hash unless $^O eq 'VMS'; + + while ( my ( $file, $want ) = each %$hash ) { + for ( qw( estat wstat ) ) { + if ( exists $want->{$_} ) { + $want->{$_} = $want->{$_} ? 1 : 0; + } + } + } + return $hash + } + + { + local $^W = 0; + + # Silence harness output + *TAP::Formatter::Console::_output = sub { + + # do nothing + }; + } + + for my $test_key ( sort keys %$results ) { + my $result = $results->{$test_key}; + SKIP: { + if ( $result->{require} && $] < $result->{require} ) { + skip "Test requires Perl $result->{require}, we have $]", 4; + } + my @test_names = split( /,/, $test_key ); + my @test_files + = map { File::Spec->catfile( $TEST_DIR, $_ ) } @test_names; + + # For now we supress STDERR because it crufts up /our/ test + # results. Should probably capture and analyse it. + local ( *OLDERR, *OLDOUT ); + open OLDERR, '>&STDERR' or die $!; + open OLDOUT, '>&STDOUT' or die $!; + my $devnull = File::Spec->devnull; + open STDERR, ">$devnull" or die $!; + open STDOUT, ">$devnull" or die $!; + + my ( $tot, $fail, $todo, $harness, $aggregate ) + = execute_tests( tests => \@test_files ); + + open STDERR, '>&OLDERR' or die $!; + open STDOUT, '>&OLDOUT' or die $!; + + my $bench = delete $tot->{bench}; + isa_ok $bench, 'Benchmark'; + + # Localise filenames in failed, todo + my $lfailed = vague_status( local_result( $result->{failed} ) ); + my $ltodo = vague_status( local_result( $result->{todo} ) ); + + # use Data::Dumper; + # diag Dumper( [ $lfailed, $ltodo ] ); + + is_deeply $tot, $result->{totals}, "totals match for $test_key"; + is_deeply vague_status($fail), $lfailed, + "failure summary matches for $test_key"; + is_deeply vague_status($todo), $ltodo, + "todo summary matches for $test_key"; + } + } +} diff --git a/lib/Test/Harness/t/compat/version.t b/lib/Test/Harness/t/compat/version.t new file mode 100644 index 0000000000..08344cbd9c --- /dev/null +++ b/lib/Test/Harness/t/compat/version.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl -Tw + +use strict; +use lib 't/lib'; + +use Test::More tests => 2; +use Test::Harness; + +my $ver = $ENV{HARNESS_VERSION} or die "HARNESS_VERSION not set"; +ok( $ver =~ /^[23].\d\d(_\d\d)?$/, "Version is proper format" ); +is( $ver, $Test::Harness::VERSION ); diff --git a/lib/Test/Harness/t/console.t b/lib/Test/Harness/t/console.t new file mode 100644 index 0000000000..32f5db62ac --- /dev/null +++ b/lib/Test/Harness/t/console.t @@ -0,0 +1,47 @@ +use strict; +use lib 't/lib'; +use Test::More; +use TAP::Formatter::Console; + +my @schedule; + +BEGIN { + @schedule = ( + { method => '_range', + in => sub {qw/2 7 1 3 10 9/}, + out => sub {qw/1-3 7 9-10/}, + name => '... and it should return numbers as ranges' + }, + { method => '_balanced_range', + in => sub { 7, qw/2 7 1 3 10 9/ }, + out => sub { '1-3, 7', '9-10' }, + name => '... and it should return numbers as ranges' + }, + ); + + plan tests => @schedule * 3; +} + +for my $test (@schedule) { + my $name = $test->{name}; + my $cons = TAP::Formatter::Console->new; + isa_ok $cons, 'TAP::Formatter::Console'; + my $method = $test->{method}; + can_ok $cons, $method; + is_deeply [ $cons->$method( $test->{in}->() ) ], [ $test->{out}->() ], + $name; +} + +#### Color tests #### + +package Colorizer; + +sub new { bless {}, shift } +sub can_color {1} + +sub set_color { + my ( $self, $output, $color ) = @_; + $output->("[[$color]]"); +} + +package main; diff --git a/lib/Test/Harness/t/errors.t b/lib/Test/Harness/t/errors.t new file mode 100644 index 0000000000..3a54cbe066 --- /dev/null +++ b/lib/Test/Harness/t/errors.t @@ -0,0 +1,183 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 23; + +use TAP::Parser; + +my $plan_line = 'TAP::Parser::Result::Plan'; +my $test_line = 'TAP::Parser::Result::Test'; + +sub _parser { + my $parser = TAP::Parser->new( { tap => shift } ); + $parser->run; + return $parser; +} + +# validate that plan! + +my $parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 - read the rest of the file +1..3 +# comments are allowed after an ending plan +END_TAP + +can_ok $parser, 'parse_errors'; +ok !$parser->parse_errors, + '... comments should be allowed after a terminating plan'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 - read the rest of the file +1..3 +# yeah, yeah, I know. +ok +END_TAP + +can_ok $parser, 'parse_errors'; +is scalar $parser->parse_errors, 2, '... and we should have two parse errors'; + +is [ $parser->parse_errors ]->[0], + 'Plan (1..3) must be at the beginning or end of the TAP output', + '... telling us that our plan was misplaced'; +is [ $parser->parse_errors ]->[1], + 'Bad plan. You planned 3 tests but ran 4.', + '... and telling us we ran the wrong number of tests.'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 - read the rest of the file +#1..3 +# yo quiero tests! +1..3 +END_TAP +ok !$parser->parse_errors, '... but test plan-like data can be in a comment'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 - read the rest of the file 1..5 +# yo quiero tests! +1..3 +END_TAP +ok !$parser->parse_errors, '... or a description'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo 1..4 +ok 3 - read the rest of the file +# yo quiero tests! +1..3 +END_TAP +ok !$parser->parse_errors, '... or a directive'; + +# test numbers included? + +$parser = _parser(<<'END_TAP'); +1..3 +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok read the rest of the file +# this is ... +END_TAP +eval { $parser->run }; +ok !$@, 'We can mix and match the presence of test numbers'; + +$parser = _parser(<<'END_TAP'); +1..3 +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 2 read the rest of the file +END_TAP + +is + ( $parser->parse_errors )[0], + 'Tests out of sequence. Found (2) but expected (3)', + '... and if the numbers are there, they cannot be out of sequence'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 2 read the rest of the file +END_TAP + +is $parser->parse_errors, 2, + 'Having two errors in the TAP should result in two errors (duh)'; +my $expected = [ + 'Tests out of sequence. Found (2) but expected (3)', + 'No plan found in TAP output' +]; +is_deeply [ $parser->parse_errors ], $expected, + '... and they should be the correct errors'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 read the rest of the file +END_TAP + +is $parser->parse_errors, 1, 'Having no plan should cause an error'; +is + ( $parser->parse_errors )[0], 'No plan found in TAP output', + '... with a correct error message'; + +$parser = _parser(<<'END_TAP'); +1..3 +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 read the rest of the file +1..3 +END_TAP + +is $parser->parse_errors, 1, + 'Having more than one plan should cause an error'; +is + ( $parser->parse_errors )[0], 'More than one plan found in TAP output', + '... with a correct error message'; + +can_ok $parser, 'is_good_plan'; +$parser = _parser(<<'END_TAP'); +1..2 +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 read the rest of the file +END_TAP + +is $parser->parse_errors, 1, + 'Having the wrong number of planned tests is a parse error'; +is + ( $parser->parse_errors )[0], + 'Bad plan. You planned 2 tests but ran 3.', + '... with a correct error message'; + +# XXX internals: plan will not set to true if defined +$parser->is_good_plan(undef); +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +1..1 +END_TAP + +ok $parser->is_good_plan, + '... and it should return true if the plan is correct'; + +# TAP::Parser coverage tests +{ + + # good_plan coverage + + my @warn; + + eval { + local $SIG{__WARN__} = sub { push @warn, @_ }; + + $parser->good_plan; + }; + + is @warn, 1, 'coverage testing of good_plan'; + + like pop @warn, + qr/good_plan[(][)] is deprecated. Please use "is_good_plan[(][)]"/, + '...and it fell-back like we expected'; +} diff --git a/lib/Test/Harness/t/grammar.t b/lib/Test/Harness/t/grammar.t new file mode 100644 index 0000000000..107cd77aca --- /dev/null +++ b/lib/Test/Harness/t/grammar.t @@ -0,0 +1,399 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More tests => 81; + +use TAP::Parser::Grammar; +use TAP::Parser::Iterator::Array; + +my $GRAMMAR = 'TAP::Parser::Grammar'; + +# Array based stream that we can push items in to +package SS; + +sub new { + my $class = shift; + return bless [], $class; +} + +sub next { + my $self = shift; + return shift @$self; +} + +sub put { + my $self = shift; + unshift @$self, @_; +} + +sub handle_unicode { } + +package main; + +my $stream = SS->new; +can_ok $GRAMMAR, 'new'; +my $grammar = $GRAMMAR->new($stream); +isa_ok $grammar, $GRAMMAR, '... and the object it returns'; + +# Note: all methods are actually class methods. See the docs for the reason +# why. We'll still use the instance because that should be forward +# compatible. + +my @V12 = qw(bailout comment plan simple_test test version); +my @V13 = ( @V12, 'yaml' ); + +can_ok $grammar, 'token_types'; +ok my @types = sort( $grammar->token_types ), + '... and calling it should succeed (v12)'; +is_deeply \@types, \@V12, '... and return the correct token types (v12)'; + +$grammar->set_version(13); +ok @types = sort( $grammar->token_types ), + '... and calling it should succeed (v13)'; +is_deeply \@types, \@V13, '... and return the correct token types (v13)'; + +can_ok $grammar, 'syntax_for'; +can_ok $grammar, 'handler_for'; + +my ( %syntax_for, %handler_for ); +foreach my $type (@types) { + ok $syntax_for{$type} = $grammar->syntax_for($type), + '... and calling syntax_for() with a type name should succeed'; + cmp_ok ref $syntax_for{$type}, 'eq', 'Regexp', + '... and it should return a regex'; + + ok $handler_for{$type} = $grammar->handler_for($type), + '... and calling handler_for() with a type name should succeed'; + cmp_ok ref $handler_for{$type}, 'eq', 'CODE', + '... and it should return a code reference'; +} + +# Test the plan. Gotta have a plan. +my $plan = '1..1'; +like $plan, $syntax_for{'plan'}, 'A basic plan should match its syntax'; + +my $method = $handler_for{'plan'}; +$plan =~ $syntax_for{'plan'}; +ok my $plan_token = $grammar->$method($plan), + '... and the handler should return a token'; + +my $expected = { + 'explanation' => '', + 'directive' => '', + 'type' => 'plan', + 'tests_planned' => 1, + 'raw' => '1..1', + 'todo_list' => [], +}; +is_deeply $plan_token, $expected, + '... and it should contain the correct data'; + +can_ok $grammar, 'tokenize'; +$stream->put($plan); +ok my $token = $grammar->tokenize, + '... and calling it with data should return a token'; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# a plan with a skip directive + +$plan = '1..0 # SKIP why not?'; +like $plan, $syntax_for{'plan'}, 'a basic plan should match its syntax'; + +$plan =~ $syntax_for{'plan'}; +ok $plan_token = $grammar->$method($plan), + '... and the handler should return a token'; + +$expected = { + 'explanation' => 'why not?', + 'directive' => 'SKIP', + 'type' => 'plan', + 'tests_planned' => 0, + 'raw' => '1..0 # SKIP why not?', + 'todo_list' => [], +}; +is_deeply $plan_token, $expected, + '... and it should contain the correct data'; + +$stream->put($plan); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# implied skip + +$plan = '1..0'; +like $plan, $syntax_for{'plan'}, + 'A plan with an implied "skip all" should match its syntax'; + +$plan =~ $syntax_for{'plan'}; +ok $plan_token = $grammar->$method($plan), + '... and the handler should return a token'; + +$expected = { + 'explanation' => '', + 'directive' => 'SKIP', + 'type' => 'plan', + 'tests_planned' => 0, + 'raw' => '1..0', + 'todo_list' => [], +}; +is_deeply $plan_token, $expected, + '... and it should contain the correct data'; + +$stream->put($plan); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# bad plan + +$plan = '1..0 # TODO 3,4,5'; # old syntax. No longer supported +unlike $plan, $syntax_for{'plan'}, + 'Bad plans should not match the plan syntax'; + +# Bail out! + +my $bailout = 'Bail out!'; +like $bailout, $syntax_for{'bailout'}, + 'Bail out! should match a bailout syntax'; + +$stream->put($bailout); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; +$expected = { + 'bailout' => '', + 'type' => 'bailout', + 'raw' => 'Bail out!' +}; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +$bailout = 'Bail out! some explanation'; +like $bailout, $syntax_for{'bailout'}, + 'Bail out! should match a bailout syntax'; + +$stream->put($bailout); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; +$expected = { + 'bailout' => 'some explanation', + 'type' => 'bailout', + 'raw' => 'Bail out! some explanation' +}; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# test comment + +my $comment = '# this is a comment'; +like $comment, $syntax_for{'comment'}, + 'Comments should match the comment syntax'; + +$stream->put($comment); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; +$expected = { + 'comment' => 'this is a comment', + 'type' => 'comment', + 'raw' => '# this is a comment' +}; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# test tests :/ + +my $test = 'ok 1 this is a test'; +like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; + +$stream->put($test); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; + +$expected = { + 'ok' => 'ok', + 'explanation' => '', + 'type' => 'test', + 'directive' => '', + 'description' => 'this is a test', + 'test_num' => '1', + 'raw' => 'ok 1 this is a test' +}; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# TODO tests + +$test = 'not ok 2 this is a test # TODO whee!'; +like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; + +$stream->put($test); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; + +$expected = { + 'ok' => 'not ok', + 'explanation' => 'whee!', + 'type' => 'test', + 'directive' => 'TODO', + 'description' => 'this is a test', + 'test_num' => '2', + 'raw' => 'not ok 2 this is a test # TODO whee!' +}; +is_deeply $token, $expected, '... and the TODO should be parsed'; + +# false TODO tests + +# escaping that hash mark ('#') means this should *not* be a TODO test +$test = 'ok 22 this is a test \# TODO whee!'; +like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; + +$stream->put($test); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; + +$expected = { + 'ok' => 'ok', + 'explanation' => '', + 'type' => 'test', + 'directive' => '', + 'description' => 'this is a test \# TODO whee!', + 'test_num' => '22', + 'raw' => 'ok 22 this is a test \# TODO whee!' +}; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# coverage tests + +# set_version + +{ + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $grammar->set_version('no_such_version'); + }; + + unless (is @die, 1, 'set_version with bad version') { + diag " >>> $_ <<<\n" for @die; + } + + like pop @die, qr/^Unsupported syntax version: no_such_version at /, + '... and got expected message'; +} + +# tokenize +{ + my $stream = SS->new; + + my $grammar = $GRAMMAR->new($stream); + + my $plan = ''; + + $stream->put($plan); + + my $result = $grammar->tokenize(); + + isa_ok $result, 'TAP::Parser::Result::Unknown'; +} + +# _make_plan_token + +{ + my $grammar = $GRAMMAR->new; + + my $plan + = '1..1 # SKIP with explanation'; # trigger warning in _make_plan_token + + my $method = $handler_for{'plan'}; + + $plan =~ $syntax_for{'plan'}; # perform regex to populate $1, $2 + + my @warn; + + eval { + local $SIG{__WARN__} = sub { push @warn, @_ }; + + $grammar->$method($plan); + }; + + is @warn, 1, 'catch warning on inconsistent plan'; + + like pop @warn, + qr/^Specified SKIP directive in plan but more than 0 tests [(]1\.\.1 # SKIP with explanation[)]/, + '... and its what we expect'; +} + +# _make_yaml_token + +{ + my $stream = SS->new; + + my $grammar = $GRAMMAR->new($stream); + + $grammar->set_version(13); + + # now this is badly formed YAML that is missing the + # leader padding - this is done for coverage testing + # the $reader code sub in _make_yaml_token, that is + # passed as the yaml consumer to T::P::YAMLish::Reader. + + # because it isnt valid yaml, the yaml document is + # not done, and the _peek in the YAMLish::Reader + # code doesnt find the terminating '...' pattern. + # but we dont care as this is coverage testing, so + # if thats what we have to do to exercise that code, + # so be it. + my $yaml = [ ' ... ', '- 2', ' --- ', ]; + + sub iter { + my $ar = shift; + return sub { + return shift @$ar; + }; + } + + my $iter = iter($yaml); + + while ( my $line = $iter->() ) { + $stream->put($line); + } + + # pad == ' ', marker == '--- ' + # length $pad == 3 + # strip == pad + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + $grammar->tokenize; + }; + + is @die, 1, 'checking badly formed yaml for coverage testing'; + + like pop @die, qr/^Missing '[.][.][.]' at end of YAMLish/, + '...and it died like we expect'; +} + +{ + + # coverage testing for TAP::Parser::Iterator::Array + + my $source = [qw( a b c )]; + + my $aiter = TAP::Parser::Iterator::Array->new($source); + + my $first = $aiter->next_raw; + + is $first, 'a', 'access raw iterator'; + + is $aiter->exit, undef, '... and note we didnt exhaust the source'; +} diff --git a/lib/Test/Harness/t/harness.t b/lib/Test/Harness/t/harness.t index 33b8d24795..4da18fc1e9 100644 --- a/lib/Test/Harness/t/harness.t +++ b/lib/Test/Harness/t/harness.t @@ -1,22 +1,820 @@ -#!/usr/bin/perl -Tw +#!/usr/bin/perl -w BEGIN { - if ( $ENV{PERL_CORE} ) { + if( $ENV{PERL_CORE} ) { chdir 't'; @INC = ('../lib', 'lib'); } else { - unshift @INC, 't/lib'; + use lib 't/lib'; + } +} + +BEGIN { + if ($ENV{PERL_CORE}) { + # FIXME + print "1..0 # Skip pending resolution of a clean way to record the change in location of the sample tests\n"; + exit 0; } } use strict; -use Test::More tests => 2; +use Test::More; +use IO::c55Capture; -BEGIN { - use_ok( 'Test::Harness' ); +use TAP::Harness; + +my $HARNESS = 'TAP::Harness'; + +plan tests => 106; + +# note that this test will always pass when run through 'prove' +ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set'; +ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set'; + +#### For color tests #### + +package Colorizer; + +sub new { bless {}, shift } +sub can_color {1} + +sub set_color { + my ( $self, $output, $color ) = @_; + $output->("[[$color]]"); +} + +package main; + +sub colorize { + my $harness = shift; + $harness->formatter->_colorizer( Colorizer->new ); +} + +can_ok $HARNESS, 'new'; + +eval { $HARNESS->new( { no_such_key => 1 } ) }; +like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/, + '... and calling it with bad keys should fail'; + +eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) }; +is $@, '', '... and calling it with a non-existent lib is fine'; + +eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) }; +is $@, '', '... and calling it with non-existent libs is fine'; + +ok my $harness = $HARNESS->new, + 'Calling new() without arguments should succeed'; + +foreach my $test_args ( get_arg_sets() ) { + my %args = %$test_args; + foreach my $key ( sort keys %args ) { + $args{$key} = $args{$key}{in}; + } + ok my $harness = $HARNESS->new( {%args} ), + 'Calling new() with valid arguments should succeed'; + isa_ok $harness, $HARNESS, '... and the object it returns'; + + while ( my ( $property, $test ) = each %$test_args ) { + my $value = $test->{out}; + can_ok $harness, $property; + is_deeply scalar $harness->$property(), $value, $test->{test_name}; + } +} + +{ + my @output; + local $^W; + local *TAP::Formatter::Console::_should_show_count = sub {0}; + local *TAP::Formatter::Console::_output = sub { + my $self = shift; + push @output => grep { $_ ne '' } + map { + local $_ = $_; + chomp; + trim($_) + } @_; + }; + my $harness = TAP::Harness->new( { verbosity => 1 } ); + my $harness_whisper = TAP::Harness->new( { verbosity => -1 } ); + my $harness_mute = TAP::Harness->new( { verbosity => -2 } ); + my $harness_directives = TAP::Harness->new( { directives => 1 } ); + my $harness_failures = TAP::Harness->new( { failures => 1 } ); + + colorize($harness); + + can_ok $harness, 'runtests'; + + # normal tests in verbose mode + + ok my $aggregate = _runtests( $harness, 't/source_tests/harness' ), + '... runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + my @expected = ( + 't/source_tests/harness....', + '1..1', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + 'ok', + 'All tests successful.', + ); + my $status = pop @output; + my $expected_status = qr{^Result: PASS$}; + my $summary = pop @output; + my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # use an alias for test name + + @output = (); + ok $aggregate + = _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ] ), + '... runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + @expected = ( + 'My Nice Test....', + '1..1', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + 'ok', + 'All tests successful.', + ); + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # run same test twice + + @output = (); + ok $aggregate + = _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ], + [ 't/source_tests/harness', 'My Nice Test Again' ] ), + '... runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + @expected = ( + 'My Nice Test..........', + '1..1', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + 'ok', + 'My Nice Test Again....', + '1..1', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + 'ok', + 'All tests successful.', + ); + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests in quiet mode + + @output = (); + _runtests( $harness_whisper, 't/source_tests/harness' ); + + chomp(@output); + @expected = ( + 't/source_tests/harness....', + 'ok', + 'All tests successful.', + ); + + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests in really_quiet mode + + @output = (); + _runtests( $harness_mute, 't/source_tests/harness' ); + + chomp(@output); + @expected = ( + 'All tests successful.', + ); + + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests with failures + + @output = (); + _runtests( $harness, 't/source_tests/harness_failure' ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + + my @summary = @output[ 10 .. $#output ]; + @output = @output[ 0 .. 9 ]; + + @expected = ( + 't/source_tests/harness_failure....', + '1..2', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + '[[red]]', + 'not ok 2 - this is another test', + '[[reset]]', + '[[red]]', + 'Failed 1/2 subtests', + ); + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + my @expected_summary = ( + '[[reset]]', + 'Test Summary Report', + '-------------------', + '[[red]]', + 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)', + '[[reset]]', + '[[red]]', + 'Failed test number(s):', + '[[reset]]', + '[[red]]', + '2', + '[[reset]]', + ); + + is_deeply \@summary, \@expected_summary, + '... and the failure summary should also be correct'; + + # quiet tests with failures + + @output = (); + _runtests( $harness_whisper, 't/source_tests/harness_failure' ); + + $status = pop @output; + $summary = pop @output; + @expected = ( + 't/source_tests/harness_failure....', + 'Failed 1/2 subtests', + 'Test Summary Report', + '-------------------', + 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)', + 'Failed test number(s):', + '2', + ); + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + # really quiet tests with failures + + @output = (); + _runtests( $harness_mute, 't/source_tests/harness_failure' ); + + $status = pop @output; + $summary = pop @output; + @expected = ( + 'Test Summary Report', + '-------------------', + 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)', + 'Failed test number(s):', + '2', + ); + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + # only show directives + + @output = (); + _runtests( + $harness_directives, + 't/source_tests/harness_directives' + ); + + chomp(@output); + + @expected = ( + 't/source_tests/harness_directives....', + 'not ok 2 - we have a something # TODO some output', + "ok 3 houston, we don't have liftoff # SKIP no funding", + 'ok', + 'All tests successful.', + + # ~TODO {{{ this should be an option + #'Test Summary Report', + #'-------------------', + #'t/source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)', + #'Tests skipped:', + #'3', + # }}} + ); + + $status = pop @output; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + + # normal tests with bad tap + + # install callback handler + my $parser; + my $callback_count = 0; + + my @callback_log = (); + + for my $evt (qw(parser_args made_parser before_runtests after_runtests)) { + $harness->callback( + $evt => sub { + push @callback_log, $evt; + } + ); + } + + $harness->callback( + made_parser => sub { + $parser = shift; + $callback_count++; + } + ); + + @output = (); + _runtests( $harness, 't/source_tests/harness_badtap' ); + chomp(@output); + + @output = map { trim($_) } @output; + $status = pop @output; + @summary = @output[ 12 .. ( $#output - 1 ) ]; + @output = @output[ 0 .. 11 ]; + @expected = ( + 't/source_tests/harness_badtap....', + '1..2', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + '[[red]]', + 'not ok 2 - this is another test', + '[[reset]]', + '1..2', + '[[reset]]', + '[[red]]', + 'Failed 1/2 subtests', + ); + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + @expected_summary = ( + '[[reset]]', + 'Test Summary Report', + '-------------------', + '[[red]]', + 't/source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)', + '[[reset]]', + '[[red]]', + 'Failed test number(s):', + '[[reset]]', + '[[red]]', + '2', + '[[reset]]', + '[[red]]', + 'Parse errors: More than one plan found in TAP output', + '[[reset]]', + ); + is_deeply \@summary, \@expected_summary, + '... and the badtap summary should also be correct'; + + cmp_ok( $callback_count, '==', 1, 'callback called once' ); + is_deeply( + \@callback_log, + [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ], + 'callback log matches' + ); + isa_ok $parser, 'TAP::Parser'; + + # coverage testing for _should_show_failures + # only show failures + + @output = (); + _runtests( $harness_failures, 't/source_tests/harness_failure' ); + + chomp(@output); + + @expected = ( + 't/source_tests/harness_failure....', + 'not ok 2 - this is another test', + 'Failed 1/2 subtests', + 'Test Summary Report', + '-------------------', + 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)', + 'Failed test number(s):', + '2', + ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; + is_deeply \@output, \@expected, '... and the output should be correct'; + + # check the status output for no tests + + @output = (); + _runtests( $harness_failures, 't/sample-tests/no_output' ); + + chomp(@output); + + @expected = ( + 't/sample-tests/no_output....', + 'No subtests run', + 'Test Summary Report', + '-------------------', + 't/sample-tests/no_output (Wstat: 0 Tests: 0 Failed: 0)', + 'Parse errors: No plan found in TAP output', + ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; + is_deeply \@output, \@expected, '... and the output should be correct'; + + #XXXX +} + +# make sure we can exec something ... anything! +SKIP: { + + my $cat = '/bin/cat'; + unless ( -e $cat ) { + skip "no '$cat'", 2; + } + + my $capture = IO::c55Capture->new_handle; + my $harness = TAP::Harness->new( + { verbosity => -2, + stdout => $capture, + exec => [$cat], + } + ); + + eval { _runtests( $harness, 't/data/catme.1' ) }; + + my @output = tied($$capture)->dump; + my $status = pop @output; + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + pop @output; # get rid of summary line + my $answer = pop @output; + is( $answer, "All tests successful.\n", 'cat meows' ); +} + +# catches "exec accumulates arguments" issue (r77) +{ + my $capture = IO::c55Capture->new_handle; + my $harness = TAP::Harness->new( + { verbosity => -2, + stdout => $capture, + exec => [$^X] + } + ); + + _runtests( + $harness, + 't/source_tests/harness_complain' + , # will get mad if run with args + 't/source_tests/harness', + ); + + my @output = tied($$capture)->dump; + my $status = pop @output; + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + pop @output; # get rid of summary line + is( $output[-1], "All tests successful.\n", + 'No exec accumulation' + ); +} + +sub trim { + $_[0] =~ s/^\s+|\s+$//g; + return $_[0]; +} + +sub liblist { + return [ map {"-I$_"} @_ ]; } -my $strap = Test::Harness->strap; -isa_ok( $strap, 'Test::Harness::Straps' ); +sub get_arg_sets { + + # keys are keys to new() + return { + lib => { + in => 'lib', + out => liblist('lib'), + test_name => '... a single lib switch should be correct' + }, + verbosity => { + in => 1, + out => 1, + test_name => '... and we should be able to set verbosity to 1' + }, + + # verbose => { + # in => 1, + # out => 1, + # test_name => '... and we should be able to set verbose to true' + # }, + }, + { lib => { + in => [ 'lib', 't' ], + out => liblist( 'lib', 't' ), + test_name => '... multiple lib dirs should be correct' + }, + verbosity => { + in => 0, + out => 0, + test_name => '... and we should be able to set verbosity to 0' + }, + + # verbose => { + # in => 0, + # out => 0, + # test_name => '... and we should be able to set verbose to false' + # }, + }, + { switches => { + in => [ '-T', '-w', '-T' ], + out => [ '-T', '-w', '-T' ], + test_name => '... duplicate switches should remain', + }, + failures => { + in => 1, + out => 1, + test_name => + '... and we should be able to set failures to true', + }, + verbosity => { + in => -1, + out => -1, + test_name => '... and we should be able to set verbosity to -1' + }, + + # quiet => { + # in => 1, + # out => 1, + # test_name => '... and we should be able to set quiet to false' + # }, + }, + + { verbosity => { + in => -2, + out => -2, + test_name => '... and we should be able to set verbosity to -2' + }, + + # really_quiet => { + # in => 1, + # out => 1, + # test_name => + # '... and we should be able to set really_quiet to true', + # }, + exec => { + in => $^X, + out => $^X, + test_name => + '... and we should be able to set the executable', + }, + }, + { switches => { + in => 'T', + out => ['T'], + test_name => + '... leading dashes (-) on switches are not optional', + }, + }, + { switches => { + in => '-T', + out => ['-T'], + test_name => '... we should be able to set switches', + }, + failures => { + in => 1, + out => 1, + test_name => '... and we should be able to set failures to true' + }, + }; +} + +sub _runtests { + my ( $harness, @tests ) = @_; + local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; + my $aggregate = $harness->runtests(@tests); + return $aggregate; +} + +{ + + # coverage tests for ctor + + my $harness = TAP::Harness->new( + { timer => 0, + errors => 1, + merge => 2, + + # formatter => 3, + } + ); + + is $harness->timer(), 0, 'timer getter'; + is $harness->timer(10), 10, 'timer setter'; + is $harness->errors(), 1, 'errors getter'; + is $harness->errors(10), 10, 'errors setter'; + is $harness->merge(), 2, 'merge getter'; + is $harness->merge(10), 10, 'merge setter'; + + # jobs accessor + is $harness->jobs(), 1, 'jobs'; +} + +{ + +# coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor + + # the coverage tests are + # 1. ref $ref => false + # 2. ref => ! GLOB and ref->can(print) + # 3. ref $ref => GLOB + + # case 1 + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + my $harness = TAP::Harness->new( + { stdout => bless {}, '0', # how evil is THAT !!! + } + ); + }; + + is @die, 1, 'bad filehandle to stdout'; + like pop @die, qr/option 'stdout' needs a filehandle/, + '... and we died as expected'; + + # case 2 + + @die = (); + + package Printable; + + sub new { return bless {}, shift } + + sub print {return} + + package main; + + my $harness = TAP::Harness->new( + { stdout => Printable->new(), + } + ); + + isa_ok $harness, 'TAP::Harness'; + + # case 3 + + @die = (); + + $harness = TAP::Harness->new( + { stdout => bless {}, 'GLOB', # again with the evil + } + ); + + isa_ok $harness, 'TAP::Harness'; +} + +{ + + # coverage testing of lib/switches accessor + my $harness = TAP::Harness->new; + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $harness->switches(qw( too many arguments)); + }; + + is @die, 1, 'too many arguments to accessor'; + + like pop @die, qr/Too many arguments to method 'switches'/, + '...and we died as expected'; + + $harness->switches('simple scalar'); + + my $arrref = $harness->switches; + is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref'; +} + +{ + + # coverage tests for the basically untested T::H::_open_spool + + $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(qw(t spool)); + +# now given that we're going to be writing stuff to the file system, make sure we have +# a cleanup hook + + END { + use File::Path; + + # remove the tree if we made it this far + rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) + if $ENV{PERL_TEST_HARNESS_DUMP_TAP}; + } + + my $harness = TAP::Harness->new( { verbosity => -2 } ); + + can_ok $harness, 'runtests'; + + # normal tests in verbose mode + + my $parser = $harness->runtests( + File::Spec->catfile(qw (t source_tests harness )) ); + + isa_ok $parser, 'TAP::Parser::Aggregator', + '... runtests returns the aggregate'; + + ok -e File::Spec->catfile( + $ENV{PERL_TEST_HARNESS_DUMP_TAP}, + qw( t source_tests harness ) + ); +} diff --git a/lib/Test/Harness/t/iterators.t b/lib/Test/Harness/t/iterators.t new file mode 100644 index 0000000000..44d2004baf --- /dev/null +++ b/lib/Test/Harness/t/iterators.t @@ -0,0 +1,208 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More tests => 76; + +use File::Spec; +use TAP::Parser; +use TAP::Parser::Iterator; +use Config; + +sub array_ref_from { + my $string = shift; + my @lines = split /\n/ => $string; + return \@lines; +} + +# we slurp __DATA__ and then reset it so we don't have to duplicate our TAP +my $offset = tell DATA; +my $tap = do { local $/; <DATA> }; +seek DATA, $offset, 0; + +my $did_setup = 0; +my $did_teardown = 0; + +my $setup = sub { $did_setup++ }; +my $teardown = sub { $did_teardown++ }; + +package NoForkProcess; +use vars qw( @ISA ); +@ISA = qw( TAP::Parser::Iterator::Process ); + +sub _use_open3 {return} + +package main; + +my @schedule = ( + { name => 'Process', + subclass => 'TAP::Parser::Iterator::Process', + source => { + command => [ + $^X, + File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'), + 'sample-tests', 'out_err_mix' ) + ], + merge => 1, + setup => $setup, + teardown => $teardown, + }, + after => sub { + is $did_setup, 1, "setup called"; + is $did_teardown, 1, "teardown called"; + }, + need_open3 => 15, + }, + { name => 'Array', + subclass => 'TAP::Parser::Iterator::Array', + source => array_ref_from($tap), + }, + { name => 'Stream', + subclass => 'TAP::Parser::Iterator::Stream', + source => \*DATA, + }, + { name => 'Process (Perl -e)', + subclass => 'TAP::Parser::Iterator::Process', + source => + { command => [ $^X, '-e', 'print qq/one\ntwo\n\nthree\n/' ] }, + }, + { name => 'Process (NoFork)', + subclass => 'TAP::Parser::Iterator::Process', + class => 'NoForkProcess', + source => + { command => [ $^X, '-e', 'print qq/one\ntwo\n\nthree\n/' ] }, + }, +); + +sub _can_open3 { + return $^O eq 'MSWin32' || $Config{d_fork}; +} + +for my $test (@schedule) { + SKIP: { + my $name = $test->{name}; + my $need_open3 = $test->{need_open3}; + skip "No open3", $need_open3 if $need_open3 && !_can_open3(); + my $subclass = $test->{subclass}; + my $source = $test->{source}; + my $class = $test->{class} || 'TAP::Parser::Iterator'; + ok my $iter = $class->new($source), + "$name: We should be able to create a new iterator"; + isa_ok $iter, 'TAP::Parser::Iterator', + '... and the object it returns'; + isa_ok $iter, $subclass, '... and the object it returns'; + + can_ok $iter, 'exit'; + ok !defined $iter->exit, + "$name: ... and it should be undef before we are done ($subclass)"; + + can_ok $iter, 'next'; + is $iter->next, 'one', "$name: next() should return the first result"; + + is $iter->next, 'two', + "$name: next() should return the second result"; + + is $iter->next, '', "$name: next() should return the third result"; + + is $iter->next, 'three', + "$name: next() should return the fourth result"; + + ok !defined $iter->next, + "$name: next() should return undef after it is empty"; + + is $iter->exit, 0, + "$name: ... and exit should now return 0 ($subclass)"; + + is $iter->wait, 0, "$name: wait should also now return 0 ($subclass)"; + + if ( my $after = $test->{after} ) { + $after->(); + } + } +} + +{ + + # coverage tests for the ctor + + my $stream = TAP::Parser::Iterator->new( IO::Handle->new ); + + isa_ok $stream, 'TAP::Parser::Iterator::Stream'; + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + TAP::Parser::Iterator->new( \1 ); # a ref to a scalar + }; + + is @die, 1, 'coverage of error case'; + + like pop @die, qr/Can't iterate with a SCALAR/, + '...and we died as expected'; +} + +{ + + # coverage test for VMS case + + my $stream = TAP::Parser::Iterator->new( + [ 'not ', + 'ok 1 - I hate VMS', + ] + ); + + is $stream->next, 'not ok 1 - I hate VMS', + 'coverage of VMS line-splitting case'; + + # coverage test for VMS case - nothing after 'not' + + $stream = TAP::Parser::Iterator->new( + [ 'not ', + ] + ); + + is $stream->next, 'not ', '...and we find "not" by itself'; +} + +SKIP: { + skip "No open3", 4 unless _can_open3(); + + # coverage testing for TAP::Parser::Iterator::Process ctor + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + TAP::Parser::Iterator->new( {} ); + }; + + is @die, 1, 'coverage testing for TPI::Process'; + + like pop @die, qr/Must supply a command to execute/, + '...and we died as expected'; + + my $parser = TAP::Parser::Iterator->new( + { command => [ + $^X, + File::Spec->catfile( 't', 'sample-tests', 'out_err_mix' ) + ], + merge => 1, + } + ); + + is $parser->{err}, '', 'confirm we set err to empty string'; + is $parser->{sel}, undef, '...and selector to undef'; + + # And then we read from the parser to sidestep the Mac OS / open3 + # bug which frequently throws an error here otherwise. + $parser->next; +} +__DATA__ +one +two + +three diff --git a/lib/Test/Harness/t/multiplexer.t b/lib/Test/Harness/t/multiplexer.t new file mode 100644 index 0000000000..e74c15cd07 --- /dev/null +++ b/lib/Test/Harness/t/multiplexer.t @@ -0,0 +1,167 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More qw( no_plan ); + +use File::Spec; +use TAP::Parser; +use TAP::Parser::Multiplexer; +use TAP::Parser::Iterator::Process; + +my $fork_desc + = TAP::Parser::Iterator::Process->_use_open3 + ? 'fork' + : 'nofork'; + +my @schedule = ( + { name => 'Single non-selectable source', + + # Returns a list of parser, stash pairs. The stash contains the + # TAP that we expect from this parser. + sources => sub { + my @tap = ( + '1..1', + 'ok 1 Just fine' + ); + + return [ + TAP::Parser->new( { tap => join( "\n", @tap ) . "\n" } ), + \@tap, + ]; + }, + }, + { name => 'Two non-selectable sources', + sources => sub { + my @tap = ( + [ '1..1', + 'ok 1 Just fine' + ], + [ '1..2', + 'not ok 1 Oh dear', + 'ok 2 Better' + ] + ); + + return map { + [ TAP::Parser->new( { tap => join( "\n", @$_ ) . "\n" } ), + $_ + ] + } @tap; + }, + }, + { name => 'Single selectable source', + sources => sub { + return [ + TAP::Parser->new( + { source => File::Spec->catfile( + ($ENV{PERL_CORE} ? 'lib' : 't'), 'sample-tests', + 'simple' + ), + } + ), + [ '1..5', + 'ok 1', + 'ok 2', + 'ok 3', + 'ok 4', + 'ok 5', + ] + ]; + }, + }, + { name => 'Three selectable sources', + sources => sub { + return map { + [ TAP::Parser->new( + { source => File::Spec->catfile( + ($ENV{PERL_CORE} ? 'lib' : 't'), + 'sample-tests', 'simple' + ), + } + ), + [ '1..5', + 'ok 1', + 'ok 2', + 'ok 3', + 'ok 4', + 'ok 5', + ] + ] + } 1 .. 3; + }, + }, + { name => 'Three selectable sources, two non-selectable sources', + sources => sub { + my @tap = ( + [ '1..1', + 'ok 1 Just fine' + ], + [ '1..2', + 'not ok 1 Oh dear', + 'ok 2 Better' + ] + ); + + return ( + map { + [ TAP::Parser->new( + { tap => join( "\n", @$_ ) . "\n" } + ), + $_ + ] + } @tap + ), + ( map { + [ TAP::Parser->new( + { source => File::Spec->catfile( + ($ENV{PERL_CORE} ? 'lib' : 't'), + 'sample-tests', 'simple' + ), + } + ), + [ '1..5', + 'ok 1', + 'ok 2', + 'ok 3', + 'ok 4', + 'ok 5', + ] + ] + } 1 .. 3 + ); + }, + } +); + +for my $test (@schedule) { + my $name = "$test->{name} ($fork_desc)"; + my @sources = $test->{sources}->(); + my $mux = TAP::Parser::Multiplexer->new; + + my $count = @sources; + $mux->add(@$_) for @sources; + + is $mux->parsers, $count, "$name: count OK"; + + while ( my ( $parser, $stash, $result ) = $mux->next ) { + + # use Data::Dumper; + # diag Dumper( { stash => $stash, result => $result } ); + if ( defined $result ) { + my $expect = ( shift @$stash ) || ' OOPS '; + my $got = $result->raw; + is $got, $expect, "$name: '$expect' OK"; + } + else { + ok @$stash == 0, "$name: EOF OK"; + + # Make sure we only get one EOF per stream + push @$stash, ' expect no more '; + } + } + is $mux->parsers, 0, "$name: All used up"; +} + +1; diff --git a/lib/Test/Harness/t/nofork-mux.t b/lib/Test/Harness/t/nofork-mux.t new file mode 100644 index 0000000000..1ab27b1916 --- /dev/null +++ b/lib/Test/Harness/t/nofork-mux.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl -w + + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + use lib 't/lib'; + } +} + +use strict; + +use NoFork; +require ($ENV{PERL_CORE} && '../lib/Test/Harness/') . 't/multiplexer.t'; diff --git a/lib/Test/Harness/t/nofork.t b/lib/Test/Harness/t/nofork.t new file mode 100755 index 0000000000..0184c67794 --- /dev/null +++ b/lib/Test/Harness/t/nofork.t @@ -0,0 +1,74 @@ +#!/usr/bin/perl -w + +# check nofork logic on systems which *can* fork() +# NOTE maybe a good candidate for xt/author or something. + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + use lib 't/lib'; + } +} + +BEGIN { + if ($ENV{PERL_CORE}) { + # FIXME + print "1..0 # Skip pending resolution of how to set the library with -I\n"; + exit 0; + } +} + +use strict; + +use Config; +use Test::More ( + $Config{d_fork} + ? 'no_plan' + : ( 'skip_all' => 'your system already has no fork' ) +); +use IO::c55Capture; # for util + +use TAP::Harness; + +sub backticks { + my (@args) = @_; + + util::stdout_of( sub { system(@args) and die "error $?" } ); +} + +my @perl = ( $^X, '-Ilib', '-It/lib' ); +my $mod = 'TAP::Parser::Iterator::Process'; + +{ # just check the introspective method to start... + my $code = qq(print $mod->_use_open3 ? 1 : 2); + { + my $ans = backticks( @perl, '-MNoFork', "-M$mod", '-e', $code ); + is( $ans, 2, 'says not to fork' ); + } + { + local $ENV{PERL5OPT}; # punt: prevent propogating -MNoFork + my $ans = backticks( @perl, "-M$mod", '-e', $code ); + is( $ans, 1, 'says to fork' ); + } +} + +{ # and make sure we can run a test + my $capture = IO::c55Capture->new_handle; + local *STDERR; + my $harness = TAP::Harness->new( + { verbosity => -2, + switches => [ '-It/lib', "-MNoFork" ], + stdout => $capture, + } + ); + $harness->runtests(($ENV{PERL_CORE} ? 'lib' : 't') . '/sample-tests/simple'); + my @output = tied($$capture)->dump; + is pop @output, "Result: PASS\n", 'status OK'; + pop @output; # get rid of summary line + is( $output[-1], "All tests successful.\n", 'ran with no fork' ); +} + +# vim:ts=4:sw=4:et:sta diff --git a/lib/Test/Harness/t/parse.t b/lib/Test/Harness/t/parse.t new file mode 100755 index 0000000000..6e5c585273 --- /dev/null +++ b/lib/Test/Harness/t/parse.t @@ -0,0 +1,990 @@ +#!/usr/bin/perl -w + +use strict; + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + use lib 't/lib'; + } +} + +use Test::More tests => 260; +use IO::c55Capture; + +use File::Spec; + +use TAP::Parser; +use TAP::Parser::Iterator; + +sub _get_results { + my $parser = shift; + my @results; + while ( defined( my $result = $parser->next ) ) { + push @results => $result; + } + return @results; +} + +my ( $PARSER, $PLAN, $TEST, $COMMENT, $BAILOUT, $UNKNOWN, $YAML, $VERSION ) = qw( + TAP::Parser + TAP::Parser::Result::Plan + TAP::Parser::Result::Test + TAP::Parser::Result::Comment + TAP::Parser::Result::Bailout + TAP::Parser::Result::Unknown + TAP::Parser::Result::YAML + TAP::Parser::Result::Version +); + +my $tap = <<'END_TAP'; +TAP version 13 +1..7 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure + --- YAML! + ... +ok 5 # skip we have no description +ok 6 - you shall not pass! # TODO should have failed +not ok 7 - Gandalf wins. Game over. # TODO 'bout time! +END_TAP + +can_ok $PARSER, 'new'; +my $parser = $PARSER->new( { tap => $tap } ); +isa_ok $parser, $PARSER, '... and the object it returns'; + +ok $ENV{TAP_VERSION}, 'TAP_VERSION env variable should be set'; + +# results() is sane? + +my @results = _get_results($parser); +is scalar @results, 12, '... and there should be one for each line'; + +my $version = shift @results; +isa_ok $version, $VERSION; +is $version->version, '13', '... and the version should be 13'; + +# check the test plan + +my $result = shift @results; +isa_ok $result, $PLAN; +can_ok $result, 'type'; +is $result->type, 'plan', '... and it should report the correct type'; +ok $result->is_plan, '... and it should identify itself as a plan'; +is $result->plan, '1..7', '... and identify the plan'; +ok !$result->directive, '... and this plan should not have a directive'; +ok !$result->explanation, '... or a directive explanation'; +is $result->as_string, '1..7', + '... and have the correct string representation'; +is $result->raw, '1..7', '... and raw() should return the original line'; + +# a normal, passing test + +my $test = shift @results; +isa_ok $test, $TEST; +is $test->type, 'test', '... and it should report the correct type'; +ok $test->is_test, '... and it should identify itself as a test'; +is $test->ok, 'ok', '... and it should have the correct ok()'; +ok $test->is_ok, '... and the correct boolean version of is_ok()'; +ok $test->is_actual_ok, + '... and the correct boolean version of is_actual_ok()'; +is $test->number, 1, '... and have the correct test number'; +is $test->description, '- input file opened', + '... and the correct description'; +ok !$test->directive, '... and not have a directive'; +ok !$test->explanation, '... or a directive explanation'; +ok !$test->has_skip, '... and it is not a SKIPped test'; +ok !$test->has_todo, '... nor a TODO test'; +is $test->as_string, 'ok 1 - input file opened', + '... and its string representation should be correct'; +is $test->raw, 'ok 1 - input file opened', + '... and raw() should return the original line'; + +# junk lines should be preserved + +my $unknown = shift @results; +isa_ok $unknown, $UNKNOWN; +is $unknown->type, 'unknown', '... and it should report the correct type'; +ok $unknown->is_unknown, '... and it should identify itself as unknown'; +is $unknown->as_string, '... this is junk', + '... and its string representation should be returned verbatim'; +is $unknown->raw, '... this is junk', + '... and raw() should return the original line'; + +# a failing test, which also happens to have a directive + +my $failed = shift @results; +isa_ok $failed, $TEST; +is $failed->type, 'test', '... and it should report the correct type'; +ok $failed->is_test, '... and it should identify itself as a test'; +is $failed->ok, 'not ok', '... and it should have the correct ok()'; +ok $failed->is_ok, '... and TODO tests should always pass'; +ok !$failed->is_actual_ok, + '... and the correct boolean version of is_actual_ok ()'; +is $failed->number, 2, '... and have the correct failed number'; +is $failed->description, 'first line of the input valid', + '... and the correct description'; +is $failed->directive, 'TODO', '... and should have the correct directive'; +is $failed->explanation, 'some data', + '... and the correct directive explanation'; +ok !$failed->has_skip, '... and it is not a SKIPped failed'; +ok $failed->has_todo, '... but it is a TODO succeeded'; +is $failed->as_string, + 'not ok 2 first line of the input valid # TODO some data', + '... and its string representation should be correct'; +is $failed->raw, 'not ok first line of the input valid # todo some data', + '... and raw() should return the original line'; + +# comments + +my $comment = shift @results; +isa_ok $comment, $COMMENT; +is $comment->type, 'comment', '... and it should report the correct type'; +ok $comment->is_comment, '... and it should identify itself as a comment'; +is $comment->comment, 'this is a comment', + '... and you should be able to fetch the comment'; +is $comment->as_string, '# this is a comment', + '... and have the correct string representation'; +is $comment->raw, '# this is a comment', + '... and raw() should return the original line'; + +# another normal, passing test + +$test = shift @results; +isa_ok $test, $TEST; +is $test->type, 'test', '... and it should report the correct type'; +ok $test->is_test, '... and it should identify itself as a test'; +is $test->ok, 'ok', '... and it should have the correct ok()'; +ok $test->is_ok, '... and the correct boolean version of is_ok()'; +ok $test->is_actual_ok, + '... and the correct boolean version of is_actual_ok()'; +is $test->number, 3, '... and have the correct test number'; +is $test->description, '- read the rest of the file', + '... and the correct description'; +ok !$test->directive, '... and not have a directive'; +ok !$test->explanation, '... or a directive explanation'; +ok !$test->has_skip, '... and it is not a SKIPped test'; +ok !$test->has_todo, '... nor a TODO test'; +is $test->as_string, 'ok 3 - read the rest of the file', + '... and its string representation should be correct'; +is $test->raw, 'ok 3 - read the rest of the file', + '... and raw() should return the original line'; + +# a failing test + +$failed = shift @results; +isa_ok $failed, $TEST; +is $failed->type, 'test', '... and it should report the correct type'; +ok $failed->is_test, '... and it should identify itself as a test'; +is $failed->ok, 'not ok', '... and it should have the correct ok()'; +ok !$failed->is_ok, '... and the tests should not have passed'; +ok !$failed->is_actual_ok, + '... and the correct boolean version of is_actual_ok ()'; +is $failed->number, 4, '... and have the correct failed number'; +is $failed->description, '- this is a real failure', + '... and the correct description'; +ok !$failed->directive, '... and should have no directive'; +ok !$failed->explanation, '... and no directive explanation'; +ok !$failed->has_skip, '... and it is not a SKIPped failed'; +ok !$failed->has_todo, '... and not a TODO test'; +is $failed->as_string, 'not ok 4 - this is a real failure', + '... and its string representation should be correct'; +is $failed->raw, 'not ok 4 - this is a real failure', + '... and raw() should return the original line'; + +# Some YAML +my $yaml = shift @results; +isa_ok $yaml, $YAML; +is $yaml->type, 'yaml', '... and it should report the correct type'; +ok $yaml->is_yaml, '... and it should identify itself as yaml'; +is_deeply $yaml->data, 'YAML!', '... and data should be correct'; + +# ok 5 # skip we have no description +# skipped test + +$test = shift @results; +isa_ok $test, $TEST; +is $test->type, 'test', '... and it should report the correct type'; +ok $test->is_test, '... and it should identify itself as a test'; +is $test->ok, 'ok', '... and it should have the correct ok()'; +ok $test->is_ok, '... and the correct boolean version of is_ok()'; +ok $test->is_actual_ok, + '... and the correct boolean version of is_actual_ok()'; +is $test->number, 5, '... and have the correct test number'; +ok !$test->description, '... and skipped tests have no description'; +is $test->directive, 'SKIP', '... and teh correct directive'; +is $test->explanation, 'we have no description', + '... but we should have an explanation'; +ok $test->has_skip, '... and it is a SKIPped test'; +ok !$test->has_todo, '... but not a TODO test'; +is $test->as_string, 'ok 5 # SKIP we have no description', + '... and its string representation should be correct'; +is $test->raw, 'ok 5 # skip we have no description', + '... and raw() should return the original line'; + +# a failing test, which also happens to have a directive +# ok 6 - you shall not pass! # TODO should have failed + +my $bonus = shift @results; +isa_ok $bonus, $TEST; +can_ok $bonus, 'todo_passed'; +is $bonus->type, 'test', 'TODO tests should parse correctly'; +ok $bonus->is_test, '... and it should identify itself as a test'; +is $bonus->ok, 'ok', '... and it should have the correct ok()'; +ok $bonus->is_ok, '... and TODO tests should not always pass'; +ok $bonus->is_actual_ok, + '... and the correct boolean version of is_actual_ok ()'; +is $bonus->number, 6, '... and have the correct failed number'; +is $bonus->description, '- you shall not pass!', + '... and the correct description'; +is $bonus->directive, 'TODO', '... and should have the correct directive'; +is $bonus->explanation, 'should have failed', + '... and the correct directive explanation'; +ok !$bonus->has_skip, '... and it is not a SKIPped failed'; +ok $bonus->has_todo, '... but it is a TODO succeeded'; +is $bonus->as_string, 'ok 6 - you shall not pass! # TODO should have failed', + '... and its string representation should be correct'; +is $bonus->raw, 'ok 6 - you shall not pass! # TODO should have failed', + '... and raw() should return the original line'; +ok $bonus->todo_passed, + '... todo_bonus() should pass for TODO tests which unexpectedly succeed'; + +# not ok 7 - Gandalf wins. Game over. # TODO 'bout time! + +my $passed = shift @results; +isa_ok $passed, $TEST; +can_ok $passed, 'todo_passed'; +is $passed->type, 'test', 'TODO tests should parse correctly'; +ok $passed->is_test, '... and it should identify itself as a test'; +is $passed->ok, 'not ok', '... and it should have the correct ok()'; +ok $passed->is_ok, '... and TODO tests should always pass'; +ok !$passed->is_actual_ok, + '... and the correct boolean version of is_actual_ok ()'; +is $passed->number, 7, '... and have the correct passed number'; +is $passed->description, '- Gandalf wins. Game over.', + '... and the correct description'; +is $passed->directive, 'TODO', '... and should have the correct directive'; +is $passed->explanation, "'bout time!", + '... and the correct directive explanation'; +ok !$passed->has_skip, '... and it is not a SKIPped passed'; +ok $passed->has_todo, '... but it is a TODO succeeded'; +is $passed->as_string, + "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!", + '... and its string representation should be correct'; +is $passed->raw, "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!", + '... and raw() should return the original line'; +ok !$passed->todo_passed, + '... todo_passed() should not pass for TODO tests which failed'; + +# test parse results + +can_ok $parser, 'passed'; +is $parser->passed, 6, + '... and we should have the correct number of passed tests'; +is_deeply [ $parser->passed ], [ 1, 2, 3, 5, 6, 7 ], + '... and get a list of the passed tests'; + +can_ok $parser, 'failed'; +is $parser->failed, 1, '... and the correct number of failed tests'; +is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests'; + +can_ok $parser, 'actual_passed'; +is $parser->actual_passed, 4, + '... and we should have the correct number of actually passed tests'; +is_deeply [ $parser->actual_passed ], [ 1, 3, 5, 6 ], + '... and get a list of the actually passed tests'; + +can_ok $parser, 'actual_failed'; +is $parser->actual_failed, 3, + '... and the correct number of actually failed tests'; +is_deeply [ $parser->actual_failed ], [ 2, 4, 7 ], + '... or get a list of the actually failed tests'; + +can_ok $parser, 'todo'; +is $parser->todo, 3, + '... and we should have the correct number of TODO tests'; +is_deeply [ $parser->todo ], [ 2, 6, 7 ], + '... and get a list of the TODO tests'; + +can_ok $parser, 'skipped'; +is $parser->skipped, 1, + '... and we should have the correct number of skipped tests'; +is_deeply [ $parser->skipped ], [5], + '... and get a list of the skipped tests'; + +# check the plan + +can_ok $parser, 'plan'; +is $parser->plan, '1..7', '... and we should have the correct plan'; +is $parser->tests_planned, 7, '... and the correct number of tests'; + +# "Unexpectedly succeeded" +can_ok $parser, 'todo_passed'; +is scalar $parser->todo_passed, 1, + '... and it should report the number of tests which unexpectedly succeeded'; +is_deeply [ $parser->todo_passed ], [6], + '... or *which* tests unexpectedly succeeded'; + +# +# Bug report from Torsten Schoenfeld +# Makes sure parser can handle blank lines +# + +$tap = <<'END_TAP'; +1..2 +ok 1 - input file opened + + +ok 2 - read the rest of the file +END_TAP + +my $aref = [ split /\n/ => $tap ]; + +can_ok $PARSER, 'new'; +$parser = $PARSER->new( { stream => TAP::Parser::Iterator->new($aref) } ); +isa_ok $parser, $PARSER, '... and calling it should succeed'; + +# results() is sane? + +ok @results = _get_results($parser), 'The parser should return results'; +is scalar @results, 5, '... and there should be one for each line'; + +# check the test plan + +$result = shift @results; +isa_ok $result, $PLAN; +can_ok $result, 'type'; +is $result->type, 'plan', '... and it should report the correct type'; +ok $result->is_plan, '... and it should identify itself as a plan'; +is $result->plan, '1..2', '... and identify the plan'; +is $result->as_string, '1..2', + '... and have the correct string representation'; +is $result->raw, '1..2', '... and raw() should return the original line'; + +# a normal, passing test + +$test = shift @results; +isa_ok $test, $TEST; +is $test->type, 'test', '... and it should report the correct type'; +ok $test->is_test, '... and it should identify itself as a test'; +is $test->ok, 'ok', '... and it should have the correct ok()'; +ok $test->is_ok, '... and the correct boolean version of is_ok()'; +ok $test->is_actual_ok, + '... and the correct boolean version of is_actual_ok()'; +is $test->number, 1, '... and have the correct test number'; +is $test->description, '- input file opened', + '... and the correct description'; +ok !$test->directive, '... and not have a directive'; +ok !$test->explanation, '... or a directive explanation'; +ok !$test->has_skip, '... and it is not a SKIPped test'; +ok !$test->has_todo, '... nor a TODO test'; +is $test->as_string, 'ok 1 - input file opened', + '... and its string representation should be correct'; +is $test->raw, 'ok 1 - input file opened', + '... and raw() should return the original line'; + +# junk lines should be preserved + +$unknown = shift @results; +isa_ok $unknown, $UNKNOWN; +is $unknown->type, 'unknown', '... and it should report the correct type'; +ok $unknown->is_unknown, '... and it should identify itself as unknown'; +is $unknown->as_string, '', + '... and its string representation should be returned verbatim'; +is $unknown->raw, '', '... and raw() should return the original line'; + +# ... and the second empty line + +$unknown = shift @results; +isa_ok $unknown, $UNKNOWN; +is $unknown->type, 'unknown', '... and it should report the correct type'; +ok $unknown->is_unknown, '... and it should identify itself as unknown'; +is $unknown->as_string, '', + '... and its string representation should be returned verbatim'; +is $unknown->raw, '', '... and raw() should return the original line'; + +# a passing test + +$test = shift @results; +isa_ok $test, $TEST; +is $test->type, 'test', '... and it should report the correct type'; +ok $test->is_test, '... and it should identify itself as a test'; +is $test->ok, 'ok', '... and it should have the correct ok()'; +ok $test->is_ok, '... and the correct boolean version of is_ok()'; +ok $test->is_actual_ok, + '... and the correct boolean version of is_actual_ok()'; +is $test->number, 2, '... and have the correct test number'; +is $test->description, '- read the rest of the file', + '... and the correct description'; +ok !$test->directive, '... and not have a directive'; +ok !$test->explanation, '... or a directive explanation'; +ok !$test->has_skip, '... and it is not a SKIPped test'; +ok !$test->has_todo, '... nor a TODO test'; +is $test->as_string, 'ok 2 - read the rest of the file', + '... and its string representation should be correct'; +is $test->raw, 'ok 2 - read the rest of the file', + '... and raw() should return the original line'; + +is scalar $parser->passed, 2, + 'Empty junk lines should not affect the correct number of tests passed'; + +# coverage tests +{ + + # calling a TAP::Parser internal method with a 'foreign' class + + my $foreigner = bless {}, 'Foreigner'; + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + TAP::Parser::_stream $foreigner, qw(a b c); + }; + + unless ( is @die, 1, 'coverage testing for TAP::Parser accessors' ) { + diag " >>> $_ <<<\n" for @die; + } + + like pop @die, qr/_stream[(][)] may not be set externally/, + '... and we died with expected message'; +} + +{ + + # set a spool to write to + tie local *SPOOL, 'IO::c55Capture'; + + my $tap = <<'END_TAP'; +TAP version 13 +1..7 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure + --- YAML! + ... +ok 5 # skip we have no description +ok 6 - you shall not pass! # TODO should have failed +not ok 7 - Gandalf wins. Game over. # TODO 'bout time! +END_TAP + + { + my $parser = $PARSER->new( + { tap => $tap, + spool => \*SPOOL, + } + ); + + _get_results($parser); + + my @spooled = tied(*SPOOL)->dump(); + + is @spooled, 24, 'coverage testing for spool attribute of parser'; + is join( '', @spooled ), $tap, "spooled tap matches"; + } + + { + my $parser = $PARSER->new( + { tap => $tap, + spool => \*SPOOL, + } + ); + + $parser->callback( 'ALL', sub { } ); + + _get_results($parser); + + my @spooled = tied(*SPOOL)->dump(); + + is @spooled, 24, 'coverage testing for spool attribute of parser'; + is join( '', @spooled ), $tap, "spooled tap matches"; + } +} + +{ + + # _initialize coverage + + my $x = bless [], 'kjsfhkjsdhf'; + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $PARSER->new(); + }; + + is @die, 1, 'coverage testing for _initialize'; + + like pop @die, qr/PANIC:\s+could not determine stream at/, + '...and it failed as expected'; + + @die = (); + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $PARSER->new( + { stream => 'stream', + tap => 'tap', + source => 'source', # only one of these is allowed + } + ); + }; + + is @die, 1, 'coverage testing for _initialize'; + + like pop @die, + qr/You may only choose one of 'exec', 'stream', 'tap' or 'source'/, + '...and it failed as expected'; +} + +{ + + # coverage of todo_failed + + my $tap = <<'END_TAP'; +TAP version 13 +1..7 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure + --- YAML! + ... +ok 5 # skip we have no description +ok 6 - you shall not pass! # TODO should have failed +not ok 7 - Gandalf wins. Game over. # TODO 'bout time! +END_TAP + + my $parser = $PARSER->new( { tap => $tap } ); + + _get_results($parser); + + my @warn; + + eval { + local $SIG{__WARN__} = sub { push @warn, @_ }; + + $parser->todo_failed; + }; + + is @warn, 1, 'coverage testing of todo_failed'; + + like pop @warn, + qr/"todo_failed" is deprecated. Please use "todo_passed". See the docs[.]/, + '..and failed as expected' +} + +{ + + # coverage testing for T::P::_initialize + + # coverage of the source argument paths + + # ref argument to source + + my $parser = TAP::Parser->new( { source => [ split /$/, $tap ] } ); + + isa_ok $parser, 'TAP::Parser'; + + isa_ok $parser->_stream, 'TAP::Parser::Iterator::Array'; + + # uncategorisable argument to source + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $parser = TAP::Parser->new( { source => 'nosuchfile' } ); + }; + + is @die, 1, 'uncategorisable source'; + + like pop @die, qr/Cannot determine source for nosuchfile/, + '... and we died as expected'; +} + +{ + + # coverage test of perl source with switches + + my $parser = TAP::Parser->new( + { source => File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'), + 'sample-tests', 'simple' ), + } + ); + + isa_ok $parser, 'TAP::Parser'; + + isa_ok $parser->_stream, 'TAP::Parser::Iterator::Process'; + + # Workaround for Mac OS X problem wrt closing the iterator without + # reading from it. + $parser->next; +} + +{ + + # coverage testing for TAP::Parser::has_problems + + # we're going to need to test lots of fragments of tap + # to cover all the different boolean tests + + # currently covered are no problems and failed, so let's next test + # todo_passed + + my $tap = <<'END_TAP'; +TAP version 13 +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins. Game over. # TODO 'bout time! +END_TAP + + my $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + ok !$parser->failed; + ok $parser->todo_passed; + + ok !$parser->has_problems, 'and has_problems is false'; + + # now parse_errors + + $tap = <<'END_TAP'; +TAP version 13 +1..2 +SMACK +END_TAP + + $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + ok !$parser->failed; + ok !$parser->todo_passed; + ok $parser->parse_errors; + + ok $parser->has_problems; + + # Now wait and exit are hard to do in an OS platform-independent way, so + # we won't even bother + + $tap = <<'END_TAP'; +TAP version 13 +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + $parser->wait(1); + + ok !$parser->failed; + ok !$parser->todo_passed; + ok !$parser->parse_errors; + + ok $parser->wait; + + ok $parser->has_problems; + + # and use the same for exit + + $parser->wait(0); + $parser->exit(1); + + ok !$parser->failed; + ok !$parser->todo_passed; + ok !$parser->parse_errors; + ok !$parser->wait; + + ok $parser->exit; + + ok $parser->has_problems; +} + +{ + + # coverage testing of the version states + + my $tap = <<'END_TAP'; +TAP version 12 +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + my $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + my @errors = $parser->parse_errors; + + is @errors, 1, 'test too low version number'; + + like pop @errors, + qr/Explicit TAP version must be at least 13. Got version 12/, + '... and trapped expected version error'; + + # now too high a version + $tap = <<'END_TAP'; +TAP version 14 +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + @errors = $parser->parse_errors; + + is @errors, 1, 'test too high version number'; + + like pop @errors, + qr/TAP specified version 14 but we don't know about versions later than 13/, + '... and trapped expected version error'; +} + +{ + + # coverage testing of TAP version in the wrong place + + my $tap = <<'END_TAP'; +1..2 +ok 1 - input file opened +TAP version 12 +ok 2 - Gandalf wins +END_TAP + + my $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + my @errors = $parser->parse_errors; + + is @errors, 1, 'test TAP version number in wrong place'; + + like pop @errors, + qr/If TAP version is present it must be the first line of output/, + '... and trapped expected version error'; + +} + +{ + + # we're going to bash the internals a bit (but using the API as + # much as possible) to force grammar->tokenise() to fail + + # firstly we'll create a stream that dies when its next_raw method is called + + package TAP::Parser::Iterator::Dies; + + use strict; + use vars qw(@ISA); + + @ISA = qw(TAP::Parser::Iterator); + + sub new { + return bless {}, shift; + } + + sub next_raw { + die 'this is the dying iterator'; + } + + # required as part of the TPI interface + sub exit { } + sub wait { } + + package main; + + # now build a standard parser + + my $tap = <<'END_TAP'; +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + { + my $parser = TAP::Parser->new( { tap => $tap } ); + + # build a dying stream + my $stream = TAP::Parser::Iterator::Dies->new; + + # now replace the stream - we're forced to us an T::P intenal + # method for this + $parser->_stream($stream); + + # build a new grammar + my $grammar = TAP::Parser::Grammar->new($stream); + + # replace our grammar with this new one + $parser->_grammar($grammar); + + # now call next on the parser, and the grammar should die + my $result = $parser->next; # will die in iterator + + is $result, undef, 'iterator dies'; + + my @errors = $parser->parse_errors; + is @errors, 2, '...and caught expected errrors'; + + like shift @errors, qr/this is the dying iterator/, + '...and it was what we expected'; + } + + # Do it all again with callbacks to exercise the other code path in + # the unrolled iterator + { + my $parser = TAP::Parser->new( { tap => $tap } ); + + $parser->callback( 'ALL', sub { } ); + + # build a dying stream + my $stream = TAP::Parser::Iterator::Dies->new; + + # now replace the stream - we're forced to us an T::P intenal + # method for this + $parser->_stream($stream); + + # build a new grammar + my $grammar = TAP::Parser::Grammar->new($stream); + + # replace our grammar with this new one + $parser->_grammar($grammar); + + # now call next on the parser, and the grammar should die + my $result = $parser->next; # will die in iterator + + is $result, undef, 'iterator dies'; + + my @errors = $parser->parse_errors; + is @errors, 2, '...and caught expected errrors'; + + like shift @errors, qr/this is the dying iterator/, + '...and it was what we expected'; + } +} + +{ + + # coverage testing of TAP::Parser::_next_state + + package TAP::Parser::WithBrokenState; + use vars qw(@ISA); + + @ISA = qw( TAP::Parser ); + + sub _make_state_table { + return { INIT => { plan => { goto => 'FOO' } } }; + } + + package main; + + my $tap = <<'END_TAP'; +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + my $parser = TAP::Parser::WithBrokenState->new( { tap => $tap } ); + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $parser->next; + $parser->next; + }; + + is @die, 1, 'detect broken state machine'; + + like pop @die, qr/Illegal state: FOO/, + '...and the message is as we expect'; +} + +{ + + # coverage testing of TAP::Parser::_iter + + package TAP::Parser::WithBrokenIter; + use vars qw(@ISA); + + @ISA = qw( TAP::Parser ); + + sub _iter {return} + + package main; + + my $tap = <<'END_TAP'; +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + my $parser = TAP::Parser::WithBrokenIter->new( { tap => $tap } ); + + my @die; + + eval { + local $SIG{__WARN__} = sub { }; + local $SIG{__DIE__} = sub { push @die, @_ }; + + $parser->next; + }; + + is @die, 1, 'detect broken iter'; + + like pop @die, qr/Can't use/, '...and the message is as we expect'; +} + +{ + + # coverage testing of TAP::Parser::_finish + + my $tap = <<'END_TAP'; +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + my $parser = TAP::Parser->new( { tap => $tap } ); + + $parser->tests_run(999); + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + _get_results $parser; + }; + + is @die, 1, 'detect broken test counts'; + + like pop @die, + qr/Panic: planned test count [(]1001[)] did not equal sum of passed [(]0[)] and failed [(]2[)] tests!/, + '...and the message is as we expect'; +} diff --git a/lib/Test/Harness/t/premature-bailout.t b/lib/Test/Harness/t/premature-bailout.t new file mode 100644 index 0000000000..d38e6d189a --- /dev/null +++ b/lib/Test/Harness/t/premature-bailout.t @@ -0,0 +1,124 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 14; + +use TAP::Parser; +use TAP::Parser::Iterator; + +sub tap_to_lines { + my $string = shift; + my @lines = ( $string =~ /.*\n/g ); + return \@lines; +} + +my $tap = <<'END_TAP'; +1..4 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +Bail out! We ran out of foobar. +not ok 5 +END_TAP + +my $parser = TAP::Parser->new( + { stream => TAP::Parser::Iterator->new( tap_to_lines($tap) ), + } +); + +# results() is sane? + +# check the test plan +my $result = $parser->next(); + +# TEST +ok $result->is_plan, 'We should have a plan'; + +# a normal, passing test + +my $test = $parser->next(); + +# TEST +ok $test->is_test, '... and a test'; + +# junk lines should be preserved + +my $unknown = $parser->next(); + +# TEST +ok $unknown->is_unknown, '... and an unknown line'; + +# a failing test, which also happens to have a directive + +my $failed = $parser->next(); + +# TEST +ok $failed->is_test, '... and another test'; + +# comments + +my $comment = $parser->next(); + +# TEST +ok $comment->is_comment, '... and a comment'; + +# another normal, passing test + +$test = $parser->next(); + +# TEST +ok $test->is_test, '... and another test'; + +# a failing test + +$failed = $parser->next(); + +# TEST +ok $failed->is_test, '... and yet another test'; + +# ok 5 # skip we have no description +# skipped test +my $bailout = $parser->next(); + +# TEST +ok $bailout->is_bailout, 'And finally we should have a bailout'; + +# TEST +is $bailout->as_string, 'We ran out of foobar.', + '... and as_string() should return the explanation'; + +# TEST +is( $bailout->raw, 'Bail out! We ran out of foobar.', + '... and raw() should return the explanation' +); + +# TEST +is( $bailout->explanation, 'We ran out of foobar.', + '... and it should have the correct explanation' +); + +my $more_tap = "1..1\nok 1 - input file opened\n"; + +my $second_parser = TAP::Parser->new( + { stream => TAP::Parser::Iterator->new( [ split( /\n/, $more_tap ) ] ), + } +); + +$result = $second_parser->next(); + +# TEST +ok $result->is_plan(), "Result is not the leftover line"; + +$result = $second_parser->next(); + +# TEST +ok $result->is_test(), "Result is a test"; + +# TEST +ok $result->is_ok(), "The event has passed"; + diff --git a/lib/Test/Harness/t/process.t b/lib/Test/Harness/t/process.t new file mode 100644 index 0000000000..e4d585e261 --- /dev/null +++ b/lib/Test/Harness/t/process.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +my $hires; + +BEGIN { + $hires = eval 'use Time::HiRes qw(sleep); 1'; +} + +use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) + : $hires ? ( tests => 9 * 3 ) + : ( skip_all => 'Need Time::HiRes' ) ); + +use File::Spec; +use TAP::Parser::Iterator::Process; + +my @expect = ( + '1..5', + 'ok 1 00000', + 'ok 2', + 'not ok 3', + 'ok 4', + 'ok 5 00000', +); + +my $source = File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'), + 'sample-tests', 'delayed' ); + +for my $chunk_size ( 1, 4, 65536 ) { + for my $where ( 0 .. 8 ) { + + my $proc = TAP::Parser::Iterator::Process->new( + { _chunk_size => $chunk_size, + command => [ $^X, $source, ( 1 << $where ) ] + } + ); + + my @got = (); + while ( defined( my $line = $proc->next_raw ) ) { + push @got, $line; + } + + is_deeply \@got, \@expect, + "I/O ok with delay at position $where, chunk size $chunk_size"; + } +} diff --git a/lib/Test/Harness/t/prove.t b/lib/Test/Harness/t/prove.t new file mode 100644 index 0000000000..8d90f4b608 --- /dev/null +++ b/lib/Test/Harness/t/prove.t @@ -0,0 +1,1385 @@ +#!/usr/bin/perl -w + +BEGIN { + if ($ENV{PERL_CORE}) { + # FIXME + print "1..0 # Skip, needs fixing. Probably an -I issue\n"; + exit 0; + } +} + +use strict; +use lib 't/lib'; + +use Test::More; +use File::Spec; + +use App::Prove; + +package FakeProve; +use vars qw( @ISA ); + +@ISA = qw( App::Prove ); + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + $self->{_log} = []; + return $self; +} + +sub _color_default {0} + +sub _runtests { + my $self = shift; + push @{ $self->{_log} }, [ '_runtests', @_ ]; +} + +sub get_log { + my $self = shift; + my @log = @{ $self->{_log} }; + $self->{_log} = []; + return @log; +} + +sub _shuffle { + my $self = shift; + s/^/xxx/ for @_; +} + +package main; + +sub mabs { + my $ar = shift; + return [ map { File::Spec->rel2abs($_) } @$ar ]; +} + +{ + my @import_log = (); + + sub test_log_import { push @import_log, [@_] } + + sub get_import_log { + my @log = @import_log; + @import_log = (); + return @log; + } +} + +my ( @ATTR, %DEFAULT_ASSERTION, @SCHEDULE ); + +# see the "ACTUAL TEST" section at the bottom + +BEGIN { # START PLAN + + # list of attributes + @ATTR = qw( + archive argv blib color directives exec failures formatter harness + includes lib merge parse quiet really_quiet recurse backwards + shuffle taint_fail taint_warn verbose warnings_fail warnings_warn + ); + + # what we expect if the 'expect' hash does not define it + %DEFAULT_ASSERTION = map { $_ => undef } @ATTR; + + $DEFAULT_ASSERTION{includes} = $DEFAULT_ASSERTION{argv} + = sub { 'ARRAY' eq ref shift }; + + my @dummy_tests = map { File::Spec->catdir( 't', 'sample-tests', $_ ) } + qw(simple simple_yaml); + my $dummy_test = $dummy_tests[0]; + + ######################################################################## + # declarations - this drives all of the subtests. + # The cheatsheet follows. + # required: name, expect + # optional: + # args - arguments to constructor + # switches - command-line switches + # runlog - expected results of internal calls to _runtests, must + # match FakeProve's _log attr + # run_error - depends on 'runlog' (if missing, asserts no error) + # extra - follow-up check to handle exceptional cleanup / verification + # class - The App::Prove subclass to test. Defaults to FakeProve + @SCHEDULE = ( + { name => 'Create empty', + expect => {} + }, + { name => 'Set all options via constructor', + args => { + archive => 1, + argv => [qw(one two three)], + blib => 2, + color => 3, + directives => 4, + exec => 5, + failures => 7, + formatter => 8, + harness => 9, + includes => [qw(four five six)], + lib => 10, + merge => 11, + parse => 13, + quiet => 14, + really_quiet => 15, + recurse => 16, + backwards => 17, + shuffle => 18, + taint_fail => 19, + taint_warn => 20, + verbose => 21, + warnings_fail => 22, + warnings_warn => 23, + }, + expect => { + archive => 1, + argv => [qw(one two three)], + blib => 2, + color => 3, + directives => 4, + exec => 5, + failures => 7, + formatter => 8, + harness => 9, + includes => [qw(four five six)], + lib => 10, + merge => 11, + parse => 13, + quiet => 14, + really_quiet => 15, + recurse => 16, + backwards => 17, + shuffle => 18, + taint_fail => 19, + taint_warn => 20, + verbose => 21, + warnings_fail => 22, + warnings_warn => 23, + } + }, + { name => 'Call with defaults', + args => { argv => [qw( one two three )] }, + expect => {}, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + 'one', + 'two', + 'three' + ] + ], + }, + + # Test all options individually + + # { name => 'Just archive', + # args => { + # argv => [qw( one two three )], + # archive => 1, + # }, + # expect => { + # archive => 1, + # }, + # runlog => [ + # [ { archive => 1, + # }, + # 'TAP::Harness', + # 'one', 'two', + # 'three' + # ] + # ], + # }, + { name => 'Just argv', + args => { + argv => [qw( one two three )], + }, + expect => { + argv => [qw( one two three )], + }, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + 'one', 'two', + 'three' + ] + ], + }, + { name => 'Just blib', + args => { + argv => [qw( one two three )], + blib => 1, + }, + expect => { + blib => 1, + }, + runlog => [ + [ '_runtests', + { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + { name => 'Just color', + args => { + argv => [qw( one two three )], + color => 1, + }, + expect => { + color => 1, + }, + runlog => [ + [ '_runtests', + { color => 1, + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + { name => 'Just directives', + args => { + argv => [qw( one two three )], + directives => 1, + }, + expect => { + directives => 1, + }, + runlog => [ + [ '_runtests', + { directives => 1, + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just exec', + args => { + argv => [qw( one two three )], + exec => 1, + }, + expect => { + exec => 1, + }, + runlog => [ + [ '_runtests', + { exec => [1], + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just failures', + args => { + argv => [qw( one two three )], + failures => 1, + }, + expect => { + failures => 1, + }, + runlog => [ + [ '_runtests', + { failures => 1, + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + { name => 'Just formatter', + args => { + argv => [qw( one two three )], + formatter => 'TAP::Harness', + }, + expect => { + formatter => 'TAP::Harness', + }, + runlog => [ + [ '_runtests', + { formatter_class => 'TAP::Harness', + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + { name => 'Just includes', + args => { + argv => [qw( one two three )], + includes => [qw( four five six )], + }, + expect => { + includes => [qw( four five six )], + }, + runlog => [ + [ '_runtests', + { lib => mabs( [qw( four five six )] ), + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just lib', + args => { + argv => [qw( one two three )], + lib => 1, + }, + expect => { + lib => 1, + }, + runlog => [ + [ '_runtests', + { lib => mabs( ['lib'] ), + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just merge', + args => { + argv => [qw( one two three )], + merge => 1, + }, + expect => { + merge => 1, + }, + runlog => [ + [ '_runtests', + { merge => 1, + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just parse', + args => { + argv => [qw( one two three )], + parse => 1, + }, + expect => { + parse => 1, + }, + runlog => [ + [ '_runtests', + { errors => 1, + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just quiet', + args => { + argv => [qw( one two three )], + quiet => 1, + }, + expect => { + quiet => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => -1 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just really_quiet', + args => { + argv => [qw( one two three )], + really_quiet => 1, + }, + expect => { + really_quiet => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => -2 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just recurse', + args => { + argv => [qw( one two three )], + recurse => 1, + }, + expect => { + recurse => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just reverse', + args => { + argv => [qw( one two three )], + backwards => 1, + }, + expect => { + backwards => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + 'three', 'two', 'one' + ] + ], + }, + + { name => 'Just shuffle', + args => { + argv => [qw( one two three )], + shuffle => 1, + }, + expect => { + shuffle => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + 'xxxone', 'xxxtwo', + 'xxxthree' + ] + ], + }, + { name => 'Just taint_fail', + args => { + argv => [qw( one two three )], + taint_fail => 1, + }, + expect => { + taint_fail => 1, + }, + runlog => [ + [ '_runtests', + { switches => ['-T'], + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just taint_warn', + args => { + argv => [qw( one two three )], + taint_warn => 1, + }, + expect => { + taint_warn => 1, + }, + runlog => [ + [ '_runtests', + { switches => ['-t'], + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just verbose', + args => { + argv => [qw( one two three )], + verbose => 1, + }, + expect => { + verbose => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 1 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just warnings_fail', + args => { + argv => [qw( one two three )], + warnings_fail => 1, + }, + expect => { + warnings_fail => 1, + }, + runlog => [ + [ '_runtests', + { switches => ['-W'], + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just warnings_warn', + args => { + argv => [qw( one two three )], + warnings_warn => 1, + }, + expect => { + warnings_warn => 1, + }, + runlog => [ + [ '_runtests', + { switches => ['-w'], + verbosity => 0 + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + # Command line parsing + { name => 'Switch -v', + args => { + argv => [qw( one two three )], + }, + switches => [ '-v', $dummy_test ], + expect => { + verbose => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 1 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --verbose', + args => { + argv => [qw( one two three )], + }, + switches => [ '--verbose', $dummy_test ], + expect => { + verbose => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 1 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -f', + args => { + argv => [qw( one two three )], + }, + switches => [ '-f', $dummy_test ], + expect => { failures => 1 }, + runlog => [ + [ '_runtests', + { failures => 1, + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --failures', + args => { + argv => [qw( one two three )], + }, + switches => [ '--failures', $dummy_test ], + expect => { failures => 1 }, + runlog => [ + [ '_runtests', + { failures => 1, + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -l', + args => { + argv => [qw( one two three )], + }, + switches => [ '-l', $dummy_test ], + expect => { lib => 1 }, + runlog => [ + [ '_runtests', + { lib => mabs( ['lib'] ), + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --lib', + args => { + argv => [qw( one two three )], + }, + switches => [ '--lib', $dummy_test ], + expect => { lib => 1 }, + runlog => [ + [ '_runtests', + { lib => mabs( ['lib'] ), + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -b', + args => { + argv => [qw( one two three )], + }, + switches => [ '-b', $dummy_test ], + expect => { blib => 1 }, + runlog => [ + [ '_runtests', + { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --blib', + args => { + argv => [qw( one two three )], + }, + switches => [ '--blib', $dummy_test ], + expect => { blib => 1 }, + runlog => [ + [ '_runtests', + { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -s', + args => { + argv => [qw( one two three )], + }, + switches => [ '-s', $dummy_test ], + expect => { shuffle => 1 }, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + "xxx$dummy_test" + ] + ], + }, + + { name => 'Switch --shuffle', + args => { + argv => [qw( one two three )], + }, + switches => [ '--shuffle', $dummy_test ], + expect => { shuffle => 1 }, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + "xxx$dummy_test" + ] + ], + }, + + { name => 'Switch -c', + args => { + argv => [qw( one two three )], + }, + switches => [ '-c', $dummy_test ], + expect => { color => 1 }, + runlog => [ + [ '_runtests', + { color => 1, + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -r', + args => { + argv => [qw( one two three )], + }, + switches => [ '-r', $dummy_test ], + expect => { recurse => 1 }, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --recurse', + args => { + argv => [qw( one two three )], + }, + switches => [ '--recurse', $dummy_test ], + expect => { recurse => 1 }, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --reverse', + args => { + argv => [qw( one two three )], + }, + switches => [ '--reverse', @dummy_tests ], + expect => { backwards => 1 }, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + reverse @dummy_tests + ] + ], + }, + + { name => 'Switch -p', + args => { + argv => [qw( one two three )], + }, + switches => [ '-p', $dummy_test ], + expect => { + parse => 1, + }, + runlog => [ + [ '_runtests', + { errors => 1, + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --parse', + args => { + argv => [qw( one two three )], + }, + switches => [ '--parse', $dummy_test ], + expect => { + parse => 1, + }, + runlog => [ + [ '_runtests', + { errors => 1, + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -q', + args => { + argv => [qw( one two three )], + }, + switches => [ '-q', $dummy_test ], + expect => { quiet => 1 }, + runlog => [ + [ '_runtests', + { verbosity => -1 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --quiet', + args => { + argv => [qw( one two three )], + }, + switches => [ '--quiet', $dummy_test ], + expect => { quiet => 1 }, + runlog => [ + [ '_runtests', + { verbosity => -1 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -Q', + args => { + argv => [qw( one two three )], + }, + switches => [ '-Q', $dummy_test ], + expect => { really_quiet => 1 }, + runlog => [ + [ '_runtests', + { verbosity => -2 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --QUIET', + args => { + argv => [qw( one two three )], + }, + switches => [ '--QUIET', $dummy_test ], + expect => { really_quiet => 1 }, + runlog => [ + [ '_runtests', + { verbosity => -2 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -m', + args => { + argv => [qw( one two three )], + }, + switches => [ '-m', $dummy_test ], + expect => { merge => 1 }, + runlog => [ + [ '_runtests', + { merge => 1, + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --merge', + args => { + argv => [qw( one two three )], + }, + switches => [ '--merge', $dummy_test ], + expect => { merge => 1 }, + runlog => [ + [ '_runtests', + { merge => 1, + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --directives', + args => { + argv => [qw( one two three )], + }, + switches => [ '--directives', $dummy_test ], + expect => { directives => 1 }, + runlog => [ + [ '_runtests', + { directives => 1, + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # Executing one word (why would it be a -s though?) + { name => 'Switch --exec -s', + args => { + argv => [qw( one two three )], + }, + switches => [ '--exec', '-s', $dummy_test ], + expect => { exec => '-s' }, + runlog => [ + [ '_runtests', { exec => ['-s'], verbosity => 0 }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # multi-part exec + { name => 'Switch --exec "/foo/bar/perl -Ilib"', + args => { + argv => [qw( one two three )], + }, + switches => [ '--exec', '/foo/bar/perl -Ilib', $dummy_test ], + expect => { exec => '/foo/bar/perl -Ilib' }, + runlog => [ + [ '_runtests', + { exec => [qw(/foo/bar/perl -Ilib)], + verbosity => 0 + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # null exec (run tests as compiled binaries) + { name => 'Switch --exec ""', + switches => [ '--exec', '', $dummy_test ], + expect => { + exec => # ick, must workaround the || default bit with a sub + sub { my $val = shift; defined($val) and !length($val) } + }, + runlog => [ + [ '_runtests', + { exec => [], verbosity => 0 }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # Plugins + { name => 'Load plugin', + switches => [ '-P', 'Dummy', $dummy_test ], + args => { + argv => [qw( one two three )], + }, + expect => { + plugins => ['Dummy'], + }, + extra => sub { + my @loaded = get_import_log(); + is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], + "Plugin loaded OK"; + }, + plan => 1, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Load plugin (args)', + switches => [ '-P', 'Dummy=cracking,cheese,gromit', $dummy_test ], + args => { + argv => [qw( one two three )], + }, + expect => { + plugins => ['Dummy'], + }, + extra => sub { + my @loaded = get_import_log(); + is_deeply \@loaded, + [ [ 'App::Prove::Plugin::Dummy', 'cracking', 'cheese', + 'gromit' + ] + ], + "Plugin loaded OK"; + }, + plan => 1, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Load plugin (explicit path)', + switches => [ '-P', 'App::Prove::Plugin::Dummy', $dummy_test ], + args => { + argv => [qw( one two three )], + }, + expect => { + plugins => ['Dummy'], + }, + extra => sub { + my @loaded = get_import_log(); + is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], + "Plugin loaded OK"; + }, + plan => 1, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Load module', + switches => [ '-M', 'App::Prove::Plugin::Dummy', $dummy_test ], + args => { + argv => [qw( one two three )], + }, + expect => { + plugins => ['Dummy'], + }, + extra => sub { + my @loaded = get_import_log(); + is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], + "Plugin loaded OK"; + }, + plan => 1, + runlog => [ + [ '_runtests', + { verbosity => 0 }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # TODO + # Hmm, that doesn't work... + # { name => 'Switch -h', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-h', $dummy_test ], + # expect => {}, + # runlog => [ + # [ '_runtests', + # {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + + # { name => 'Switch --help', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--help', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # { name => 'Switch -?', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-?', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch -H', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-H', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --man', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--man', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch -V', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-V', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --version', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--version', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --color!', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--color!', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + { name => 'Switch -I=s@', + args => { + argv => [qw( one two three )], + }, + switches => [ '-Ilib', $dummy_test ], + expect => { + includes => sub { + my ( $val, $attr ) = @_; + return + 'ARRAY' eq ref $val + && 1 == @$val + && $val->[0] =~ /lib$/; + }, + }, + }, + + # { name => 'Switch -a', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-a', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --archive=-s', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--archive=-s', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --formatter=-s', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--formatter=-s', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch -e', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-e', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --harness=-s', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--harness=-s', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + + ); + + # END SCHEDULE + ######################################################################## + + my $extra_plan = 0; + for my $test (@SCHEDULE) { + $extra_plan += $test->{plan} || 0; + $extra_plan += 2 if $test->{runlog}; + $extra_plan += 1 if $test->{switches}; + } + + plan tests => @SCHEDULE * ( 3 + @ATTR ) + $extra_plan; +} # END PLAN + +# ACTUAL TEST +for my $test (@SCHEDULE) { + my $name = $test->{name}; + my $class = $test->{class} || 'FakeProve'; + + ok my $app = $class->new( exists $test->{args} ? $test->{args} : () ), + "$name: App::Prove created OK"; + + isa_ok $app, 'App::Prove'; + isa_ok $app, $class; + + # Optionally parse command args + if ( my $switches = $test->{switches} ) { + eval { $app->process_args( '--norc', @$switches ) }; + if ( my $err_pattern = $test->{parse_error} ) { + like $@, $err_pattern, "$name: expected parse error"; + } + else { + ok !$@, "$name: no parse error"; + } + } + + my $expect = $test->{expect} || {}; + for my $attr ( sort @ATTR ) { + my $val = $app->$attr(); + my $assertion = $expect->{$attr} || $DEFAULT_ASSERTION{$attr}; + my $is_ok = undef; + + if ( 'CODE' eq ref $assertion ) { + $is_ok = ok $assertion->( $val, $attr ), + "$name: $attr has the expected value"; + } + elsif ( 'Regexp' eq ref $assertion ) { + $is_ok = like $val, $assertion, "$name: $attr matches $assertion"; + } + else { + $is_ok = is_deeply $val, $assertion, + "$name: $attr has the expected value"; + } + + unless ($is_ok) { + diag "got $val for $attr"; + } + } + + if ( my $runlog = $test->{runlog} ) { + eval { $app->run }; + if ( my $err_pattern = $test->{run_error} ) { + like $@, $err_pattern, "$name: expected error OK"; + pass; + pass for 1 .. $test->{plan}; + } + else { + unless ( ok !$@, "$name: no error OK" ) { + diag "$name: error: $@\n"; + } + + my $gotlog = [ $app->get_log ]; + + if ( my $extra = $test->{extra} ) { + $extra->($gotlog); + } + + unless ( + is_deeply $gotlog, $runlog, + "$name: run results match" + ) + { + use Data::Dumper; + diag Dumper( { wanted => $runlog, got => $gotlog } ); + } + } + } +} diff --git a/lib/Test/Harness/t/proverc.t b/lib/Test/Harness/t/proverc.t new file mode 100644 index 0000000000..0e196ec4b7 --- /dev/null +++ b/lib/Test/Harness/t/proverc.t @@ -0,0 +1,25 @@ +#!/usr/bin/perl -w + +BEGIN { + if ($ENV{PERL_CORE}) { + # FIXME + print "1..0 # Skip, needs fixing. Probably an -I issue\n"; + exit 0; + } +} + +use strict; +use lib 't/lib'; +use Test::More tests => 1; +use File::Spec; +use App::Prove; + +my $prove = App::Prove->new; + +$prove->add_rc_file( File::Spec->catfile( 't', 'data', 'proverc' ) ); + +is_deeply $prove->{rc_opts}, + [ '--should', 'be', '--split', 'correctly', 'Can', 'quote things', + 'using single or', 'double quotes', '--this', 'is', 'OK?' ], + 'options parsed'; + diff --git a/lib/Test/Harness/t/proverun.t b/lib/Test/Harness/t/proverun.t new file mode 100644 index 0000000000..e68b6d794a --- /dev/null +++ b/lib/Test/Harness/t/proverun.t @@ -0,0 +1,167 @@ +#!/usr/bin/perl -w + +BEGIN { + if ($ENV{PERL_CORE}) { + # FIXME + print "1..0 # Skip, needs fixing. Probably an -I issue\n"; + exit 0; + } +} + +use strict; + +use lib 't/lib'; + +use Test::More; +use File::Spec; +use App::Prove; + +my @SCHEDULE; + +BEGIN { + + my $sample_test + = File::Spec->catfile( split /\//, 't/sample-tests/simple' ); + + @SCHEDULE = ( + { name => 'Create empty', + args => [$sample_test], + expect => [ + [ 'new', + 'TAP::Parser::Iterator::Process', + { merge => undef, + command => [ + 'PERL', + $sample_test + ], + setup => \'CODE', + teardown => \'CODE', + + } + ] + ] + }, + ); + + plan tests => @SCHEDULE * 2; +} + +# Waaaaay too much boilerplate + +package FakeProve; +use vars qw( @ISA ); + +@ISA = qw( App::Prove ); + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + $self->{_log} = []; + return $self; +} + +sub _exit { + my $self = shift; + push @{ $self->{_log} }, [ '_exit', @_ ]; + die "Exited"; +} + +sub get_log { + my $self = shift; + my @log = @{ $self->{_log} }; + $self->{_log} = []; + return @log; +} + +package main; + +{ + use TAP::Parser::Iterator::Process; + use TAP::Formatter::Console; + + # Patch TAP::Parser::Iterator::Process + my @call_log = (); + + local $^W; # no warnings + + my $orig_new = \&TAP::Parser::Iterator::Process::new; + *TAP::Parser::Iterator::Process::new = sub { + push @call_log, [ 'new', @_ ]; + + # And then new turns round and tramples on our args... + $_[1] = { %{ $_[1] } }; + $orig_new->(@_); + }; + + # Patch TAP::Formatter::Console; + my $orig_output = \&TAP::Formatter::Console::_output; + *TAP::Formatter::Console::_output = sub { + + # push @call_log, [ '_output', @_ ]; + }; + + sub get_log { + my @log = @call_log; + @call_log = (); + return @log; + } +} + +sub _slacken { + my $obj = shift; + if ( my $ref = ref $obj ) { + if ( 'HASH' eq ref $obj ) { + return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj }; + } + elsif ( 'ARRAY' eq ref $obj ) { + return [ map { _slacken($_) } @$obj ]; + } + elsif ( 'SCALAR' eq ref $obj ) { + return $obj; + } + else { + return \$ref; + } + } + else { + return $obj; + } +} + +sub is_slackly($$$) { + my ( $got, $want, $msg ) = @_; + return is_deeply _slacken($got), _slacken($want), $msg; +} + +# ACTUAL TEST +for my $test (@SCHEDULE) { + my $name = $test->{name}; + + my $app = FakeProve->new; + $app->process_args( '--norc', @{ $test->{args} } ); + + # Why does this make the output from the test spew out of + # our STDOUT? + eval { $app->run }; + like $@, qr{Exited}, "$name: exited via _exit()"; + + my @log = get_log(); + + # Bodge: we don't know what pathname will be used for the exe so we + # obliterate it here. Need to test that it's sane. + for my $call (@log) { + if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) { + $call->[2]->{command}->[0] = 'PERL'; + } + } + + is_slackly \@log, $test->{expect}, "$name: command args OK"; + + # use Data::Dumper; + # diag Dumper( + # { got => \@log, + # expect => $test->{expect} + # } + # ); +} + diff --git a/lib/Test/Harness/t/regression.t b/lib/Test/Harness/t/regression.t new file mode 100644 index 0000000000..14f613c825 --- /dev/null +++ b/lib/Test/Harness/t/regression.t @@ -0,0 +1,3130 @@ +#!/usr/bin/perl -w + +BEGIN { + chdir 't' and @INC = '../lib' if $ENV{PERL_CORE}; +} + +use strict; +use lib 't/lib'; + +use Test::More 'no_plan'; + +use File::Spec; +use Config; + +use constant TRUE => "__TRUE__"; +use constant FALSE => "__FALSE__"; + +# if wait() is non-zero, we cannot reliably predict its value +use constant NOT_ZERO => "__NOT_ZERO__"; + +use TAP::Parser; + +my $IsVMS = $^O eq 'VMS'; +my $IsWin32 = $^O eq 'MSWin32'; + +my $SAMPLE_TESTS + = File::Spec->catdir( File::Spec->curdir, ($ENV{PERL_CORE} ? 'lib' : 't'), + 'sample-tests' ); + +my %deprecated = map { $_ => 1 } qw( + TAP::Parser::good_plan + TAP::Parser::Result::Plan::passed + TAP::Parser::Result::Test::passed + TAP::Parser::Result::Test::actual_passed + TAP::Parser::Result::passed +); +$SIG{__WARN__} = sub { + if ( $_[0] =~ /is deprecated/ ) { + my @caller = caller(1); + my $sub = $caller[3]; + ok exists $deprecated{$sub}, + "... we should get a deprecated warning for $sub"; + } + else { + CORE::warn @_; + } +}; + +# the %samples keys are the names of test scripts in t/sample-tests +my %samples = ( + descriptive => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "Interlock activated", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "Megathrusters are go", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "Head formed", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "Blazing sword formed", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "Robeast destroyed", + is_unplanned => FALSE, + } + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + descriptive_trailing => { + results => [ + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "Interlock activated", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "Megathrusters are go", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "Head formed", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "Blazing sword formed", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "Robeast destroyed", + is_unplanned => FALSE, + }, + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + empty => { + results => [], + plan => '', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + is_good_plan => FALSE, + tests_planned => undef, + tests_run => 0, + parse_errors => ['No plan found in TAP output'], + 'exit' => 0, + wait => 0, + version => 12, + }, + simple => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + space_after_plan => { + results => [ + { is_plan => TRUE, + raw => '1..5 ', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + simple_yaml => { + results => [ + { is_version => TRUE, + raw => 'TAP version 13', + }, + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { is_yaml => TRUE, + data => [ + { 'fnurk' => 'skib', 'ponk' => 'gleeb' }, + { 'bar' => 'krup', 'foo' => 'plink' } + ], + raw => + " ---\n -\n fnurk: skib\n ponk: gleeb\n -\n bar: krup\n foo: plink\n ...", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { is_yaml => TRUE, + data => { + 'got' => [ '1', 'pong', '4' ], + 'expected' => [ '1', '2', '4' ] + }, + raw => + " ---\n expected:\n - 1\n - 2\n - 4\n got:\n - 1\n - pong\n - 4\n ...", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 13, + }, + simple_fail => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1, 3, 4 ], + actual_passed => [ 1, 3, 4 ], + failed => [ 2, 5 ], + actual_failed => [ 2, 5 ], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + skip => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => TRUE, + has_todo => FALSE, + number => 2, + description => "", + explanation => 'rain delay', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [2], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + skip_nomsg => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..1', + tests_planned => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => TRUE, + has_todo => FALSE, + number => 1, + description => "", + explanation => '', + }, + ], + plan => '1..1', + passed => [1], + actual_passed => [1], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [1], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 1, + tests_run => TRUE, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + todo_inline => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..3', + tests_planned => 3, + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 1, + description => "- Foo", + explanation => 'Just testing the todo interface.', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 2, + description => "- Unexpected success", + explanation => 'Just testing the todo interface.', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "- This is not todo", + explanation => '', + }, + ], + plan => '1..3', + passed => [ 1, 2, 3 ], + actual_passed => [ 2, 3 ], + failed => [], + actual_failed => [1], + todo => [ 1, 2 ], + todo_passed => [2], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 3, + tests_run => 3, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + todo => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..5 todo 3 2;', + tests_planned => 5, + todo_list => [ 3, 2 ], + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 2, + description => "", + explanation => '', + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 3, + description => "", + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + explanation => '', + }, + ], + plan => '1..5', + passed => [ 1, 2, 3, 4, 5 ], + actual_passed => [ 1, 2, 4, 5 ], + failed => [], + actual_failed => [3], + todo => [ 2, 3 ], + todo_passed => [2], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + duplicates => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..10', + tests_planned => 10, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 6, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 7, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 8, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 9, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 10, + description => '', + explanation => '', + is_unplanned => TRUE, + }, + ], + plan => '1..10', + passed => [ 1 .. 4, 4 .. 9 ], + actual_passed => [ 1 .. 4, 4 .. 10 ], + failed => [10], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => 10, + tests_run => 11, + parse_errors => [ + 'Tests out of sequence. Found (4) but expected (5)', + 'Tests out of sequence. Found (5) but expected (6)', + 'Tests out of sequence. Found (6) but expected (7)', + 'Tests out of sequence. Found (7) but expected (8)', + 'Tests out of sequence. Found (8) but expected (9)', + 'Tests out of sequence. Found (9) but expected (10)', + 'Tests out of sequence. Found (10) but expected (11)', + 'Bad plan. You planned 10 tests but ran 11.', + ], + 'exit' => 0, + wait => 0, + }, + no_nums => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..5', + tests_planned => 5, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + } + ], + plan => '1..5', + passed => [ 1, 2, 4, 5 ], + actual_passed => [ 1, 2, 4, 5 ], + failed => [3], + actual_failed => [3], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + bailout => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..5', + tests_planned => 5, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { is_bailout => TRUE, + explanation => "GERONIMMMOOOOOO!!!", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + } + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + no_output => { + results => [], + plan => '', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => undef, + tests_run => 0, + parse_errors => [ 'No plan found in TAP output', ], + 'exit' => 0, + wait => 0, + }, + too_many => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..3', + tests_planned => 3, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + is_unplanned => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + is_unplanned => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 6, + description => "", + is_unplanned => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 7, + description => "", + is_unplanned => TRUE, + }, + ], + plan => '1..3', + passed => [ 1 .. 3 ], + actual_passed => [ 1 .. 7 ], + failed => [ 4 .. 7 ], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => 3, + tests_run => 7, + parse_errors => ['Bad plan. You planned 3 tests but ran 7.'], + 'exit' => 4, + wait => NOT_ZERO, + skip_if => sub {$IsVMS}, + }, + taint => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..1', + tests_planned => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "- -T honored", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + }, + ], + plan => '1..1', + passed => [ 1 .. 1 ], + actual_passed => [ 1 .. 1 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => TRUE, + tests_run => TRUE, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + 'die' => { + results => [], + plan => '', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => undef, + tests_run => 0, + parse_errors => [ 'No plan found in TAP output', ], + 'exit' => NOT_ZERO, + wait => NOT_ZERO, + }, + die_head_end => { + results => [ + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + ], + plan => '', + passed => [ 1 .. 4 ], + actual_passed => [ 1 .. 4 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => undef, + tests_run => 4, + parse_errors => [ 'No plan found in TAP output', ], + 'exit' => NOT_ZERO, + wait => NOT_ZERO, + }, + die_last_minute => { + results => [ + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..4', + tests_planned => 4, + }, + ], + plan => '1..4', + passed => [ 1 .. 4 ], + actual_passed => [ 1 .. 4 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 4, + tests_run => 4, + parse_errors => [], + 'exit' => NOT_ZERO, + wait => NOT_ZERO, + }, + bignum => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..2', + tests_planned => 2, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 136211425, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 136211426, + description => '', + explanation => '', + }, + ], + plan => '1..2', + passed => [ 1, 2 ], + actual_passed => [ 1, 2, 136211425, 136211426 ], + failed => [ 136211425, 136211426 ], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => 2, + tests_run => 4, + parse_errors => [ + 'Tests out of sequence. Found (136211425) but expected (3)', + 'Tests out of sequence. Found (136211426) but expected (4)', + 'Bad plan. You planned 2 tests but ran 4.' + ], + 'exit' => 0, + wait => 0, + }, + bignum_many => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..2', + tests_planned => 2, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 99997, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 99998, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 99999, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100000, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100001, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100002, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100003, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100004, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100005, + description => '', + explanation => '', + }, + ], + plan => '1..2', + passed => [ 1, 2 ], + actual_passed => [ 1, 2, 99997 .. 100005 ], + failed => [ 99997 .. 100005 ], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => 2, + tests_run => 11, + parse_errors => [ + 'Tests out of sequence. Found (99997) but expected (3)', + 'Tests out of sequence. Found (99998) but expected (4)', + 'Tests out of sequence. Found (99999) but expected (5)', + 'Tests out of sequence. Found (100000) but expected (6)', + 'Tests out of sequence. Found (100001) but expected (7)', + 'Tests out of sequence. Found (100002) but expected (8)', + 'Tests out of sequence. Found (100003) but expected (9)', + 'Tests out of sequence. Found (100004) but expected (10)', + 'Tests out of sequence. Found (100005) but expected (11)', + 'Bad plan. You planned 2 tests but ran 11.' + ], + 'exit' => 0, + wait => 0, + }, + combined => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..10', + tests_planned => 10, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => 'basset hounds got long ears', + explanation => '', + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => 'all hell broke loose', + explanation => '', + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 4, + description => '', + explanation => 'if I heard a voice from heaven ...', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => 'say "live without loving",', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 6, + description => "I'd beg off.", + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => '1', + has_todo => FALSE, + number => 7, + description => '', + explanation => 'contract negotiations', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 8, + description => 'Girls are such exquisite hell', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 9, + description => 'Elegy 9B', + explanation => '', + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 10, + description => '', + explanation => '', + }, + ], + plan => '1..10', + passed => [ 1 .. 2, 4 .. 9 ], + actual_passed => [ 1 .. 2, 5 .. 9 ], + failed => [ 3, 10 ], + actual_failed => [ 3, 4, 10 ], + todo => [ 4, 9 ], + todo_passed => [9], + skipped => [7], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 10, + tests_run => 10, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + head_end => { + results => [ + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comments', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comment', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..4', + tests_planned => 4, + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'more ignored stuff', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'and yet more', + }, + ], + plan => '1..4', + passed => [ 1 .. 4 ], + actual_passed => [ 1 .. 4 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 4, + tests_run => 4, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + head_fail => { + results => [ + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comments', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comment', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..4', + tests_planned => 4, + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'more ignored stuff', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'and yet more', + }, + ], + plan => '1..4', + passed => [ 1, 3, 4 ], + actual_passed => [ 1, 3, 4 ], + failed => [2], + actual_failed => [2], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 4, + tests_run => 4, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + out_of_order => { + results => [ + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '- Test that argument passing works', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => + '- Test that passing arguments as references work', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '- Test a normal sub', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 6, + description => '- Detach test', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 8, + description => '- Nested thread test', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 9, + description => '- Nested thread test', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 10, + description => '- Wanted 7, got 7', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 11, + description => '- Wanted 7, got 7', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 12, + description => '- Wanted 8, got 8', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 13, + description => '- Wanted 8, got 8', + explanation => '', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..15', + tests_planned => 15, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => '- Check that Config::threads is true', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 7, + description => '- Detach test', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 14, + description => + '- Check so that tid for threads work for main thread', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 15, + description => + '- Check so that tid for threads work for main thread', + explanation => '', + }, + ], + plan => '1..15', + passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ], + actual_passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + is_good_plan => FALSE, + tests_planned => 15, + tests_run => 15, + + # Note that tests 14 and 15 *are* in the correct sequence. + parse_errors => [ + 'Tests out of sequence. Found (2) but expected (1)', + 'Tests out of sequence. Found (3) but expected (2)', + 'Tests out of sequence. Found (4) but expected (3)', + 'Tests out of sequence. Found (6) but expected (4)', + 'Tests out of sequence. Found (8) but expected (5)', + 'Tests out of sequence. Found (9) but expected (6)', + 'Tests out of sequence. Found (10) but expected (7)', + 'Tests out of sequence. Found (11) but expected (8)', + 'Tests out of sequence. Found (12) but expected (9)', + 'Tests out of sequence. Found (13) but expected (10)', + 'Plan (1..15) must be at the beginning or end of the TAP output', + 'Tests out of sequence. Found (1) but expected (11)', + 'Tests out of sequence. Found (5) but expected (12)', + 'Tests out of sequence. Found (7) but expected (13)', + ], + 'exit' => 0, + wait => 0, + }, + skipall => { + results => [ + { is_plan => TRUE, + raw => '1..0 # skipping: rope', + tests_planned => 0, + passed => TRUE, + is_ok => TRUE, + directive => 'SKIP', + explanation => 'rope' + }, + ], + plan => '1..0', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 0, + tests_run => 0, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + skip_all => 'rope', + }, + skipall_v13 => { + results => [ + { is_version => TRUE, + raw => 'TAP version 13', + }, + { is_unknown => TRUE, + raw => '1..0 # skipping: rope', + }, + ], + plan => '', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + is_good_plan => FALSE, + tests_planned => FALSE, + tests_run => 0, + parse_errors => ['No plan found in TAP output'], + 'exit' => 0, + wait => 0, + version => 13, + }, + skipall_nomsg => { + results => [ + { is_plan => TRUE, + raw => '1..0', + tests_planned => 0, + passed => TRUE, + is_ok => TRUE, + directive => 'SKIP', + explanation => '' + }, + ], + plan => '1..0', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 0, + tests_run => 0, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + skip_all => '(no reason given)', + }, + todo_misparse => { + results => [ + { is_plan => TRUE, + raw => '1..1', + tests_planned => TRUE, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => 'Hamlette # TODOORNOTTODO', + explanation => '', + }, + ], + plan => '1..1', + passed => [], + actual_passed => [], + failed => [1], + actual_failed => [1], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => TRUE, + tests_run => 1, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + shbang_misparse => { + results => [ + { is_plan => TRUE, + raw => '1..2', + tests_planned => 2, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + ], + plan => '1..2', + passed => [ 1 .. 2 ], + actual_passed => [ 1 .. 2 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 2, + tests_run => 2, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + switches => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..1', + tests_planned => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + explanation => '', + }, + ], + __ARGS__ => { switches => ['-Mstrict'] }, + plan => '1..1', + passed => [1], + actual_passed => [1], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 1, + tests_run => TRUE, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + inc_taint => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..1', + tests_planned => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + explanation => '', + }, + ], + __ARGS__ => { switches => ['-Iexamples'] }, + plan => '1..1', + passed => [1], + actual_passed => [1], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 1, + tests_run => TRUE, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + sequence_misparse => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "\# skipped on foobar system", + }, + { is_comment => TRUE, + comment => '1234567890123456789012345678901234567890', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { is_comment => TRUE, + comment => '1234567890123456789012345678901234567890', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + + stdout_stderr => { + results => [ + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comments', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comment', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'more ignored stuff', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'and yet more', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..4', + tests_planned => 4, + }, + ], + plan => '1..4', + passed => [ 1 .. 4 ], + actual_passed => [ 1 .. 4 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 4, + tests_run => 4, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + need_open3 => 1, + }, + + junk_before_plan => { + results => [ + { is_unknown => TRUE, + raw => 'this is junk', + }, + { is_comment => TRUE, + comment => "this is a comment", + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..1', + tests_planned => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + }, + ], + plan => '1..1', + passed => [ 1 .. 1 ], + actual_passed => [ 1 .. 1 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 1, + tests_run => 1, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + version_good => { + results => [ + { is_version => TRUE, + raw => 'TAP version 13', + }, + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 13, + }, + version_old => { + results => [ + { is_version => TRUE, + raw => 'TAP version 12', + }, + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => + ['Explicit TAP version must be at least 13. Got version 12'], + 'exit' => 0, + wait => 0, + version => 12, + }, + version_late => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { is_version => TRUE, + raw => 'TAP version 13', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => + ['If TAP version is present it must be the first line of output'], + 'exit' => 0, + wait => 0, + version => 12, + }, + + escape_eol => { + results => [ + { is_plan => TRUE, + raw => '1..2', + tests_planned => 2, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => + 'Should parse as literal backslash --> \\', + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => 'Not a continuation line', + is_unplanned => FALSE, + }, + ], + plan => '1..2', + passed => [ 1 .. 2 ], + actual_passed => [ 1 .. 2 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 2, + tests_run => 2, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + + escape_hash => { + results => [ + { is_plan => TRUE, + raw => '1..3', + tests_planned => 3, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => 'Not a \\# TODO', + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => 'Not a \\# SKIP', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => 'Escaped \\\\\\#', + is_unplanned => FALSE, + }, + ], + plan => '1..3', + passed => [ 1 .. 3 ], + actual_passed => [ 1 .. 3 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 3, + tests_run => 3, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, +); + +my %HANDLER_FOR = ( + NOT_ZERO, sub { local $^W; 0 != shift }, + TRUE, sub { local $^W; !!shift }, + FALSE, sub { local $^W; !shift }, +); + +my $can_open3 = ( $Config{d_fork} || $IsWin32 ) ? 1 : 0; + +for my $hide_fork ( 0 .. $can_open3 ) { + if ($hide_fork) { + no strict 'refs'; + local $^W = 0; + *{'TAP::Parser::Iterator::Process::_use_open3'} = sub {return}; + } + + TEST: + for my $test ( sort keys %samples ) { + + #next unless 'empty' eq $test; + my %details = %{ $samples{$test} }; + + if ( my $skip_if = delete $details{skip_if} ) { + next TEST if $skip_if->(); + } + + my $results = delete $details{results}; + my $args = delete $details{__ARGS__}; + my $need_open3 = delete $details{need_open3}; + + next TEST if $need_open3 && ( $hide_fork || !$can_open3 ); + + # the following acrobatics are necessary to make it easy for the + # Test::Builder::failure_output() method to be overridden when + # TAP::Parser is not installed. Otherwise, these tests will fail. + unshift @{ $args->{switches} }, '-It/lib'; + + $args->{source} = File::Spec->catfile( $SAMPLE_TESTS, $test ); + $args->{merge} = !$hide_fork; + + my $parser = eval { analyze_test( $test, [@$results], $args ) }; + my $error = $@; + ok !$error, "'$test' should parse successfully" or diag $error; + + if ($error) { + my $tests = 0; + while ( my ( $method, $answer ) = each %details ) { + $tests += ref $answer ? 2 : 1; + } + SKIP: { + skip "$test did not parse successfully", $tests; + } + } + else { + while ( my ( $method, $answer ) = each %details ) { + if ( my $handler = $HANDLER_FOR{ $answer || '' } ) { # yuck + ok $handler->( $parser->$method() ), + "... and $method should return a reasonable value ($test)"; + } + elsif ( !ref $answer ) { + local $^W; # uninit warnings + + $answer = _vmsify_answer( $method, $answer ); + + is $parser->$method(), $answer, + "... and $method should equal $answer ($test)"; + } + else { + is scalar $parser->$method(), scalar @$answer, + "... and $method should be the correct amount ($test)"; + is_deeply [ $parser->$method() ], $answer, + "... and $method should be the correct values ($test)"; + } + } + } + } +} + +my %Unix2VMS_Exit_Codes = ( + 1 => 4, +); + +sub _vmsify_answer { + my ( $method, $answer ) = @_; + + return $answer unless $IsVMS; + + if ( $method eq 'exit' + and exists $Unix2VMS_Exit_Codes{$answer} ) + { + $answer = $Unix2VMS_Exit_Codes{$answer}; + } + + return $answer; +} + +sub analyze_test { + my ( $test, $results, $args ) = @_; + + my $parser = TAP::Parser->new($args); + my $count = 1; + while ( defined( my $result = $parser->next ) ) { + + my $expected = shift @$results; + my $desc + = $result->is_test + ? $result->description + : $result->raw; + $desc = $result->plan if $result->is_plan && $desc =~ /SKIP/i; + $desc =~ s/#/<hash>/g; + $desc =~ s/\s+/ /g; # Drop newlines + ok defined $expected, + "$test/$count We should have a result for $desc"; + while ( my ( $method, $answer ) = each %$expected ) { + + if ( my $handler = $HANDLER_FOR{ $answer || '' } ) { # yuck + ok $handler->( $result->$method() ), + "... and $method should return a reasonable value ($test/$count)"; + } + elsif ( ref $answer ) { + is_deeply $result->$method(), $answer, + "... and $method should return the correct structure ($test/$count)"; + } + else { + is $result->$method(), $answer, + "... and $method should return the correct answer ($test/$count)"; + } + } + $count++; + } + is @$results, 0, + "... and we should have the correct number of results ($test)"; + return $parser; +} + +# vms_nit diff --git a/lib/Test/Harness/t/results.t b/lib/Test/Harness/t/results.t new file mode 100644 index 0000000000..431bb7dc71 --- /dev/null +++ b/lib/Test/Harness/t/results.t @@ -0,0 +1,272 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 222; + +use TAP::Parser::Result; + +use constant RESULT => 'TAP::Parser::Result'; +use constant PLAN => 'TAP::Parser::Result::Plan'; +use constant TEST => 'TAP::Parser::Result::Test'; +use constant COMMENT => 'TAP::Parser::Result::Comment'; +use constant BAILOUT => 'TAP::Parser::Result::Bailout'; +use constant UNKNOWN => 'TAP::Parser::Result::Unknown'; + +my $warning; +$SIG{__WARN__} = sub { $warning = shift }; + +# +# Note that the are basic unit tests. More comprehensive path coverage is +# found in the regression tests. +# + +my %inherited_methods = ( + is_plan => '', + is_test => '', + is_comment => '', + is_bailout => '', + is_unknown => '', + is_ok => 1, +); + +my $abstract_class = bless { type => 'no_such_type' }, + RESULT; # you didn't see this +run_method_tests( $abstract_class, {} ); # check the defaults + +can_ok $abstract_class, 'type'; +is $abstract_class->type, 'no_such_type', + '... and &type should return the correct result'; + +can_ok $abstract_class, 'passed'; +$warning = ''; +ok $abstract_class->passed, '... and it should default to true'; +like $warning, qr/^\Qpassed() is deprecated. Please use "is_ok()"/, + '... but it should emit a deprecation warning'; + +can_ok RESULT, 'new'; +eval { RESULT->new( { type => 'no_such_type' } ) }; +ok my $error = $@, '... and calling it with an unknown class should fail'; +like $error, qr/^Could not determine class for.*no_such_type/s, + '... with an appropriate error message'; + +# +# test unknown tokens +# + +run_tests( + { class => UNKNOWN, + data => { + type => 'unknown', + raw => '... this line is junk ... ', + }, + }, + { is_unknown => 1, + raw => '... this line is junk ... ', + as_string => '... this line is junk ... ', + type => 'unknown', + has_directive => '', + } +); + +# +# test comment tokens +# + +run_tests( + { class => COMMENT, + data => { + type => 'comment', + raw => '# this is a comment', + comment => 'this is a comment', + }, + }, + { is_comment => 1, + raw => '# this is a comment', + as_string => '# this is a comment', + comment => 'this is a comment', + type => 'comment', + has_directive => '', + } +); + +# +# test bailout tokens +# + +run_tests( + { class => BAILOUT, + data => { + type => 'bailout', + raw => 'Bailout! This blows!', + bailout => 'This blows!', + }, + }, + { is_bailout => 1, + raw => 'Bailout! This blows!', + as_string => 'This blows!', + type => 'bailout', + has_directive => '', + } +); + +# +# test plan tokens +# + +run_tests( + { class => PLAN, + data => { + type => 'plan', + raw => '1..20', + tests_planned => 20, + directive => '', + explanation => '', + }, + }, + { is_plan => 1, + raw => '1..20', + tests_planned => 20, + directive => '', + explanation => '', + has_directive => '', + } +); + +run_tests( + { class => PLAN, + data => { + type => 'plan', + raw => '1..0 # SKIP help me, Rhonda!', + tests_planned => 0, + directive => 'SKIP', + explanation => 'help me, Rhonda!', + }, + }, + { is_plan => 1, + raw => '1..0 # SKIP help me, Rhonda!', + tests_planned => 0, + directive => 'SKIP', + explanation => 'help me, Rhonda!', + has_directive => 1, + } +); + +# +# test 'test' tokens +# + +my $test = run_tests( + { class => TEST, + data => { + ok => 'ok', + test_num => 5, + description => '... and this test is fine', + directive => '', + explanation => '', + raw => 'ok 5 and this test is fine', + type => 'test', + }, + }, + { is_test => 1, + type => 'test', + ok => 'ok', + number => 5, + description => '... and this test is fine', + directive => '', + explanation => '', + is_ok => 1, + is_actual_ok => 1, + todo_passed => '', + has_skip => '', + has_todo => '', + as_string => 'ok 5 ... and this test is fine', + is_unplanned => '', + has_directive => '', + } +); + +can_ok $test, 'actual_passed'; +$warning = ''; +is $test->actual_passed, $test->is_actual_ok, + '... and it should return the correct value'; +like $warning, + qr/^\Qactual_passed() is deprecated. Please use "is_actual_ok()"/, + '... but issue a deprecation warning'; + +can_ok $test, 'todo_failed'; +$warning = ''; +is $test->todo_failed, $test->todo_passed, + '... and it should return the correct value'; +like $warning, + qr/^\Qtodo_failed() is deprecated. Please use "todo_passed()"/, + '... but issue a deprecation warning'; + +# TODO directive + +$test = run_tests( + { class => TEST, + data => { + ok => 'not ok', + test_num => 5, + description => '... and this test is fine', + directive => 'TODO', + explanation => 'why not?', + raw => 'not ok 5 and this test is fine # TODO why not?', + type => 'test', + }, + }, + { is_test => 1, + type => 'test', + ok => 'not ok', + number => 5, + description => '... and this test is fine', + directive => 'TODO', + explanation => 'why not?', + is_ok => 1, + is_actual_ok => '', + todo_passed => '', + has_skip => '', + has_todo => 1, + as_string => + 'not ok 5 ... and this test is fine # TODO why not?', + is_unplanned => '', + has_directive => 1, + } +); + +sub run_tests { + my ( $instantiated, $value_for ) = @_; + my $result = instantiate($instantiated); + run_method_tests( $result, $value_for ); + return $result; +} + +sub instantiate { + my $instantiated = shift; + my $class = $instantiated->{class}; + ok my $result = RESULT->new( $instantiated->{data} ), + 'Creating $class results should succeed'; + isa_ok $result, $class, '.. and the object it returns'; + return $result; +} + +sub run_method_tests { + my ( $result, $value_for ) = @_; + while ( my ( $method, $default ) = each %inherited_methods ) { + can_ok $result, $method; + if ( defined( my $value = delete $value_for->{$method} ) ) { + is $result->$method(), $value, + "... and $method should be correct"; + } + else { + is $result->$method(), $default, + "... and $method default should be correct"; + } + } + while ( my ( $method, $value ) = each %$value_for ) { + can_ok $result, $method; + is $result->$method(), $value, "... and $method should be correct"; + } +} diff --git a/lib/Test/Harness/t/source.t b/lib/Test/Harness/t/source.t new file mode 100644 index 0000000000..1f4ae521a7 --- /dev/null +++ b/lib/Test/Harness/t/source.t @@ -0,0 +1,126 @@ +#!/usr/bin/perl -w + +BEGIN { + if ($ENV{PERL_CORE}) { + # FIXME + print "1..0 # Skip pending resolution of how to set the library with -I\n"; + exit 0; + } +} + +use strict; +use lib 't/lib'; + +use Test::More tests => 30; + +use File::Spec; + +use TAP::Parser::Source; +use TAP::Parser::Source::Perl; + +my $test = File::Spec->catfile( $ENV{PERL_CORE} ? 'lib' : 't', 'source_tests', + 'source' ); + +my $perl = $^X; + +can_ok 'TAP::Parser::Source', 'new'; +my $source = TAP::Parser::Source->new; +isa_ok $source, 'TAP::Parser::Source'; + +can_ok $source, 'source'; +eval { $source->source("$perl -It/lib $test") }; +ok my $error = $@, '... and calling it with a string should fail'; +like $error, qr/^Argument to &source must be an array reference/, + '... with an appropriate error message'; +ok $source->source( [ $perl, '-It/lib', '-T', $test ] ), + '... and calling it with valid args should succeed'; + +can_ok $source, 'get_stream'; +my $stream = $source->get_stream; + +isa_ok $stream, 'TAP::Parser::Iterator::Process', + 'get_stream returns the right object'; +can_ok $stream, 'next'; +is $stream->next, '1..1', '... and the first line should be correct'; +is $stream->next, 'ok 1', '... as should the second'; +ok !$stream->next, '... and we should have no more results'; + +can_ok 'TAP::Parser::Source::Perl', 'new'; +$source = TAP::Parser::Source::Perl->new; +isa_ok $source, 'TAP::Parser::Source::Perl', '... and the object it returns'; + +can_ok $source, 'source'; +ok $source->source( [$test] ), + '... and calling it with valid args should succeed'; + +can_ok $source, 'get_stream'; +$stream = $source->get_stream; + +isa_ok $stream, 'TAP::Parser::Iterator::Process', + '... and the object it returns'; +can_ok $stream, 'next'; +is $stream->next, '1..1', '... and the first line should be correct'; +is $stream->next, 'ok 1', '... as should the second'; +ok !$stream->next, '... and we should have no more results'; + +# internals tests! + +can_ok $source, '_switches'; +ok( grep( $_ =~ /^['"]?-T['"]?$/, $source->_switches ), + '... and it should find the taint switch' +); + +# coverage test for TAP::PArser::Source + +{ + + # coverage for method get_steam + + my $source = TAP::Parser::Source->new(); + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $source->get_stream; + }; + + is @die, 1, 'coverage testing of get_stream'; + + like pop @die, qr/No command found!/, '...and it failed as expect'; +} + +{ + + # coverage testing for error + + my $source = TAP::Parser::Source->new(); + + my $error = $source->error; + + is $error, undef, 'coverage testing for error()'; + + $source->error('save me'); + + $error = $source->error; + + is $error, 'save me', '...and we got the expected message'; +} + +{ + + # coverage testing for exit + + my $source = TAP::Parser::Source->new(); + + my $exit = $source->exit; + + is $exit, undef, 'coverage testing for exit()'; + + $source->exit('save me'); + + $exit = $source->exit; + + is $exit, 'save me', '...and we got the expected message'; +} diff --git a/lib/Test/Harness/t/spool.t b/lib/Test/Harness/t/spool.t new file mode 100644 index 0000000000..b7b11b85df --- /dev/null +++ b/lib/Test/Harness/t/spool.t @@ -0,0 +1,144 @@ +#!/usr/bin/perl -w + +BEGIN { + if ($ENV{PERL_CORE}) { + # FIXME + print "1..0 # Skip pending resolution of how to avoid creating a directory t in the core\n"; + exit 0; + } +} + +# test T::H::_open_spool and _close_spool - these are good examples +# of the 'Fragile Test' pattern - messing with I/O primitives breaks +# nearly everything + +use strict; +use lib 't/lib'; + +use Test::More; + +my $useOrigOpen; +my $useOrigClose; + +# setup replacements for core open and close - breaking these makes everything very fragile +BEGIN { + $useOrigOpen = $useOrigClose = 1; + + # taken from http://www.perl.com/pub/a/2002/06/11/threads.html?page=2 + + *CORE::GLOBAL::open = \&my_open; + + sub my_open (*@) { + if ($useOrigOpen) { + if ( defined( $_[0] ) ) { + use Symbol qw(); + my $handle = Symbol::qualify( $_[0], (caller)[0] ); + no strict 'refs'; + if ( @_ == 1 ) { + return CORE::open($handle); + } + elsif ( @_ == 2 ) { + return CORE::open( $handle, $_[1] ); + } + else { + die "Can't open with more than two args"; + } + } + } + else { + return; + } + } + + *CORE::GLOBAL::close = sub (*) { + if ($useOrigClose) { return CORE::close(shift) } + else {return} + }; + +} + +use TAP::Harness; +use TAP::Parser; + +plan tests => 4; + +{ + + # coverage tests for the basically untested T::H::_open_spool + + $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(qw(t spool)); + +# now given that we're going to be writing stuff to the file system, make sure we have +# a cleanup hook + + END { + use File::Path; + + $useOrigOpen = $useOrigClose = 1; + + # remove the tree if we made it this far + rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) + if $ENV{PERL_TEST_HARNESS_DUMP_TAP}; + } + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + # use the broken open + $useOrigOpen = 0; + + TAP::Harness->_open_spool( + File::Spec->catfile(qw (source_tests harness )) ); + + # restore universal sanity + $useOrigOpen = 1; + }; + + is @die, 1, 'open failed, die as expected'; + + my $spoolDir + = quotemeta( File::Spec->catfile(qw( t spool source_tests harness )) ); + + like pop @die, qr/ Can't write $spoolDir [(] /, + '...with expected message'; + + # now make close fail + + use Symbol; + + my $spoolHandle = gensym; + + my $tap = <<'END_TAP'; +1..1 +ok 1 - input file opened + +END_TAP + + my $parser = TAP::Parser->new( + { spool => $spoolHandle, + stream => TAP::Parser::Iterator->new( [ split /\n/ => $tap ] ) + } + ); + + @die = (); + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + # use the broken CORE::close + $useOrigClose = 0; + + TAP::Harness->_close_spool($parser); + + $useOrigClose = 1; + }; + + unless ( is @die, 1, 'close failed, die as expected' ) { + diag " >>> $_ <<<\n" for @die; + } + + like pop @die, qr/ Error closing TAP spool file[(] /, + '...with expected message'; +} diff --git a/lib/Test/Harness/t/state.t b/lib/Test/Harness/t/state.t new file mode 100644 index 0000000000..0963a7e9b0 --- /dev/null +++ b/lib/Test/Harness/t/state.t @@ -0,0 +1,242 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More; +use App::Prove::State; + +my @schedule = ( + + # last => sub { + # failed => sub { + # passed => sub { + # all => sub { + # todo => sub { + # hot => sub { + # save => sub { + # adrian => sub { + { options => 'all', + get_tests_args => [], + expect => [ + 't/compat/env.t', + 't/compat/failure.t', + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/source.t', + 't/yamlish-writer.t', + ], + }, + { options => 'failed', + get_tests_args => [], + expect => [ + 't/compat/inc_taint.t', + 't/compat/version.t', + ], + }, + { options => 'passed', + get_tests_args => [], + expect => [ + 't/compat/env.t', + 't/compat/failure.t', + 't/source.t', + 't/yamlish-writer.t', + ], + }, + { options => 'last', + get_tests_args => [], + expect => [ + 't/compat/env.t', + 't/compat/failure.t', + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/source.t', + ], + }, + { options => 'todo', + get_tests_args => [], + expect => [ + 't/compat/version.t', + 't/compat/failure.t', + ], + + }, + { options => 'hot', + get_tests_args => [], + expect => [ + 't/compat/version.t', + 't/yamlish-writer.t', + 't/compat/env.t', + ], + }, + { options => 'adrian', + get_tests_args => [], + expect => [ + 't/compat/version.t', + 't/yamlish-writer.t', + 't/compat/env.t', + 't/compat/failure.t', + 't/compat/inc_taint.t', + 't/source.t', + ], + }, + { options => 'failed,passed', + get_tests_args => [], + expect => [ + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/compat/env.t', + 't/compat/failure.t', + 't/source.t', + 't/yamlish-writer.t', + ], + }, + { options => [ 'failed', 'passed' ], + get_tests_args => [], + expect => [ + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/compat/env.t', + 't/compat/failure.t', + 't/source.t', + 't/yamlish-writer.t', + ], + }, + { options => 'slow', + get_tests_args => [], + expect => [ + 't/yamlish-writer.t', + 't/compat/env.t', + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/compat/failure.t', + 't/source.t', + ], + }, + { options => 'fast', + get_tests_args => [], + expect => [ + 't/source.t', + 't/compat/failure.t', + 't/compat/version.t', + 't/compat/inc_taint.t', + 't/compat/env.t', + 't/yamlish-writer.t', + ], + }, + { options => 'old', + get_tests_args => [], + expect => [ + 't/compat/env.t', + 't/compat/failure.t', + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/source.t', + 't/yamlish-writer.t', + ], + }, + { options => 'new', + get_tests_args => [], + expect => [ + 't/source.t', + 't/yamlish-writer.t', + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/compat/env.t', + 't/compat/failure.t', + ], + }, +); + +plan tests => @schedule * 2; + +for my $test (@schedule) { + my $state = App::Prove::State->new; + isa_ok $state, 'App::Prove::State'; + + my $desc = $test->{options}; + + # Naughty + $state->{_} = get_state(); + my $options = $test->{options}; + $options = [$options] unless 'ARRAY' eq ref $options; + $state->apply_switch(@$options); + + my @got = $state->get_tests( @{ $test->{get_tests_args} } ); + + unless ( is_deeply \@got, $test->{expect}, "$desc: order OK" ) { + use Data::Dumper; + diag( Dumper( { got => \@got, want => $test->{expect} } ) ); + } +} + +sub get_state { + return { + 'generation' => '51', + 'tests' => { + 't/compat/failure.t' => { + 'last_result' => '0', + 'last_run_time' => '1196371471.57738', + 'last_pass_time' => '1196371471.57738', + 'total_passes' => '48', + 'seq' => '1549', + 'gen' => '51', + 'elapsed' => 0.1230, + 'last_todo' => '1' + }, + 't/yamlish-writer.t' => { + 'last_result' => '0', + 'last_run_time' => '1196371480.5761', + 'last_pass_time' => '1196371480.5761', + 'last_fail_time' => '1196368609', + 'total_passes' => '41', + 'seq' => '1578', + 'gen' => '49', + 'elapsed' => 12.2983, + 'last_todo' => '0' + }, + 't/compat/env.t' => { + 'last_result' => '0', + 'last_run_time' => '1196371471.42967', + 'last_pass_time' => '1196371471.42967', + 'last_fail_time' => '1196368608', + 'total_passes' => '48', + 'seq' => '1548', + 'gen' => '52', + 'elapsed' => 3.1290, + 'last_todo' => '0' + }, + 't/compat/version.t' => { + 'last_result' => '2', + 'last_run_time' => '1196371472.96476', + 'last_pass_time' => '1196371472.96476', + 'last_fail_time' => '1196368609', + 'total_passes' => '47', + 'seq' => '1555', + 'gen' => '51', + 'elapsed' => 0.2363, + 'last_todo' => '4' + }, + 't/compat/inc_taint.t' => { + 'last_result' => '3', + 'last_run_time' => '1196371471.89682', + 'last_pass_time' => '1196371471.89682', + 'total_passes' => '47', + 'seq' => '1551', + 'gen' => '51', + 'elapsed' => 1.6938, + 'last_todo' => '0' + }, + 't/source.t' => { + 'last_result' => '0', + 'last_run_time' => '1196371479.72508', + 'last_pass_time' => '1196371479.72508', + 'total_passes' => '41', + 'seq' => '1570', + 'gen' => '51', + 'elapsed' => 0.0143, + 'last_todo' => '0' + }, + } + }; +} diff --git a/lib/Test/Harness/t/streams.t b/lib/Test/Harness/t/streams.t new file mode 100755 index 0000000000..fba0591b3e --- /dev/null +++ b/lib/Test/Harness/t/streams.t @@ -0,0 +1,169 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 47; + +use TAP::Parser; +use TAP::Parser::Iterator; + +my ( $STREAMED, $ITER ) = ( 'TAP::Parser', 'TAP::Parser::Iterator' ); +my $ITER_FH = "${ITER}::Stream"; +my $ITER_ARRAY = "${ITER}::Array"; + +my $stream = TAP::Parser::Iterator->new( \*DATA ); +isa_ok $stream, 'TAP::Parser::Iterator'; +my $parser = TAP::Parser->new( { stream => $stream } ); +isa_ok $parser, 'TAP::Parser', + '... and creating a streamed parser should succeed'; + +can_ok $parser, '_stream'; +is ref $parser->_stream, $ITER_FH, + '... and it should return the proper iterator'; +can_ok $parser, 'next'; +is $parser->next->as_string, '1..5', + '... and the plan should parse correctly'; +is $parser->next->as_string, 'ok 1 - input file opened', + '... and the first test should parse correctly'; +is $parser->next->as_string, '... this is junk', + '... and junk should parse correctly'; +is $parser->next->as_string, + 'not ok 2 first line of the input valid # TODO some data', + '... and the second test should parse correctly'; +is $parser->next->as_string, '# this is a comment', + '... and comments should parse correctly'; +is $parser->next->as_string, 'ok 3 - read the rest of the file', + '... and the third test should parse correctly'; +is $parser->next->as_string, 'not ok 4 - this is a real failure', + '... and the fourth test should parse correctly'; +is $parser->next->as_string, 'ok 5 # SKIP we have no description', + '... and fifth test should parse correctly'; + +ok !$parser->parse_errors, '... and we should have no parse errors'; + +# plan at end + +my $tap = <<'END_TAP'; +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 # skip we have no description +1..5 +END_TAP + +$stream = $ITER->new( [ split /\n/ => $tap ] ); +ok $parser = TAP::Parser->new( { stream => $stream } ), + 'Now we create a parser with the plan at the end'; +isa_ok $parser->_stream, $ITER_ARRAY, + '... and now we should have an array iterator'; +is $parser->next->as_string, 'ok 1 - input file opened', + '... and the first test should parse correctly'; +is $parser->next->as_string, '... this is junk', + '... and junk should parse correctly'; +is $parser->next->as_string, + 'not ok 2 first line of the input valid # TODO some data', + '... and the second test should parse correctly'; +is $parser->next->as_string, '# this is a comment', + '... and comments should parse correctly'; +is $parser->next->as_string, 'ok 3 - read the rest of the file', + '... and the third test should parse correctly'; +is $parser->next->as_string, 'not ok 4 - this is a real failure', + '... and the fourth test should parse correctly'; +is $parser->next->as_string, 'ok 5 # SKIP we have no description', + '... and fifth test should parse correctly'; +is $parser->next->as_string, '1..5', + '... and the plan should parse correctly'; + +ok !$parser->parse_errors, '... and we should have no parse errors'; + +# misplaced plan (and one-off errors) + +$tap = <<'END_TAP'; +ok 1 - input file opened +1..5 +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 # skip we have no description +END_TAP + +$stream = $ITER->new( [ split /\n/ => $tap ] ); + +ok $parser = TAP::Parser->new( { stream => $stream } ), + 'Now we create a parser with a plan as the second line'; +is $parser->next->as_string, 'ok 1 - input file opened', + '... and the first test should parse correctly'; +is $parser->next->as_string, '1..5', + '... and the plan should parse correctly'; +is $parser->next->as_string, '... this is junk', + '... and junk should parse correctly'; +is $parser->next->as_string, + 'not ok 2 first line of the input valid # TODO some data', + '... and the second test should parse correctly'; +is $parser->next->as_string, '# this is a comment', + '... and comments should parse correctly'; +is $parser->next->as_string, 'ok 3 - read the rest of the file', + '... and the third test should parse correctly'; +is $parser->next->as_string, 'not ok 4 - this is a real failure', + '... and the fourth test should parse correctly'; +is $parser->next->as_string, 'ok 5 # SKIP we have no description', + '... and fifth test should parse correctly'; + +ok $parser->parse_errors, '... and we should have one parse error'; +is + ( $parser->parse_errors )[0], + 'Plan (1..5) must be at the beginning or end of the TAP output', + '... telling us that our plan went awry'; + +$tap = <<'END_TAP'; +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +1..5 +ok 5 # skip we have no description +END_TAP + +$stream = $ITER->new( [ split /\n/ => $tap ] ); + +ok $parser = TAP::Parser->new( { stream => $stream } ), + 'Now we create a parser with the plan as the second to last line'; +is $parser->next->as_string, 'ok 1 - input file opened', + '... and the first test should parse correctly'; +is $parser->next->as_string, '... this is junk', + '... and junk should parse correctly'; +is $parser->next->as_string, + 'not ok 2 first line of the input valid # TODO some data', + '... and the second test should parse correctly'; +is $parser->next->as_string, '# this is a comment', + '... and comments should parse correctly'; +is $parser->next->as_string, 'ok 3 - read the rest of the file', + '... and the third test should parse correctly'; +is $parser->next->as_string, 'not ok 4 - this is a real failure', + '... and the fourth test should parse correctly'; +is $parser->next->as_string, '1..5', + '... and the plan should parse correctly'; +is $parser->next->as_string, 'ok 5 # SKIP we have no description', + '... and fifth test should parse correctly'; + +ok $parser->parse_errors, '... and we should have one parse error'; +is + ( $parser->parse_errors )[0], + 'Plan (1..5) must be at the beginning or end of the TAP output', + '... telling us that our plan went awry'; + +__DATA__ +1..5 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 # skip we have no description diff --git a/lib/Test/Harness/t/taint.t b/lib/Test/Harness/t/taint.t new file mode 100644 index 0000000000..2d3891afc6 --- /dev/null +++ b/lib/Test/Harness/t/taint.t @@ -0,0 +1,76 @@ +#!/usr/bin/perl -w + +BEGIN { + if ($ENV{PERL_CORE}) { + # FIXME + print "1..0 # Skip pending resolution of how to set the library with -I\n"; + exit 0; + } +} + +# Test that options in PERL5LIB and PERL5OPT are propogated to tainted +# tests + +use strict; +use lib 't/lib'; + +use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 3 ) ); + +use Config; +use TAP::Parser; + +sub run_test_file { + my ( $test_template, @args ) = @_; + + my $test_file = 't/temp_test.tmp'; + + open TEST, ">$test_file" or die $!; + printf TEST $test_template, @args; + close TEST; + + my $p = TAP::Parser->new( { source => $test_file } ); + 1 while $p->next; + ok !$p->has_problems; + + unlink $test_file; +} + +{ + local $ENV{PERL5LIB} = join $Config{path_sep}, grep defined, 'wibble', + $ENV{PERL5LIB}; + run_test_file(<<'END'); +#!/usr/bin/perl -T + +use lib 't/lib'; +use Test::More tests => 1; + +is( $INC[1], 'wibble' ) or diag join "\n", @INC; +END +} + +{ + my $perl5lib = $ENV{PERL5LIB}; + local $ENV{PERL5LIB}; + local $ENV{PERLLIB} = join $Config{path_sep}, grep defined, 'wibble', + $perl5lib; + run_test_file(<<'END'); +#!/usr/bin/perl -T + +use lib 't/lib'; +use Test::More tests => 1; + +is( $INC[1], 'wibble' ) or diag join "\n", @INC; +END +} + +{ + local $ENV{PERL5OPT} = '-Mstrict'; + run_test_file(<<'END'); +#!/usr/bin/perl -T + +print "1..1\n"; +print $INC{'strict.pm'} ? "ok 1\n" : "not ok 1\n"; +END +} + +1; diff --git a/lib/Test/Harness/t/testargs.t b/lib/Test/Harness/t/testargs.t new file mode 100644 index 0000000000..76ee9a5bb6 --- /dev/null +++ b/lib/Test/Harness/t/testargs.t @@ -0,0 +1,129 @@ +#!/usr/bin/perl -w + +BEGIN { + chdir 't' and @INC = '../lib' if $ENV{PERL_CORE}; +} + +use strict; +use lib 't/lib'; + +use Test::More tests => 19; +use File::Spec; +use TAP::Parser; +use TAP::Harness; +use App::Prove; + +my $test = File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'), + 'sample-tests', 'echo' ); + +diag( "\n\n", bigness( join ' ', @ARGV ), "\n\n" ) if @ARGV; + +sub echo_ok { + my $options = shift; + my @args = @_; + my $parser = TAP::Parser->new( { %$options, test_args => \@args } ); + my @got = (); + while ( my $result = $parser->next ) { + push @got, $result; + } + my $plan = shift @got; + ok $plan->is_plan; + for (@got) { + is $_->description, shift(@args), + join( ', ', keys %$options ) . ": option passed OK"; + } +} + +for my $args ( [qw( yes no maybe )], [qw( 1 2 3 )] ) { + echo_ok( { source => $test }, @$args ); + echo_ok( { exec => [ $^X, $test ] }, @$args ); +} + +{ + my $harness = TAP::Harness->new( + { verbosity => -9, test_args => [qw( magic hat brigade )] } ); + my $aggregate = $harness->runtests($test); + + is $aggregate->total, 3, "ran the right number of tests"; + is $aggregate->passed, 3, "and they passed"; +} + +package Test::Prove; + +use vars qw(@ISA); +@ISA = 'App::Prove'; + +sub _runtests { + my $self = shift; + push @{ $self->{_log} }, [@_]; + return; +} + +sub get_run_log { + my $self = shift; + return $self->{_log}; +} + +package main; + +{ + my $app = Test::Prove->new; + + $app->process_args( '--norc', $test, '::', 'one', 'two', 'huh' ); + $app->run(); + my $log = $app->get_run_log; + is_deeply $log->[0]->[0]->{test_args}, [ 'one', 'two', 'huh' ], + "prove args match"; +} + +sub bigness { + my $str = join '', @_; + my @cdef = ( + '0000000000000000', '1818181818001800', '6c6c6c0000000000', + '36367f367f363600', '0c3f683e0b7e1800', '60660c1830660600', + '386c6c386d663b00', '0c18300000000000', '0c18303030180c00', + '30180c0c0c183000', '00187e3c7e180000', '0018187e18180000', + '0000000000181830', '0000007e00000000', '0000000000181800', + '00060c1830600000', '3c666e7e76663c00', '1838181818187e00', + '3c66060c18307e00', '3c66061c06663c00', '0c1c3c6c7e0c0c00', + '7e607c0606663c00', '1c30607c66663c00', '7e060c1830303000', + '3c66663c66663c00', '3c66663e060c3800', '0000181800181800', + '0000181800181830', '0c18306030180c00', '00007e007e000000', + '30180c060c183000', '3c660c1818001800', '3c666e6a6e603c00', + '3c66667e66666600', '7c66667c66667c00', '3c66606060663c00', + '786c6666666c7800', '7e60607c60607e00', '7e60607c60606000', + '3c66606e66663c00', '6666667e66666600', '7e18181818187e00', + '3e0c0c0c0c6c3800', '666c7870786c6600', '6060606060607e00', + '63777f6b6b636300', '6666767e6e666600', '3c66666666663c00', + '7c66667c60606000', '3c6666666a6c3600', '7c66667c6c666600', + '3c66603c06663c00', '7e18181818181800', '6666666666663c00', + '66666666663c1800', '63636b6b7f776300', '66663c183c666600', + '6666663c18181800', '7e060c1830607e00', '7c60606060607c00', + '006030180c060000', '3e06060606063e00', '183c664200000000', + '00000000000000ff', '1c36307c30307e00', '00003c063e663e00', + '60607c6666667c00', '00003c6660663c00', '06063e6666663e00', + '00003c667e603c00', '1c30307c30303000', '00003e66663e063c', + '60607c6666666600', '1800381818183c00', '1800381818181870', + '6060666c786c6600', '3818181818183c00', '0000367f6b6b6300', + '00007c6666666600', '00003c6666663c00', '00007c66667c6060', + '00003e66663e0607', '00006c7660606000', '00003e603c067c00', + '30307c3030301c00', '0000666666663e00', '00006666663c1800', + '0000636b6b7f3600', '0000663c183c6600', '00006666663e063c', + '00007e0c18307e00', '0c18187018180c00', '1818180018181800', + '3018180e18183000', '316b460000000000' + ); + my @chars = unpack( 'C*', $str ); + my @out = (); + for my $row ( 0 .. 7 ) { + for my $char (@chars) { + next if $char < 32 || $char > 126; + my $size = scalar(@cdef); + my $byte = hex( substr( $cdef[ $char - 32 ], $row * 2, 2 ) ); + my $bits = sprintf( '%08b', $byte ); + $bits =~ tr/01/ #/; + push @out, $bits; + } + push @out, "\n"; + } + return join '', @out; +} diff --git a/lib/Test/Harness/t/unicode.t b/lib/Test/Harness/t/unicode.t new file mode 100644 index 0000000000..837a053fcc --- /dev/null +++ b/lib/Test/Harness/t/unicode.t @@ -0,0 +1,120 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use Test::More; +use TAP::Parser; + +my @schedule; +my %make_test; + +BEGIN { + plan skip_all => "unicode on Perl < 5.8.0" + unless $] > 5.008; + + eval "use File::Temp"; + plan skip_all => "File::Temp unavailable" + if $@; + + eval "use Encode"; + plan skip_all => "Encode unavailable" + if $@; + + # Subs that take the supplied TAP and turn it into a set of args to + # supply to TAP::Harness->new. The returned hash includes the + # temporary file so that its reference count doesn't go to zero + # until we're finished with it. + %make_test = ( + file => sub { + my $source = shift; + my $tmp = File::Temp->new; + open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n"; + eval 'binmode( $fh, ":utf8" )'; + print $fh join( "\n", @$source ), "\n"; + close $fh; + + open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n"; + eval 'binmode( $taph, ":utf8" )'; + return { + temp => $tmp, + args => { source => $taph }, + }; + }, + script => sub { + my $source = shift; + my $tmp = File::Temp->new; + open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n"; + eval 'binmode( $fh, ":utf8" )'; + print $fh map {"print qq{$_\\n};\n"} @$source; + close $fh; + + open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n"; + return { + temp => $tmp, + args => { exec => [ $^X, "$tmp" ] }, + }; + }, + ); + + @schedule = ( + { name => 'Non-unicode warm up', + source => [ + 'TAP version 13', + '1..1', + 'ok 1 Everything is fine', + ], + expect => [ + { isa => 'TAP::Parser::Result::Version', }, + { isa => 'TAP::Parser::Result::Plan', }, + { isa => 'TAP::Parser::Result::Test', + description => "Everything is fine" + }, + ], + }, + { name => 'Unicode smiley', + source => [ + 'TAP version 13', + '1..1', + + # Funky quoting / eval to avoid errors on older Perls + eval qq{"ok 1 Everything is fine \\x{263a}"}, + ], + expect => [ + { isa => 'TAP::Parser::Result::Version', }, + { isa => 'TAP::Parser::Result::Plan', }, + { isa => 'TAP::Parser::Result::Test', + description => eval qq{"Everything is fine \\x{263a}"} + }, + ], + } + ); + + plan 'no_plan'; +} + +for my $test (@schedule) { + for my $type ( sort keys %make_test ) { + my $name = sprintf( "%s (%s)", $test->{name}, $type ); + my $args = $make_test{$type}->( $test->{source} ); + + my $parser = TAP::Parser->new( $args->{args} ); + isa_ok $parser, 'TAP::Parser'; + my @expect = @{ $test->{expect} }; + while ( my $tok = $parser->next ) { + my $exp = shift @expect; + for my $item ( sort keys %$exp ) { + my $val = $exp->{$item}; + if ( 'isa' eq $item ) { + isa_ok $tok, $val; + } + elsif ( 'CODE' eq ref $val ) { + ok $val->($tok), "$name: assertion for $item"; + } + else { + my $got = $tok->$item(); + is $got, $val, "$name: value for $item matches"; + } + } + } + } +} diff --git a/lib/Test/Harness/t/yamlish-output.t b/lib/Test/Harness/t/yamlish-output.t new file mode 100644 index 0000000000..914d7ea237 --- /dev/null +++ b/lib/Test/Harness/t/yamlish-output.t @@ -0,0 +1,100 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 9; + +use TAP::Parser::YAMLish::Writer; + +my $out = [ + "---", + "bill-to:", + " address:", + " city: \"Royal Oak\"", + " lines: \"458 Walkman Dr.\\nSuite #292\\n\"", + " postal: 48046", + " state: MI", + " family: Dumars", + " given: Chris", + "comments: \"Late afternoon is best. Backup contact is Nancy Billsmer \@ 338-4338\\n\"", + "date: 2001-01-23", + "invoice: 34843", + "product:", + " -", + " description: Basketball", + " price: 450.00", + " quantity: 4", + " sku: BL394D", + " -", + " description: \"Super Hoop\"", + " price: 2392.00", + " quantity: 1", + " sku: BL4438H", + "tax: 251.42", + "total: 4443.52", + "...", +]; + +my $in = { + 'bill-to' => { + 'given' => 'Chris', + 'address' => { + 'city' => 'Royal Oak', + 'postal' => '48046', + 'lines' => "458 Walkman Dr.\nSuite #292\n", + 'state' => 'MI' + }, + 'family' => 'Dumars' + }, + 'invoice' => '34843', + 'date' => '2001-01-23', + 'tax' => '251.42', + 'product' => [ + { 'sku' => 'BL394D', + 'quantity' => '4', + 'price' => '450.00', + 'description' => 'Basketball' + }, + { 'sku' => 'BL4438H', + 'quantity' => '1', + 'price' => '2392.00', + 'description' => 'Super Hoop' + } + ], + 'comments' => + "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", + 'total' => '4443.52' +}; + +my @buf1 = (); +my @buf2 = (); +my $buf3 = ''; + +my @destination = ( + { name => 'Array reference', + destination => \@buf1, + normalise => sub { return \@buf1 }, + }, + { name => 'Closure', + destination => sub { push @buf2, shift }, + normalise => sub { return \@buf2 }, + }, + { name => 'Scalar', + destination => \$buf3, + normalise => sub { + my @ar = split( /\n/, $buf3 ); + return \@ar; + }, + }, +); + +for my $dest (@destination) { + my $name = $dest->{name}; + ok my $yaml = TAP::Parser::YAMLish::Writer->new, "$name: Created"; + isa_ok $yaml, 'TAP::Parser::YAMLish::Writer'; + + $yaml->write( $in, $dest->{destination} ); + my $got = $dest->{normalise}->(); + is_deeply $got, $out, "$name: Result matches"; +} diff --git a/lib/Test/Harness/t/yamlish-writer.t b/lib/Test/Harness/t/yamlish-writer.t new file mode 100644 index 0000000000..207fd5e674 --- /dev/null +++ b/lib/Test/Harness/t/yamlish-writer.t @@ -0,0 +1,266 @@ +#!/usr/bin/perl + +use strict; +use lib 't/lib'; + +use Test::More; + +use TAP::Parser::YAMLish::Reader; +use TAP::Parser::YAMLish::Writer; + +my @SCHEDULE; + +BEGIN { + @SCHEDULE = ( + { name => 'Simple scalar', + in => 1, + out => [ + '--- 1', + '...', + ], + }, + { name => 'Undef', + in => undef, + out => [ + '--- ~', + '...', + ], + }, + { name => 'Unprintable', + in => "\x01\n\t", + out => [ + '--- "\x01\n\t"', + '...', + ], + }, + { name => 'Simple array', + in => [ 1, 2, 3 ], + out => [ + '---', + '- 1', + '- 2', + '- 3', + '...', + ], + }, + { name => 'Empty array', + in => [], + out => [ + '--- []', + '...' + ], + }, + { name => 'Empty hash', + in => {}, + out => [ + '--- {}', + '...' + ], + }, + { name => 'Array, two elements, undef', + in => [ undef, undef ], + out => [ + '---', + '- ~', + '- ~', + '...', + ], + }, + { name => 'Nested array', + in => [ 1, 2, [ 3, 4 ], 5 ], + out => [ + '---', + '- 1', + '- 2', + '-', + ' - 3', + ' - 4', + '- 5', + '...', + ], + }, + { name => 'Nested empty', + in => [ 1, 2, [], 5 ], + out => [ + '---', + '- 1', + '- 2', + '- []', + '- 5', + '...', + ], + }, + { name => 'Simple hash', + in => { one => '1', two => '2', three => '3' }, + out => [ + '---', + 'one: 1', + 'three: 3', + 'two: 2', + '...', + ], + }, + { name => 'Nested hash', + in => { + one => '1', two => '2', + more => { three => '3', four => '4' } + }, + out => [ + '---', + 'more:', + ' four: 4', + ' three: 3', + 'one: 1', + 'two: 2', + '...', + ], + }, + { name => 'Nested empty', + in => { one => '1', two => '2', more => {} }, + out => [ + '---', + 'more: {}', + 'one: 1', + 'two: 2', + '...', + ], + }, + { name => 'Unprintable key', + in => { one => '1', "\x02" => '2', three => '3' }, + out => [ + '---', + '"\x02": 2', + 'one: 1', + 'three: 3', + '...', + ], + }, + { name => 'Empty key', + in => { '' => 'empty' }, + out => [ + '---', + "'': empty", + '...', + ], + }, + { name => 'Empty value', + in => { '' => '' }, + out => [ + '---', + "'': ''", + '...', + ], + }, + { name => 'Complex', + in => { + 'bill-to' => { + 'given' => 'Chris', + 'address' => { + 'city' => 'Royal Oak', + 'postal' => '48046', + 'lines' => "458 Walkman Dr.\nSuite #292\n", + 'state' => 'MI' + }, + 'family' => 'Dumars' + }, + 'invoice' => '34843', + 'date' => '2001-01-23', + 'tax' => '251.42', + 'product' => [ + { 'sku' => 'BL394D', + 'quantity' => '4', + 'price' => '450.00', + 'description' => 'Basketball' + }, + { 'sku' => 'BL4438H', + 'quantity' => '1', + 'price' => '2392.00', + 'description' => 'Super Hoop' + } + ], + 'comments' => + "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", + 'total' => '4443.52' + }, + out => [ + "---", + "bill-to:", + " address:", + " city: \"Royal Oak\"", + " lines: \"458 Walkman Dr.\\nSuite #292\\n\"", + " postal: 48046", + " state: MI", + " family: Dumars", + " given: Chris", + "comments: \"Late afternoon is best. Backup contact is Nancy Billsmer \@ 338-4338\\n\"", + "date: 2001-01-23", + "invoice: 34843", + "product:", + " -", + " description: Basketball", + " price: 450.00", + " quantity: 4", + " sku: BL394D", + " -", + " description: \"Super Hoop\"", + " price: 2392.00", + " quantity: 1", + " sku: BL4438H", + "tax: 251.42", + "total: 4443.52", + "...", + ], + }, + ); + + plan tests => @SCHEDULE * 6; +} + +sub iter { + my $ar = shift; + return sub { + return shift @$ar; + }; +} + +for my $test (@SCHEDULE) { + my $name = $test->{name}; + ok my $yaml = TAP::Parser::YAMLish::Writer->new, "$name: Created"; + isa_ok $yaml, 'TAP::Parser::YAMLish::Writer'; + + my $got = []; + my $writer = sub { push @$got, shift }; + + my $data = $test->{in}; + + eval { $yaml->write( $data, $writer ) }; + + if ( my $err = $test->{error} ) { + unless ( like $@, $err, "$name: Error message" ) { + diag "Error: $@\n"; + } + is_deeply $got, [], "$name: No result"; + pass; + } + else { + my $want = $test->{out}; + unless ( ok !$@, "$name: No error" ) { + diag "Error: $@\n"; + } + unless ( is_deeply $got, $want, "$name: Result matches" ) { + use Data::Dumper; + diag Dumper($got); + diag Dumper($want); + } + + my $yr = TAP::Parser::YAMLish::Reader->new; + + # Now try parsing it + my $reader = sub { shift @$got }; + my $parsed = eval { $yr->read($reader) }; + ok !$@, "$name: no error" or diag "$@"; + + is_deeply $parsed, $data, "$name: Reparse OK"; + } +} + diff --git a/lib/Test/Harness/t/yamlish.t b/lib/Test/Harness/t/yamlish.t new file mode 100644 index 0000000000..3cdaf541df --- /dev/null +++ b/lib/Test/Harness/t/yamlish.t @@ -0,0 +1,513 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More; + +use TAP::Parser::YAMLish::Reader; + +my @SCHEDULE; + +BEGIN { + @SCHEDULE = ( + { name => 'Hello World', + in => [ + '--- Hello, World', + '...', + ], + out => "Hello, World", + }, + { name => 'Hello World 2', + in => [ + '--- \'Hello, \'\'World\'', + '...', + ], + out => "Hello, 'World", + }, + { name => 'Hello World 3', + in => [ + '--- "Hello, World"', + '...', + ], + out => "Hello, World", + }, + { name => 'Hello World 4', + in => [ + '--- "Hello, World"', + '...', + ], + out => "Hello, World", + }, + { name => 'Hello World 4', + in => [ + '--- >', + ' Hello,', + ' World', + '...', + ], + out => "Hello, World\n", + }, + { name => 'Hello World 5', + in => [ + '--- >', + ' Hello,', + ' World', + '...', + ], + error => qr{Missing\s+'[.][.][.]'}, + }, + { name => 'Simple array', + in => [ + '---', + '- 1', + '- 2', + '- 3', + '...', + ], + out => [ '1', '2', '3' ], + }, + { name => 'Mixed array', + in => [ + '---', + '- 1', + '- \'two\'', + '- "three\n"', + '...', + ], + out => [ '1', 'two', "three\n" ], + }, + { name => 'Hash in array', + in => [ + '---', + '- 1', + '- two: 2', + '- 3', + '...', + ], + out => [ '1', { two => '2' }, '3' ], + }, + { name => 'Hash in array 2', + in => [ + '---', + '- 1', + '- two: 2', + ' three: 3', + '- 4', + '...', + ], + out => [ '1', { two => '2', three => '3' }, '4' ], + }, + { name => 'Nested array', + in => [ + '---', + '- one', + '-', + ' - two', + ' -', + ' - three', + ' - four', + '- five', + '...', + ], + out => [ 'one', [ 'two', ['three'], 'four' ], 'five' ], + }, + { name => 'Nested hash', + in => [ + '---', + 'one:', + ' five: 5', + ' two:', + ' four: 4', + ' three: 3', + 'six: 6', + '...', + ], + out => { + one => { two => { three => '3', four => '4' }, five => '5' }, + six => '6' + }, + }, + + { name => 'Original YAML::Tiny test', + in => [ + '---', + 'invoice: 34843', + 'date : 2001-01-23', + 'bill-to:', + ' given : Chris', + ' family : Dumars', + ' address:', + ' lines: |', + ' 458 Walkman Dr.', + ' Suite #292', + ' city : Royal Oak', + ' state : MI', + ' postal : 48046', + 'product:', + ' - sku : BL394D', + ' quantity : 4', + ' description : Basketball', + ' price : 450.00', + ' - sku : BL4438H', + ' quantity : 1', + ' description : Super Hoop', + ' price : 2392.00', + 'tax : 251.42', + 'total: 4443.52', + 'comments: >', + ' Late afternoon is best.', + ' Backup contact is Nancy', + ' Billsmer @ 338-4338', + '...', + ], + out => { + 'bill-to' => { + 'given' => 'Chris', + 'address' => { + 'city' => 'Royal Oak', + 'postal' => '48046', + 'lines' => "458 Walkman Dr.\nSuite #292\n", + 'state' => 'MI' + }, + 'family' => 'Dumars' + }, + 'invoice' => '34843', + 'date' => '2001-01-23', + 'tax' => '251.42', + 'product' => [ + { 'sku' => 'BL394D', + 'quantity' => '4', + 'price' => '450.00', + 'description' => 'Basketball' + }, + { 'sku' => 'BL4438H', + 'quantity' => '1', + 'price' => '2392.00', + 'description' => 'Super Hoop' + } + ], + 'comments' => + "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", + 'total' => '4443.52' + } + }, + + # Tests harvested from YAML::Tiny + { in => ['...'], + name => 'Regression: empty', + error => qr{document\s+header\s+not\s+found} + }, + { in => [ + '# comment', + '...' + ], + name => 'Regression: only_comment', + error => qr{document\s+header\s+not\s+found} + }, + { out => undef, + in => [ + '---', + '...' + ], + name => 'Regression: only_header', + error => qr{Premature\s+end}i, + }, + { out => undef, + in => [ + '---', + '---', + '...' + ], + name => 'Regression: two_header', + error => qr{Unexpected\s+start}i, + }, + { out => undef, + in => [ + '--- ~', + '...' + ], + name => 'Regression: one_undef' + }, + { out => undef, + in => [ + '--- ~', + '...' + ], + name => 'Regression: one_undef2' + }, + { in => [ + '--- ~', + '---', + '...' + ], + name => 'Regression: two_undef', + error => qr{Missing\s+'[.][.][.]'}, + }, + { out => 'foo', + in => [ + '--- foo', + '...' + ], + name => 'Regression: one_scalar', + }, + { out => 'foo', + in => [ + '--- foo', + '...' + ], + name => 'Regression: one_scalar2', + }, + { in => [ + '--- foo', + '--- bar', + '...' + ], + name => 'Regression: two_scalar', + error => qr{Missing\s+'[.][.][.]'}, + }, + { out => ['foo'], + in => [ + '---', + '- foo', + '...' + ], + name => 'Regression: one_list1' + }, + { out => [ + 'foo', + 'bar' + ], + in => [ + '---', + '- foo', + '- bar', + '...' + ], + name => 'Regression: one_list2' + }, + { out => [ + undef, + 'bar' + ], + in => [ + '---', + '- ~', + '- bar', + '...' + ], + name => 'Regression: one_listundef' + }, + { out => { 'foo' => 'bar' }, + in => [ + '---', + 'foo: bar', + '...' + ], + name => 'Regression: one_hash1' + }, + { out => { + 'foo' => 'bar', + 'this' => undef + }, + in => [ + '---', + 'foo: bar', + 'this: ~', + '...' + ], + name => 'Regression: one_hash2' + }, + { out => { + 'foo' => [ + 'bar', + undef, + 'baz' + ] + }, + in => [ + '---', + 'foo:', + ' - bar', + ' - ~', + ' - baz', + '...' + ], + name => 'Regression: array_in_hash' + }, + { out => { + 'bar' => { 'foo' => 'bar' }, + 'foo' => undef + }, + in => [ + '---', + 'foo: ~', + 'bar:', + ' foo: bar', + '...' + ], + name => 'Regression: hash_in_hash' + }, + { out => [ + { 'foo' => undef, + 'this' => 'that' + }, + 'foo', undef, + { 'foo' => 'bar', + 'this' => 'that' + } + ], + in => [ + '---', + '-', + ' foo: ~', + ' this: that', + '- foo', + '- ~', + '-', + ' foo: bar', + ' this: that', + '...' + ], + name => 'Regression: hash_in_array' + }, + { out => ['foo'], + in => [ + '---', + '- \'foo\'', + '...' + ], + name => 'Regression: single_quote1' + }, + { out => [' '], + in => [ + '---', + '- \' \'', + '...' + ], + name => 'Regression: single_spaces' + }, + { out => [''], + in => [ + '---', + '- \'\'', + '...' + ], + name => 'Regression: single_null' + }, + { out => ' ', + in => [ + '--- " "', + '...' + ], + name => 'Regression: only_spaces' + }, + { out => [ + undef, + { 'foo' => 'bar', + 'this' => 'that' + }, + 'baz' + ], + in => [ + '---', + '- ~', + '- foo: bar', + ' this: that', + '- baz', + '...' + ], + name => 'Regression: inline_nested_hash' + }, + { name => "Unprintables", + in => [ + "---", + "- \"\\z\\x01\\x02\\x03\\x04\\x05\\x06\\a\\x08\\t\\n\\v\\f\\r\\x0e\\x0f\"", + "- \"\\x10\\x11\\x12\\x13\\x14\\x15\\x16\\x17\\x18\\x19\\x1a\\e\\x1c\\x1d\\x1e\\x1f\"", + "- \" !\\\"#\$%&'()*+,-./\"", + "- 0123456789:;<=>?", + "- '\@ABCDEFGHIJKLMNO'", + "- 'PQRSTUVWXYZ[\\]^_'", + "- '`abcdefghijklmno'", + "- 'pqrstuvwxyz{|}~\177'", + "- \200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217", + "- \220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237", + "- \240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257", + "- \260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277", + "- \300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317", + "- \320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337", + "- \340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357", + "- \360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377", + "..." + ], + out => [ + "\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17", + "\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37", + " !\"#\$%&'()*+,-./", + "0123456789:;<=>?", + "\@ABCDEFGHIJKLMNO", + "PQRSTUVWXYZ[\\]^_", + "`abcdefghijklmno", + "pqrstuvwxyz{|}~\177", + "\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217", + "\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237", + "\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257", + "\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277", + "\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317", + "\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337", + "\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357", + "\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377" + ], + }, + { name => 'Quoted hash keys', + in => [ + '---', + ' "quoted": Magic!', + ' "\n\t": newline, tab', + '...', + ], + out => { + quoted => 'Magic!', + "\n\t" => 'newline, tab', + }, + }, + ); + + plan tests => @SCHEDULE * 5; +} + +sub iter { + my $ar = shift; + return sub { + return shift @$ar; + }; +} + +for my $test (@SCHEDULE) { + my $name = $test->{name}; + ok my $yaml = TAP::Parser::YAMLish::Reader->new, "$name: Created"; + isa_ok $yaml, 'TAP::Parser::YAMLish::Reader'; + + my $source = join( "\n", @{ $test->{in} } ) . "\n"; + + my $iter = iter( $test->{in} ); + my $got = eval { $yaml->read($iter) }; + + my $raw = $yaml->get_raw; + + if ( my $err = $test->{error} ) { + unless ( like $@, $err, "$name: Error message" ) { + diag "Error: $@\n"; + } + ok !$got, "$name: No result"; + pass; + } + else { + my $want = $test->{out}; + unless ( ok !$@, "$name: No error" ) { + diag "Error: $@\n"; + } + is_deeply $got, $want, "$name: Result matches"; + is $raw, $source, "$name: Captured source matches"; + } +} |