In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8f074d66877960697c1c72433068824e05aa0e9d?hp=f347d3e37893158fcefa9e51712d785eb38aaf0a>
- Log ----------------------------------------------------------------- commit 8f074d66877960697c1c72433068824e05aa0e9d Author: Chad Granum <[email protected]> Date: Thu Dec 11 08:03:57 2014 -0800 Test-Simple Version Bump, 1.301001_084 (RC4) ----------------------------------------------------------------------- Summary of changes: MANIFEST | 3 + cpan/Test-Simple/lib/Test/Builder.pm | 2 +- cpan/Test-Simple/lib/Test/Builder/Module.pm | 2 +- cpan/Test-Simple/lib/Test/Builder/Tester.pm | 2 +- cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm | 2 +- cpan/Test-Simple/lib/Test/CanFork.pm | 24 +- cpan/Test-Simple/lib/Test/CanThread.pm | 35 +- cpan/Test-Simple/lib/Test/More.pm | 43 +- cpan/Test-Simple/lib/Test/Simple.pm | 4 +- cpan/Test-Simple/lib/Test/Stream.pm | 4 +- cpan/Test-Simple/lib/Test/Stream/API.pm | 687 ++++++++++++++++++++++ cpan/Test-Simple/lib/Test/Stream/Context.pm | 77 ++- cpan/Test-Simple/lib/Test/Stream/Event.pm | 2 + cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm | 2 + cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm | 7 + cpan/Test-Simple/lib/Test/Stream/Tester.pm | 38 +- cpan/Test-Simple/lib/Test/Stream/Toolset.pm | 70 ++- cpan/Test-Simple/lib/Test/Tester.pm | 2 +- cpan/Test-Simple/lib/Test/use/ok.pm | 2 +- cpan/Test-Simple/lib/ok.pm | 2 +- cpan/Test-Simple/t/Behavior/CustomOutput.t | 137 +++++ cpan/Test-Simple/t/Legacy/subtest/fork.t | 7 + cpan/Test-Simple/t/Test-Stream-API.t | 331 +++++++++++ 23 files changed, 1362 insertions(+), 123 deletions(-) create mode 100644 cpan/Test-Simple/lib/Test/Stream/API.pm create mode 100644 cpan/Test-Simple/t/Behavior/CustomOutput.t create mode 100644 cpan/Test-Simple/t/Test-Stream-API.t diff --git a/MANIFEST b/MANIFEST index 3291137..5475b16 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2270,6 +2270,7 @@ cpan/Test-Simple/lib/Test/More.pm Test::Simple module cpan/Test-Simple/lib/Test/More/Tools.pm Test::Simple module cpan/Test-Simple/lib/Test/MostlyLike.pm Test::Simple module cpan/Test-Simple/lib/Test/Simple.pm Test::Simple module +cpan/Test-Simple/lib/Test/Stream/API.pm Test::Simple module cpan/Test-Simple/lib/Test/Stream/Architecture.pod Test::Simple module cpan/Test-Simple/lib/Test/Stream/ArrayBase/Meta.pm Test::Simple module cpan/Test-Simple/lib/Test/Stream/ArrayBase.pm Test::Simple module @@ -2314,6 +2315,7 @@ cpan/Test-Simple/t/Behavior/388-threadedsubtest.t Test::Simple test cpan/Test-Simple/t/Behavior/478-cmp_ok_hash.t Test::Simple test cpan/Test-Simple/t/Behavior/490-inherit_exporter.t Test::Simple test cpan/Test-Simple/t/Behavior/cmp_ok_xor.t Test::Simple Test +cpan/Test-Simple/t/Behavior/CustomOutput.t Test::Simple Test cpan/Test-Simple/t/Behavior/encoding_test.t Test::Simple Test cpan/Test-Simple/t/Behavior/fork_new_end.t Test::Simple Test cpan/Test-Simple/t/Behavior/MonkeyPatching_diag.t Test::Simple Test @@ -2482,6 +2484,7 @@ cpan/Test-Simple/t/Test-More-DeepCheck.t Test::Simple Test cpan/Test-Simple/t/Test-More.t Test::Simple Test cpan/Test-Simple/t/Test-MostlyLike.t Test::Simple Test cpan/Test-Simple/t/Test-Simple.t Test::Simple Test +cpan/Test-Simple/t/Test-Stream-API.t Test::Simple Test cpan/Test-Simple/t/Test-Stream-ArrayBase-Meta.t Test::Simple Test cpan/Test-Simple/t/Test-Stream-ArrayBase.t Test::Simple Test cpan/Test-Simple/t/Test-Stream-Carp.t Test::Simple Test diff --git a/cpan/Test-Simple/lib/Test/Builder.pm b/cpan/Test-Simple/lib/Test/Builder.pm index 2955e07..fbd2dbf 100644 --- a/cpan/Test-Simple/lib/Test/Builder.pm +++ b/cpan/Test-Simple/lib/Test/Builder.pm @@ -4,7 +4,7 @@ use 5.008001; use strict; use warnings; -our $VERSION = '1.301001_079'; +our $VERSION = '1.301001_084'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) diff --git a/cpan/Test-Simple/lib/Test/Builder/Module.pm b/cpan/Test-Simple/lib/Test/Builder/Module.pm index d0b3003..11d4ff7 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Module.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Module.pm @@ -8,7 +8,7 @@ use Test::Builder 0.99; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '1.301001_079'; +our $VERSION = '1.301001_084'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester.pm b/cpan/Test-Simple/lib/Test/Builder/Tester.pm index f6711a7..0cd7d23 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester; use strict; -our $VERSION = '1.301001_079'; +our $VERSION = '1.301001_084'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Stream 1.301001 '-internal'; diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm index 98d690b..04cd6af 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester::Color; use strict; -our $VERSION = '1.301001_079'; +our $VERSION = '1.301001_084'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Stream 1.301001 '-internal'; diff --git a/cpan/Test-Simple/lib/Test/CanFork.pm b/cpan/Test-Simple/lib/Test/CanFork.pm index b28a382..c94614c 100644 --- a/cpan/Test-Simple/lib/Test/CanFork.pm +++ b/cpan/Test-Simple/lib/Test/CanFork.pm @@ -9,26 +9,24 @@ my $Can_Fork = $Config{d_fork} and $Config{useithreads} and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/); -if (!$Can_Fork) { - require Test::More; - Test::More::plan(skip_all => "This system cannot fork"); - exit 0; -} - -if ($^O eq 'MSWin32' && $] == 5.010000) { - require Test::More; - Test::More::plan('skip_all' => "5.10 has fork/threading issues that break fork on win32"); - exit 0; -} - sub import { my $class = shift; + + if (!$Can_Fork) { + require Test::More; + Test::More::plan(skip_all => "This system cannot fork"); + } + + if ($^O eq 'MSWin32' && $] == 5.010000) { + require Test::More; + Test::More::plan('skip_all' => "5.10 has fork/threading issues that break fork on win32"); + } + for my $var (@_) { next if $ENV{$var}; require Test::More; Test::More::plan(skip_all => "This forking test will only run when the '$var' environment variable is set."); - exit 0; } } diff --git a/cpan/Test-Simple/lib/Test/CanThread.pm b/cpan/Test-Simple/lib/Test/CanThread.pm index a9d6aeb..5902f84 100644 --- a/cpan/Test-Simple/lib/Test/CanThread.pm +++ b/cpan/Test-Simple/lib/Test/CanThread.pm @@ -4,37 +4,34 @@ use warnings; use Config; -if ($] == 5.010000) { - require Test::More; - Test::More::plan(skip_all => "Threads are broken on 5.10.0"); - exit 0; -} - my $works = 1; $works &&= $] >= 5.008001; $works &&= $Config{'useithreads'}; $works &&= eval { require threads; 'threads'->import; 1 }; -unless ($works) { - require Test::More; - Test::More::plan(skip_all => "Skip no working threads"); - exit 0; -} - -if ($INC{'Devel/Cover.pm'}) { - require Test::More; - Test::More::plan(skip_all => "Devel::Cover does not work with threads yet"); - exit 0; -} - sub import { my $class = shift; + + if ($] == 5.010000) { + require Test::More; + Test::More::plan(skip_all => "Threads are broken on 5.10.0"); + } + + unless ($works) { + require Test::More; + Test::More::plan(skip_all => "Skip no working threads"); + } + + if ($INC{'Devel/Cover.pm'}) { + require Test::More; + Test::More::plan(skip_all => "Devel::Cover does not work with threads yet"); + } + while(my $var = shift(@_)) { next if $ENV{$var}; require Test::More; Test::More::plan(skip_all => "This threaded test will only run when the '$var' environment variable is set."); - exit 0; } unshift @_ => 'threads'; diff --git a/cpan/Test-Simple/lib/Test/More.pm b/cpan/Test-Simple/lib/Test/More.pm index b186cc9..8b55adf 100644 --- a/cpan/Test-Simple/lib/Test/More.pm +++ b/cpan/Test-Simple/lib/Test/More.pm @@ -4,12 +4,12 @@ use 5.008001; use strict; use warnings; -our $VERSION = '1.301001_079'; +our $VERSION = '1.301001_084'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Stream 1.301001 '-internal'; use Test::Stream::Util qw/protect try spoof/; -use Test::Stream::Toolset; +use Test::Stream::Toolset qw/is_tester init_tester context before_import/; use Test::Stream::Subtest qw/subtest/; use Test::Stream::Carp qw/croak carp/; @@ -69,45 +69,6 @@ sub import_extra { 1 }; sub builder { Test::Builder->new } -sub before_import { - my $class = shift; - my ($importer, $list) = @_; - - my $meta = init_tester($importer); - - my $context = context(1); - my $other = []; - my $idx = 0; - - while ($idx <= $#{$list}) { - my $item = $list->[$idx++]; - next unless $item; - - if (defined $item and $item eq 'no_diag') { - Test::Stream->shared->set_no_diag(1); - } - elsif ($item eq 'tests') { - $context->plan($list->[$idx++]); - } - elsif ($item eq 'skip_all') { - $context->plan(0, 'SKIP', $list->[$idx++]); - } - elsif ($item eq 'no_plan') { - $context->plan(0, 'NO PLAN'); - } - elsif ($item eq 'import') { - push @$other => @{$list->[$idx++]}; - } - else { - carp("Unknown option: $item"); - } - } - - @$list = @$other; - - return; -} - sub ok ($;$) { my ($test, $name) = @_; my $ctx = context(); diff --git a/cpan/Test-Simple/lib/Test/Simple.pm b/cpan/Test-Simple/lib/Test/Simple.pm index bf140dc..27ba03e 100644 --- a/cpan/Test-Simple/lib/Test/Simple.pm +++ b/cpan/Test-Simple/lib/Test/Simple.pm @@ -5,10 +5,10 @@ use 5.008001; use strict; use warnings; -our $VERSION = '1.301001_079'; +our $VERSION = '1.301001_084'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) -use Test::Stream 1.301001_079 '-internal'; +use Test::Stream 1.301001_084 '-internal'; use Test::Stream::Toolset; use Test::Stream::Exporter; diff --git a/cpan/Test-Simple/lib/Test/Stream.pm b/cpan/Test-Simple/lib/Test/Stream.pm index 2b47ed7..705e0c3 100644 --- a/cpan/Test-Simple/lib/Test/Stream.pm +++ b/cpan/Test-Simple/lib/Test/Stream.pm @@ -2,7 +2,7 @@ package Test::Stream; use strict; use warnings; -our $VERSION = '1.301001_079'; +our $VERSION = '1.301001_084'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Stream::Context qw/context/; @@ -540,7 +540,7 @@ sub _process_event { my ($self, $e, $cache) = @_; if ($self->[MUNGERS]) { - $_->($self, $e) for @{$self->[MUNGERS]}; + $_->($self, $e, $e->subevents) for @{$self->[MUNGERS]}; } $self->_render_tap($cache) unless $cache->{no_out}; diff --git a/cpan/Test-Simple/lib/Test/Stream/API.pm b/cpan/Test-Simple/lib/Test/Stream/API.pm new file mode 100644 index 0000000..68b1e55 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/API.pm @@ -0,0 +1,687 @@ +package Test::Stream::API; +use strict; +use warnings; + +use Test::Stream::Tester qw/intercept/; +use Test::Stream::Carp qw/croak confess/; +use Test::Stream::Meta qw/is_tester init_tester/; +use Test::Stream qw/cull tap_encoding OUT_STD OUT_ERR OUT_TODO/; + +use Test::Stream::Exporter qw/import exports export_to/; +exports qw{ + listen munge follow_up + enable_forking cull + peek_todo push_todo pop_todo set_todo inspect_todo + is_tester init_tester + is_modern set_modern + context peek_context clear_context set_context + intercept + state_count state_failed state_plan state_ended is_passing + current_stream + + disable_tap enable_tap subtest_tap_instant subtest_tap_delayed tap_encoding + enable_numbers disable_numbers set_tap_outputs get_tap_outputs +}; +Test::Stream::Exporter->cleanup(); + +BEGIN { + require Test::Stream::Context; + Test::Stream::Context->import(qw/context inspect_todo/); + *peek_context = \&Test::Stream::Context::peek; + *clear_context = \&Test::Stream::Context::clear; + *set_context = \&Test::Stream::Context::set; + *push_todo = \&Test::Stream::Context::push_todo; + *pop_todo = \&Test::Stream::Context::pop_todo; + *peek_todo = \&Test::Stream::Context::peek_todo; +} + +sub listen(&) { Test::Stream->shared->listen($_[0]) } +sub munge(&) { Test::Stream->shared->munge($_[0]) } +sub follow_up(&) { Test::Stream->shared->follow_up($_[0]) } +sub enable_forking { Test::Stream->shared->use_fork() } +sub disable_tap { Test::Stream->shared->set_use_tap(0) } +sub enable_tap { Test::Stream->shared->set_use_tap(1) } +sub enable_numbers { Test::Stream->shared->set_use_numbers(1) } +sub disable_numbers { Test::Stream->shared->set_use_numbers(0) } +sub current_stream { Test::Stream->shared() } +sub state_count { Test::Stream->shared->count() } +sub state_failed { Test::Stream->shared->failed() } +sub state_plan { Test::Stream->shared->plan() } +sub state_ended { Test::Stream->shared->ended() } +sub is_passing { Test::Stream->shared->is_passing } + +sub subtest_tap_instant { + Test::Stream->shared->set_subtest_tap_instant(1); + Test::Stream->shared->set_subtest_tap_delayed(0); +} + +sub subtest_tap_delayed { + Test::Stream->shared->set_subtest_tap_instant(0); + Test::Stream->shared->set_subtest_tap_delayed(1); +} + +sub is_modern { + my ($package) = @_; + my $meta = is_tester($package) || croak "'$package' is not a tester package"; + return $meta->modern ? 1 : 0; +} + +sub set_modern { + my $package = shift; + croak "set_modern takes a package and a value" unless @_; + my $value = shift; + my $meta = is_tester($package) || croak "'$package' is not a tester package"; + return $meta->set_modern($value); +} + +sub set_todo { + my ($pkg, $why) = @_; + my $meta = is_tester($pkg) || croak "'$pkg' is not a tester package"; + $meta->set_todo($why); +} + +sub set_tap_outputs { + my %params = @_; + my $encoding = delete $params{encoding} || 'legacy'; + my $std = delete $params{std}; + my $err = delete $params{err}; + my $todo = delete $params{todo}; + + my @bad = keys %params; + croak "set_tap_output does not recognise these keys: " . join ", ", @bad + if @bad; + + my $ioset = Test::Stream->shared->io_sets; + my $enc = $ioset->init_encoding($encoding); + + $enc->[OUT_STD] = $std if $std; + $enc->[OUT_ERR] = $err if $err; + $enc->[OUT_TODO] = $todo if $todo; + + return $enc; +} + +sub get_tap_outputs { + my ($enc) = @_; + my $set = Test::Stream->shared->io_sets->init_encoding($enc || 'legacy'); + return { + encoding => $enc || 'legacy', + std => $set->[0], + err => $set->[1], + todo => $set->[2], + }; +} + +1; + +__END__ + +=head1 NAME + +Test::Stream::API - Single point of access to Test::Stream extendability +features. + +=head1 DESCRIPTION + +There are times where you want to extend or alter the bahvior of a test file or +test suite. This module collects all the features and tools that +L<Test::Stream> offers for such actions. Everything in this file is accessible +in other places, but with less sugar coating. + +=head1 SYNOPSYS + +Nothing is exported by default, you must request it. + + use Test::Stream::API qw/ ... /; + +=head2 MODIFYING EVENTS + + use Test::Stream::API qw/ munge /; + + munge { + my ($stream, $event, @subevents) = @_; + + if($event->isa('Test::Stream::Diag')) { + $event->set_message( "KILROY WAS HERE: " . $event->message ); + } + }; + +=head2 REPLACING TAP WITH ALTERNATIVE OUTPUT + + use Test::Stream::API qw/ disable_tap listen /; + + disable_tap(); + + listen { + my $stream = shift; + my ($event, @subevents) = @_; + + # Tracking results in a db? + my $id = log_event_to_db($e); + log_subevent_to_db($id, $_) for @subevents; + } + +=head2 END OF TEST BEHAVIORS + + use Test::Stream::API qw/ follow_up is_passing /; + + follow_up { + my ($context) = @_; + + if (is_passing()) { + print "KILROY Says the test file passed!\n"; + } + else { + print "KILROY is not happy with you!\n"; + } + }; + +=head2 ENABLING FORKING SUPPORT + + use Test::More; + use Test::Stream::API qw/ enable_forking /; + + enable_forking(); + + # This all just works now! + my $pid = fork(); + if ($pid) { # Parent + ok(1, "From Parent"); + } + else { # child + ok(1, "From Child"); + exit 0; + } + + done_testing; + +B<Note:> Result order between processes is not guarenteed, but the test number +is handled for you meaning you don't need to care. + +Results: + + ok 1 - From Child + ok 2 - From Parent + +Or: + + ok 1 - From Parent + ok 2 - From Child + +=head2 REDIRECTING TAP OUTPUT + +You may omit any arguments to leave a specific handle unchanged. It is not +possible to set a handle to undef or 0 or any other false value. + + use Test::Stream::API qw/ set_tap_outputs /; + + set_tap_outputs( + encoding => 'legacy', # Default, + std => $STD_IO_HANDLE, # equivilent to $TB->output() + err => $ERR_IO_HANDLE, # equivilent to $TB->failure_output() + todo => $TODO_IO_HANDLE, # equivilent to $TB->todo_output() + ); + +B<Note:> Each encoding has independant filehandles. + +=head1 GENERATING EVENTS + +=head2 EASY WAY + +The best way to generate an event is through a L<Test::Stream::Context> +object. All events have a method associated with them on the context object. +The method will be the last part of the evene package name lowercased, for +example L<Test::Stream::Event::Ok> can be issued via C<< $context->ok(...) >>. + + use Test::Stream::API qw/ context /; + my $context = context(); + $context->EVENT_TYPE(...); + +The arguments to the event method are the values for event accessors in order, +excluding the C<context>, C<created>, and C<in_subtest> arguments. For instance +here is how the Ok event is defined: + + package Test::Stream::Event::Ok; + use Test::Stream::Event( + accessors => [qw/real_bool name diag .../], + ... + ); + +This means that the C<< $context->ok >> method takes up to 5 arguments. The +first argument is a boolean true/false, the second is the name of the test, and +the third is an arrayref of diagnostics messages or +L<Test::Stream::Event::Diag> objects. + + $context->ok($bool, $name, [$diag]); + +Here are the main event methods, as well as their standard arguments: + +=over 4 + +=item $context->ok($bool, $name, \@diag) + +Issue an L<Test::Stream::Event::Ok> event. + +=item $context->diag($msg) + +Issue an L<Test::Stream::Event::Diag> event. + +=item $context->note($msg) + +Issue an L<Test::Stream::Event::Note> event. + +=item $context->plan($max, $directive, $reason) + +Issue an L<Test::Stream::Event::Plan> event. C<$max> is the number of expected +tests. C<$directive> is a plan directive such as 'no_plan' or 'skip_all'. +C<$reason> is the reason for the directive (only applicable to skip_all). + +=item $context->bail($reason) + +Issue an L<Test::Stream::Event::Bail> event. + +=back + +=head2 HARD WAY + +This is not recommended, but it demonstrates just how much the context shortcut +methods do for you. + + # First make a context + my $context = Test::Stream::Context->new_from_pairs( + frame => ..., # Where to report errors + stream => ..., # Test::Stream object to use + encoding => ..., # encoding from test package meta-data + in_todo => ..., # Are we in a todo? + todo => ..., # Which todo message should be used? + modern => ..., # Is the test package modern? + pid => ..., # Current PID + skip => ..., # Are we inside a 'skip' state? + provider => ..., # What tool created the context? + ); + + # Make the event + my $ok = Test::Stream::Event::Ok->new_from_pairs( + # Should reflect where the event was produced, NOT WHERE ERRORS ARE REPORTED + created => [__PACKAGE__, __FILE__, __LINE__], + context => $context, # A context is required + in_subtest => 0, + + bool => $bool, + name => $name, + diag => \@diag, + ); + + # Send the event to the stream. + Test::Stream->shared->send($ok); + + +=head1 EXPORTED FUNCTIONS + +All of these are functions. These functions all effect the current-shared +L<Test::Stream> object only. + +=head2 EVENT MANAGEMENT + +These let you install a callback that is triggered for all primary events. The +first argument is the L<Test::Stream> object, the second is the primary +L<Test::Stream::Event>, any additional arguments are subevents. All subevents +are L<Test::Stream::Event> objects which are directly tied to the primary one. +The main example of a subevent is the failure L<Test::Stream::Event::Diag> +object associated with a failed L<Test::Stream::Event::Ok>, events within a +subtest are another example. + +=over 4 + +=item listen { my ($stream, $event, @subevents) = @_; ... } + +Listen callbacks happen just after TAP is rendered (or just after it would be +rendered if TAP is disabled). + +=item munge { my ($stream, $event, @subevents) = @_; ... } + +Muinspect_todonge callbacks happen just before TAP is rendered (or just before +it would be rendered if TAP is disabled). + +=back + +=head2 POST-TEST BEHAVIOR + +=over 4 + +=item follow_up { my ($context) = @_; ... } + +A followup callback allows you to install behavior that happens either when +C<done_testing()> is called, or when the test file completes. + +B<CAVEAT:> If done_testing is not used, the callback will happen in the +C<END {...}> block used by L<Test::Stream> to enact magic at the end of the +test. + +=back + +=head2 CONCURRENCY + +=over 4 + +=item enable_forking() + +Turns forking support on. This turns on a synchronization method that *just +works* when you fork inside a test. This must be turned on prior to any +forking. + +=item cull() + +This can only be called in the main process or thread. This is a way to +manually pull in results from other processes or threads. Typically this +happens automatically, but this allows you to ensure results have been gathered +by a specific point. + +=back + +=head2 CONTROL OVER TAP + +=over 4 + +=item enable_tap() + +Turn TAP on (on by default). + +=item disable_tap() + +Turn TAP off. + +=item enable_numbers() + +Show test numbers when rendering TAP. + +=item disable_numbers() + +Do not show test numbers when rendering TAP. + +=item subtest_tap_instant() + +This is the default way to render subtests: + + # Subtest: a_subtest + ok 1 - pass + 1..1 + ok 1 - a_subtest + +Using this will automatically turn off C<subtest_tap_delayed> + +=item subtest_tap_delayed() + +This is an alternative way to render subtests, this method waits until the +subtest is complete then renders it in a structured way: + + ok 1 - a_subtest { + ok 1 - pass + 1..1 + } + +Using this will automatically turn off C<subtest_tap_instant> + +=item tap_encoding($ENCODING) + +This lets you change the encoding for TAP output. This only effects the current +test package. + +=item set_tap_outputs(encoding => 'legacy', std => $IO, err => $IO, todo => $IO) + +This lets you replace the filehandles used to output TAP for any specific +encoding. All fields are optional, any handles not specified will not be +changed. The C<encoding> parameter defaults to 'legacy'. + +B<Note:> The todo handle is used for failure output inside subtests where the +subtest was started already in todo. + +=item $hashref = get_tap_outputs($encoding) + +'legacy' is used when encoding is not specified. + +Returns a hashref with the output handles: + + { + encoding => $encoding, + std => $STD_HANDLE, + err => $ERR_HANDLE, + todo => $TODO_HANDLE, + } + +B<Note:> The todo handle is used for failure output inside subtests where the +subtest was started already in todo. + +=back + +=head2 TEST PACKAGE METADATA + +=over 4 + +=item $bool = is_modern($package) + +Check if a test package has the 'modern' flag. + +B<Note:> Throws an exception if C<$package> is not already a test package. + +=item set_modern($package, $value) + +Turn on the modern flag for the specified test package. + +B<Note:> Throws an exception if C<$package> is not already a test package. + +=back + +=head2 TODO MANAGEMENT + +=over 4 + +=item push_todo($todo) + +=item $todo = pop_todo() + +=item $todo = peek_todo() + +These can be used to manipulate a global C<todo> state. When a true value is at +the top of the todo stack it will effect any events generated via an +L<Test::Stream::Context> object. Typically all events are generated this way. + +=item set_todo($package, $todo) + +This lets you set the todo state for the specified test package. This will +throw an exception if the package is not a test package. + +=item $todo_hashref = inspect_todo($package) + +=item $todo_hashref = inspect_todo() + +This lets you inspect the TODO state. Optionally you can specify a package to +inspect. The return is a hashref with several keys: + + { + TODO => $TODO_STACK_ARRAYREF, + TB => $TEST_BUILDER_TODO_STATE, + META => $PACKAGE_METADATA_TODO_STATE, + PKG => $package::TODO, + } + +This lets you see what todo states are set where. This is primarily useful when +debugging to see why something is unexpectedly TODO, or when something is not +TODO despite expectations. + +=back + +=head2 TEST PACKAGE MANAGEMENT + +=over 4 + +=item $meta = is_tester($package) + +Check if a package is a tester, if it is the meta-object for the tester is +returned. + +=item $meta = init_tester($package) + +Set the package as a tester and return the meta-object. If the package is +already a tester it will return the existing meta-object. + +=back + +=head2 CONTEXTUAL INFORMATION + +=over 4 + +=item $context = context() + +This will get the correct L<Test::Stream::Context> object. This may be one that +was previously initialized, or it may generate a new one. Read the +L<Test::Stream::Context> documentation for more info. + +=item $stream = current_stream() + +This will return the current L<Test::Stream> Object. L<Test::Stream> objects +typically live on a global stack, the topmost item on the stack is the one that +is normally used. + +=back + +=head2 CAPTURING EVENTS + +=over 4 + +=item $events_arrayref = intercept { ... }; + +Any events generated inside the codeblock will be intercepted and returned. No +events within the block will go to the real L<Test::Stream> instance. + +B<Note:> This comes from the L<Test::Stream::Tester> package which provides +addiitonal tools that are useful for testing/validating events. + +=back + +=head2 TEST STATE + +=over 4 + +=item $num = state_count() + +Check how many tests have been run. + +=item $num = state_failed() + +Check how many tests have failed. + +=item $plan_event = state_plan() + +Check if a plan has been issued, if so the L<Test::Stream::Event::Plan> +instance will be returned. + +=item $bool = state_ended() + +True if the test is complete (after done_testing). + +=item $bool = is_passing() + +Check if the test state is passing. + +=back + +=encoding utf8 + +=head1 SOURCE + +The source code repository for Test::More can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>[email protected]<gt> + +=back + +=head1 AUTHORS + +The following people have all contributed to the Test-More dist (sorted using +VIM's sort function). + +=over 4 + +=item Chad Granum E<lt>[email protected]<gt> + +=item Fergal Daly E<lt>[email protected]>E<gt> + +=item Mark Fowler E<lt>[email protected]<gt> + +=item Michael G Schwern E<lt>[email protected]<gt> + +=item åé³³ + +=back + +=head1 COPYRIGHT + +There has been a lot of code migration between modules, +here are all the original copyrights together: + +=over 4 + +=item Test::Stream + +=item Test::Stream::Tester + +Copyright 2014 Chad Granum E<lt>[email protected]<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::Simple + +=item Test::More + +=item Test::Builder + +Originally authored by Michael G Schwern E<lt>[email protected]<gt> with much +inspiration from Joshua Pritikin's Test module and lots of help from Barrie +Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa +gang. + +Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern +E<lt>[email protected]<gt>, wardrobe by Calvin Klein. + +Copyright 2001-2008 by Michael G Schwern E<lt>[email protected]<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=item Test::use::ok + +To the extent possible under law, åé³³ has waived all copyright and related +or neighboring rights to L<Test-use-ok>. + +This work is published from Taiwan. + +L<http://creativecommons.org/publicdomain/zero/1.0> + +=item Test::Tester + +This module is copyright 2005 Fergal Daly <[email protected]>, some parts +are based on other people's work. + +Under the same license as Perl itself + +See http://www.perl.com/perl/misc/Artistic.html + +=item Test::Builder::Tester + +Copyright Mark Fowler E<lt>[email protected]<gt> 2002, 2004. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=back diff --git a/cpan/Test-Simple/lib/Test/Stream/Context.pm b/cpan/Test-Simple/lib/Test/Stream/Context.pm index 51b89e2..333fe4f 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Context.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Context.pm @@ -15,8 +15,9 @@ use Test::Stream::ArrayBase( accessors => [qw/frame stream encoding in_todo todo modern pid skip diag_todo provider monkeypatch_stash/], ); -use Test::Stream::Exporter qw/import export_to default_exports/; +use Test::Stream::Exporter qw/import export_to default_exports exports/; default_exports qw/context/; +exports qw/inspect_todo/; Test::Stream::Exporter->cleanup(); { @@ -24,6 +25,7 @@ Test::Stream::Exporter->cleanup(); $Test::Builder::Level ||= 1; } +my @TODO; my $CURRENT; sub init { @@ -36,6 +38,10 @@ sub init { sub peek { $CURRENT } sub clear { $CURRENT = undef } +sub push_todo { push @TODO => pop @_ } +sub pop_todo { pop @TODO } +sub peek_todo { @TODO ? $TODO[-1] : undef } + sub set { $CURRENT = pop; weaken($CURRENT); @@ -68,7 +74,11 @@ sub context { my $todo_pkg = $meta->[Test::Stream::Meta::PACKAGE]; no strict 'refs'; no warnings 'once'; - if ($todo = $meta->[Test::Stream::Meta::TODO]) { + if (@TODO) { + $todo = $TODO[-1]; + $in_todo = 1; + } + elsif ($todo = $meta->[Test::Stream::Meta::TODO]) { $in_todo = 1; } elsif ($todo = ${"$pkg\::TODO"}) { @@ -341,23 +351,35 @@ sub register_event { sub meta { is_tester($_[0]->[FRAME]->[0]) } +sub inspect_todo { + my ($pkg) = @_; + my $meta = $pkg ? is_tester($pkg) : undef; + + no strict 'refs'; + return { + TODO => [@TODO], + $Test::Builder::Test ? (TB => $Test::Builder::Test->{Todo}) : (), + $meta ? (META => $meta->[Test::Stream::Meta::TODO]) : (), + $pkg ? (PKG => ${"$pkg\::TODO"}) : (), + }; +} + sub hide_todo { my $self = shift; - no strict 'refs'; - no warnings 'once'; my $pkg = $self->[FRAME]->[0]; my $meta = is_tester($pkg); - my $found = { - TB => $Test::Builder::Test ? $Test::Builder::Test->{Todo} : undef, - META => $meta->[Test::Stream::Meta::TODO], - PKG => ${"$pkg\::TODO"}, - }; + my $found = inspect_todo($pkg); + @TODO = (); $Test::Builder::Test->{Todo} = undef; $meta->[Test::Stream::Meta::TODO] = undef; - ${"$pkg\::TODO"} = undef; + { + no strict 'refs'; + no warnings 'once'; + ${"$pkg\::TODO"} = undef; + } return $found; } @@ -365,26 +387,25 @@ sub hide_todo { sub restore_todo { my $self = shift; my ($found) = @_; - no strict 'refs'; - no warnings 'once'; my $pkg = $self->[FRAME]->[0]; my $meta = is_tester($pkg); + @TODO = @{$found->{TODO}}; $Test::Builder::Test->{Todo} = $found->{TB}; $meta->[Test::Stream::Meta::TODO] = $found->{META}; - ${"$pkg\::TODO"} = $found->{PKG}; + { + no strict 'refs'; + no warnings 'once'; + ${"$pkg\::TODO"} = $found->{PKG}; + } - my $found2 = { - TB => $Test::Builder::Test ? $Test::Builder::Test->{Todo} : undef, - META => $meta->[Test::Stream::Meta::TODO] || undef, - PKG => ${"$pkg\::TODO"} || undef, - }; + my $found2 = inspect_todo($pkg); for my $k (qw/TB META PKG/) { no warnings 'uninitialized'; next if "$found->{$k}" eq "$found2->{$k}"; - die "Mismatch! $k:\t$found->{$k}\n\t$found2->{$k}\n" + die "INTERNAL ERROR: Mismatch! $k:\t$found->{$k}\n\t$found2->{$k}\n" } return; @@ -543,6 +564,24 @@ be found. The returned C<$stash> must be used to restore it later. =back +=head2 CLASS METHODS + +B<Note:> These can effect all test packages, if that is not what you want do not use them!. + +=over 4 + +=item $msg = Test::Stream::Context->push_todo($msg) + +=item $msg = Test::Stream::Context->pop_todo() + +=item $msg = Test::Stream::Context->peek_todo() + +These manage a global todo stack. Any new context created will check here first +for a TODO. Changing this will not effect any existing context instances. This +is a reliable way to set a global todo that effects any/all packages. + +=back + =encoding utf8 =head1 SOURCE diff --git a/cpan/Test-Simple/lib/Test/Stream/Event.pm b/cpan/Test-Simple/lib/Test/Stream/Event.pm index 0e35225..e814205 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Event.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Event.pm @@ -74,6 +74,8 @@ sub summary { ); } +sub subevents { } + 1; __END__ diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm index 9b1be21..bfc614b 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm @@ -139,6 +139,8 @@ sub add_diag { } } +sub subevents { @{$_[0]->[DIAG] || []} } + sub to_legacy { my $self = shift; diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm index ec54743..4557796 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm @@ -11,6 +11,13 @@ use Test::Stream::Event( accessors => [qw/state events exception/], ); +sub subevents { + return ( + @{$_[0]->[DIAG] || []}, + map { $_, $_->subevents } @{$_[0]->[EVENTS] || []}, + ); +} + sub init { my $self = shift; diff --git a/cpan/Test-Simple/lib/Test/Stream/Tester.pm b/cpan/Test-Simple/lib/Test/Stream/Tester.pm index 80e45bd..91e9781 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Tester.pm @@ -261,7 +261,7 @@ your tools! =item $events = intercept(sub { ... }) -Capture the L<Test::Builder::Event> objects generated by tests inside the block. +Capture the L<Test::Stream::Event> objects generated by tests inside the block. =item events_are(\@events, $check) @@ -370,23 +370,23 @@ the C<$events> array reference. =head2 EVENT TYPES -All events will be subclasses of L<Test::Builder::Event> +All events will be subclasses of L<Test::Stream::Event> =over 4 -=item L<Test::Builder::Event::Ok> +=item L<Test::Stream::Event::Ok> -=item L<Test::Builder::Event::Note> +=item L<Test::Stream::Event::Note> -=item L<Test::Builder::Event::Diag> +=item L<Test::Stream::Event::Diag> -=item L<Test::Builder::Event::Plan> +=item L<Test::Stream::Event::Plan> -=item L<Test::Builder::Event::Finish> +=item L<Test::Stream::Event::Finish> -=item L<Test::Builder::Event::Bail> +=item L<Test::Stream::Event::Bail> -=item L<Test::Builder::Event::Subtest> +=item L<Test::Stream::Event::Subtest> =back @@ -493,32 +493,32 @@ Specify a sub that will validate the value of the field. =head2 WHAT FIELDS ARE AVAILABLE? This is specific to the event type. All events inherit from -L<Test::Builder::Event> which provides a C<summary()> method. The C<summary()> +L<Test::Stream::Event> which provides a C<summary()> method. The C<summary()> method returns a list of key/value pairs I<(not a reference!)> with all fields that are for public consumption. For each of the following modules see the B<SUMMARY FIELDS> section for a list of fields made available. These fields are inherited when events are subclassed, and all events have the summary fields present in -L<Test::Builder::Event>. +L<Test::Stream::Event>. =over 4 -=item L<Test::Builder::Event/"SUMMARY FIELDS"> +=item L<Test::Stream::Event/"SUMMARY FIELDS"> -=item L<Test::Builder::Event::Ok/"SUMMARY FIELDS"> +=item L<Test::Stream::Event::Ok/"SUMMARY FIELDS"> -=item L<Test::Builder::Event::Note/"SUMMARY FIELDS"> +=item L<Test::Stream::Event::Note/"SUMMARY FIELDS"> -=item L<Test::Builder::Event::Diag/"SUMMARY FIELDS"> +=item L<Test::Stream::Event::Diag/"SUMMARY FIELDS"> -=item L<Test::Builder::Event::Plan/"SUMMARY FIELDS"> +=item L<Test::Stream::Event::Plan/"SUMMARY FIELDS"> -=item L<Test::Builder::Event::Finish/"SUMMARY FIELDS"> +=item L<Test::Stream::Event::Finish/"SUMMARY FIELDS"> -=item L<Test::Builder::Event::Bail/"SUMMARY FIELDS"> +=item L<Test::Stream::Event::Bail/"SUMMARY FIELDS"> -=item L<Test::Builder::Event::Subtest/"SUMMARY FIELDS"> +=item L<Test::Stream::Event::Subtest/"SUMMARY FIELDS"> =back diff --git a/cpan/Test-Simple/lib/Test/Stream/Toolset.pm b/cpan/Test-Simple/lib/Test/Stream/Toolset.pm index 74a66bd..41b4bbe 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Toolset.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Toolset.pm @@ -15,10 +15,51 @@ use Test::Stream::Event::Ok; use Test::Stream::Event::Plan; use Test::Stream::Event::Subtest; -use Test::Stream::Exporter qw/import export_to default_exports/; +use Test::Stream::Exporter qw/import export_to default_exports export/; default_exports qw/is_tester init_tester context/; + +export before_import => sub { + my $class = shift; + my ($importer, $list) = @_; + + my $meta = init_tester($importer); + + my $context = context(1); + my $other = []; + my $idx = 0; + + while ($idx <= $#{$list}) { + my $item = $list->[$idx++]; + next unless $item; + + if (defined $item and $item eq 'no_diag') { + Test::Stream->shared->set_no_diag(1); + } + elsif ($item eq 'tests') { + $context->plan($list->[$idx++]); + } + elsif ($item eq 'skip_all') { + $context->plan(0, 'SKIP', $list->[$idx++]); + } + elsif ($item eq 'no_plan') { + $context->plan(0, 'NO PLAN'); + } + elsif ($item eq 'import') { + push @$other => @{$list->[$idx++]}; + } + else { + carp("Unknown option: $item"); + } + } + + @$list = @$other; + + return; +}; + Test::Stream::Exporter->cleanup(); + 1; =head1 NAME @@ -77,6 +118,25 @@ of integrating with L<Test::Builder> and other testing tools much easier. 1; +=head2 TEST-MORE STYLE IMPORT + +If you want to be able to pass Test-More arguments such as 'tests', 'skip_all', +and 'no_plan', then use the following: + + package My::Tester; + use Test::Stream::Exporter; # Gives us 'import()' + use Test::Stream::Toolset; # default exports + use Test::Stream::Toolset 'before_import' # Test-More style argument support + +2 'use' statements were used above for clarity, you can get all the desired +imports at once: + + use Test::Stream::Toolset qw/context init_tester is_tester before_import/; + +Then in the test: + + use My::Tester tests => 5; + =head1 EXPORTS =over 4 @@ -106,6 +166,14 @@ will return the existing meta object. This method can be used to check if an object is a tester. If the object is a tester it will return the meta object for the tester. +=item before_import + +This method is used by C<import()> to parse Test-More style import arguments. +You should never need to run this yourself, it works just by being imported. + +B<NOTE:> This will only work if you use Test::Stream::Exporter for your +'import' method. + =back =head1 GENERATING EVENTS diff --git a/cpan/Test-Simple/lib/Test/Tester.pm b/cpan/Test-Simple/lib/Test/Tester.pm index 2f36c8f..e758a50 100644 --- a/cpan/Test-Simple/lib/Test/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Tester.pm @@ -16,7 +16,7 @@ require Exporter; use vars qw( @ISA @EXPORT $VERSION ); -our $VERSION = '1.301001_079'; +our $VERSION = '1.301001_084'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) @EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); diff --git a/cpan/Test-Simple/lib/Test/use/ok.pm b/cpan/Test-Simple/lib/Test/use/ok.pm index a07c0a7..18d1026 100644 --- a/cpan/Test-Simple/lib/Test/use/ok.pm +++ b/cpan/Test-Simple/lib/Test/use/ok.pm @@ -3,7 +3,7 @@ use strict; use warnings; use 5.005; -our $VERSION = '1.301001_079'; +our $VERSION = '1.301001_084'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Stream 1.301001 '-internal'; diff --git a/cpan/Test-Simple/lib/ok.pm b/cpan/Test-Simple/lib/ok.pm index 088ec7e..f7fa459 100644 --- a/cpan/Test-Simple/lib/ok.pm +++ b/cpan/Test-Simple/lib/ok.pm @@ -6,7 +6,7 @@ use Test::Stream 1.301001 '-internal'; use Test::More 1.301001 (); use Test::Stream::Carp qw/croak/; -our $VERSION = '1.301001_079'; +our $VERSION = '1.301001_084'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) sub import { diff --git a/cpan/Test-Simple/t/Behavior/CustomOutput.t b/cpan/Test-Simple/t/Behavior/CustomOutput.t new file mode 100644 index 0000000..e4d7185 --- /dev/null +++ b/cpan/Test-Simple/t/Behavior/CustomOutput.t @@ -0,0 +1,137 @@ +use strict; +use warnings; + +use Test::Stream; +use Test::More; +use Scalar::Util qw/blessed/; + +# This will replace the main Test::Stream object for the scope of the coderef. +# We apply our output changes only in that scope so that this test itself can +# verify things with regular TAP output. The things done inside thise sub would +# work just fine when used by any module to alter the output. + +my @OUTPUT; +Test::Stream->intercept(sub { + # Turn off normal TAP output + Test::Stream->shared->set_use_tap(0); + + # Turn off legacy storage of results. + Test::Stream->shared->set_use_legacy(0); + + Test::Stream->shared->listen(sub { + my ($stream, $event) = @_; + + push @OUTPUT => "We got an event of type " . blessed($event); + }); + + # Now we run some tests, no TAP will be produced, instead all events will + # be added to @OUTPUT. + + ok(1, "pass"); + ok(0, "fail"); + + subtest foo => sub { + ok(1, "pass"); + ok(0, "fail"); + }; + + diag "Hello"; +}); + +is_deeply( + \@OUTPUT, + [ + 'We got an event of type Test::Stream::Event::Ok', + 'We got an event of type Test::Stream::Event::Ok', + 'We got an event of type Test::Stream::Event::Note', + 'We got an event of type Test::Stream::Event::Subtest', + 'We got an event of type Test::Stream::Event::Diag', + ], + "Got all events" +); + +# Now for something more complicated, lets have everything be normal TAP, +# except subtests + +my (@STDOUT, @STDERR, @TODO); +my @IO = (\@STDOUT, \@STDERR, \@TODO); + +Test::Stream->intercept(sub { + # Turn off normal TAP output + Test::Stream->shared->set_use_tap(0); + + # Turn off legacy storage of results. + Test::Stream->shared->set_use_legacy(0); + + my $number = 1; + Test::Stream->shared->listen(sub { + my ($stream, $e) = @_; + + # Do not output results inside subtests + return if $e->in_subtest; + + return unless $e->can('to_tap'); + + my $num = $stream->use_numbers ? $number++ : undef; + + # Get the TAP for the event + my @sets; + if ($e->isa('Test::Stream::Event::Subtest')) { + # Subtest is a subclass of Ok, use Ok's to_tap method: + @sets = Test::Stream::Event::Ok::to_tap($e, $num); + # Here you can also add whatever output you want. + } + else { + @sets = $e->to_tap($num); + } + + for my $set (@sets) { + my ($hid, $msg) = @$set; + next unless $msg; + my $enc = $e->encoding || die "Could not find encoding!"; + + # This is how you get the proper handle to use (STDERR, STDOUT, ETC). + my $io = $stream->io_sets->{$enc}->[$hid] || die "Could not find IO $hid for $enc"; + $io = $IO[$hid]; + + # Make sure we don't alter these vars. + local($\, $", $,) = (undef, ' ', ''); + + # Normally you print to the IO, but here we are pushing to arrays + chomp($msg); + push @$io => $msg; + } + }); + + # Now we run some tests, no TAP will be produced, instead all events will + # be added to our ourputs + + ok(1, "pass"); + ok(0, "fail"); + + subtest foo => sub { + ok(1, "pass"); + ok(0, "fail"); + }; + + diag "Hello"; +}); + +is(@TODO, 0, "No TODO output"); + +is_deeply( + \@STDOUT, + [ + 'ok 1 - pass', + 'not ok 2 - fail', + '# Subtest: foo', + # As planned, none of the events inside the subtest got rendered. + 'not ok 4 - foo' + ], + "Got expected TAP" +); + +is(pop(@STDERR), "# Hello", "Got the hello diag"); +is(@STDERR, 2, "got diag for 2 failed tests"); + +done_testing; diff --git a/cpan/Test-Simple/t/Legacy/subtest/fork.t b/cpan/Test-Simple/t/Legacy/subtest/fork.t index 8d763a4..7e0c685 100644 --- a/cpan/Test-Simple/t/Legacy/subtest/fork.t +++ b/cpan/Test-Simple/t/Legacy/subtest/fork.t @@ -8,6 +8,13 @@ use IO::Pipe; use Test::Builder; use Test::More tests => 1; +# On systems that fake forking, localized vars get unwound improperly +# post-fork. the 'subtest' function localizes $@ and $!, as such this +# test will fail on fake-fork systems up until 5.20.2 +plan skip_all => "Skipping fork tests on $^O" + if ($^O eq 'MSWin32' || $^O eq 'NetWare') + && !eval { require v5.20.2 }; + subtest 'fork within subtest' => sub { plan tests => 2; diff --git a/cpan/Test-Simple/t/Test-Stream-API.t b/cpan/Test-Simple/t/Test-Stream-API.t new file mode 100644 index 0000000..688d9d4 --- /dev/null +++ b/cpan/Test-Simple/t/Test-Stream-API.t @@ -0,0 +1,331 @@ +use strict; +use warnings; + +use Test::Stream; +use Test::More; +use Test::Stream::Tester qw/events_are event directive check/; +use Test::MostlyLike; + +require Test::Builder; +require Test::CanFork; + +use Test::Stream::API qw{ + listen munge follow_up + enable_forking cull + peek_todo push_todo pop_todo set_todo inspect_todo + is_tester init_tester + is_modern set_modern + context peek_context clear_context set_context + intercept + state_count state_failed state_plan state_ended is_passing + current_stream + + disable_tap enable_tap subtest_tap_instant subtest_tap_delayed tap_encoding + enable_numbers disable_numbers set_tap_outputs get_tap_outputs +}; + +can_ok(__PACKAGE__, qw{ + listen munge follow_up + enable_forking cull + peek_todo push_todo pop_todo set_todo inspect_todo + is_tester init_tester + is_modern set_modern + context peek_context clear_context set_context + intercept + state_count state_failed state_plan state_ended is_passing + current_stream + + disable_tap enable_tap subtest_tap_instant subtest_tap_delayed tap_encoding + enable_numbers disable_numbers set_tap_outputs get_tap_outputs +}); + +ok(!is_tester('My::Tester'), "Not a tester"); +isa_ok(init_tester('My::Tester'), 'Test::Stream::Meta'); +isa_ok(is_tester('My::Tester'), 'Test::Stream::Meta'); + +ok(!is_modern('My::Tester'), "Not a modern tester"); +set_modern('My::Tester', 1); +ok(is_modern('My::Tester'), "a modern tester"); +set_modern('My::Tester', 0); +ok(!is_modern('My::Tester'), "Not a modern tester"); + +ok(my $ctx = context(), "Got context"); +isa_ok($ctx, 'Test::Stream::Context'); +is(context(), $ctx, "Got the same instance again"); +is(peek_context(), $ctx, "peek"); +my $ref = "$ctx"; + +clear_context(); +my $ne = context() . "" ne $ref; +ok($ne, "cleared"); + +set_context($ctx); +is(context(), $ctx, "Got the same instance again"); + +$ctx = undef; +$ne = context() . "" ne $ref; +ok($ne, "New instance"); + +isa_ok(current_stream(), 'Test::Stream'); + +my @munge; +my @listen; +my @follow; +intercept { + munge { push @munge => $_[1] }; + listen { push @listen => $_[1] }; + + follow_up { push @follow => $_[0]->snapshot }; + + ok(1, "pass"); + diag "foo"; + + done_testing; +}; + +is(@listen, 3, "listen got 3 events"); +is(@munge, 3, "munge got 3 events"); +is(@follow, 1, "Follow was triggered"); + +my $want = check { + event ok => { bool => 1 }; + event diag => { message => 'foo' }; + event plan => { max => 1 }; + directive 'end'; +}; +events_are( \@listen, $want, "Listen events" ); +events_are( \@munge, $want, "Munge events" ); +isa_ok($follow[0], 'Test::Stream::Context'); + + +my $events = intercept { + Test::CanFork->import; + + # On systems that fake forking, localized vars get unwound improperly + # post-fork. the 'intercept' function localizes $@ and $!, as such this + # test will fail on fake-fork systems up until 5.20.2 + plan skip_all => "Skipping fork tests on $^O" + if ($^O eq 'MSWin32' || $^O eq 'NetWare') + && !eval { require v5.20.2 }; + + enable_forking; + + my $pid = fork(); + if ($pid) { # Parent + waitpid($pid, 0); + cull; + ok(1, "From Parent"); + } + else { # child + ok(1, "From Child"); + exit 0; + } +}; + +if (@$events == 1) { + events_are ( + $events, + check { + event plan => {}; + }, + "Not testing forking" + ); +} +else { + events_are ( + $events, + check { + event ok => { name => 'From Child' }; + event ok => { name => 'From Parent' }; + }, + "Got forked events" + ); +} + +events_are( + intercept { + ok(0, "fail"); + push_todo('foo'); + ok(0, "fail"); + push_todo('bar'); + ok(0, "fail"); + is(peek_todo(), 'bar', "peek works"); + pop_todo(); + ok(0, "fail"); + pop_todo(); + ok(0, "fail"); + }, + check { + event ok => {todo => '', in_todo => 0}; + event ok => {todo => 'foo', in_todo => 1}; + event ok => {todo => 'bar', in_todo => 1}; + event ok => {bool => 1, real_bool => 1}; # Verify peek + event ok => {todo => 'foo', in_todo => 1}; + event ok => {todo => '', in_todo => 0}; + }, + "Verified TODO stack" +); + +my $meta = init_tester('My::Tester'); +ok(!$meta->todo, "Package is not in todo"); +set_todo('My::Tester', 'foo'); +is($meta->todo, 'foo', "Package is in todo"); + +my @todos = ( + inspect_todo, + inspect_todo('My::Tester'), +); +push_todo('foo'); +push_todo('bar'); +Test::Builder->new->todo_start('tb todo'); +$My::Tester::TODO = 'pkg todo'; +push @todos => inspect_todo, inspect_todo('My::Tester'); +$My::Tester::TODO = undef; +Test::Builder->new->todo_end(); +pop_todo; +pop_todo; +set_todo('My::Tester', undef); +push @todos => inspect_todo, inspect_todo('My::Tester'); + +is_deeply( + \@todos, + [ + { + TB => undef, + TODO => [], + }, + { + META => 'foo', + PKG => undef, + TB => undef, + TODO => [], + }, + { + TB => 'tb todo', + TODO => [qw/foo bar/], + }, + { + META => 'foo', + PKG => 'pkg todo', + TB => 'tb todo', + TODO => [qw/foo bar/], + }, + { + TB => undef, + TODO => [], + }, + { + META => undef, + PKG => undef, + TB => undef, + TODO => [], + } + ], + "Todo state from inspect todo" +); + +my @state; +intercept { + plan tests => 3; + ok(1, "pass"); + ok(2, "pass"); + + push @state => { + count => state_count() || 0, + failed => state_failed() || 0, + plan => state_plan() || undef, + ended => state_ended() || undef, + passing => is_passing(), + }; + + ok(0, "fail"); + done_testing; + + push @state => { + count => state_count() || 0, + failed => state_failed() || 0, + plan => state_plan() || undef, + ended => state_ended() || undef, + passing => is_passing(), + }; +}; + +mostly_like( + \@state, + [ + { count => 2, failed => 0, passing => 1, ended => undef }, + { count => 3, failed => 1, passing => 0 }, + ], + "Verified Test state" +); + +events_are( + [ $state[0]->{plan}, $state[1]->{plan} ], + check { + event plan => { max => 3 }; + event plan => { max => 3 }; + }, + "Parts of state that are events check out." +); + +isa_ok( $state[1]->{ended}, 'Test::Stream::Context' ); + +my $got; +my $results = ""; +my $utf8 = ""; +open( my $fh, ">>", \$results ) || die "Could not open handle to scalar!"; +open( my $fh_utf8, ">>", \$utf8 ) || die "Could not open handle to scalar!"; + +intercept { + enable_tap(); # Disabled by default in intercept() + set_tap_outputs( std => $fh, err => $fh, todo => $fh ); + $got = get_tap_outputs(); + + ok(1, "pass"); + + disable_tap(); + ok(0, "fail"); + + enable_tap(); + tap_encoding('utf8'); + set_tap_outputs( encoding => 'utf8', std => $fh_utf8, err => $fh_utf8, todo => $fh_utf8 ); + ok(1, "pass"); + tap_encoding('legacy'); + + disable_numbers(); + ok(1, "pass"); + enable_numbers(); + ok(1, "pass"); + + subtest_tap_instant(); + subtest foo => sub { ok(1, 'pass') }; + + subtest_tap_delayed(); + subtest foo => sub { ok(1, 'pass') }; +}; + +is_deeply( + $got, + { encoding => 'legacy', std => $fh, err => $fh, todo => $fh }, + "Got outputs" +); + +is( $results, <<EOT, "got TAP output"); +ok 1 - pass +ok - pass +ok 5 - pass +# Subtest: foo + ok 1 - pass + 1..1 +ok 6 - foo +ok 7 - foo { + ok 1 - pass + 1..1 +} +EOT + +is( $utf8, <<EOT, "got utf8 TAP output"); +ok 3 - pass +EOT + +done_testing; -- Perl5 Master Repository
