In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/4bba85d0fdb428e77c7a589a992b892d7999bb33?hp=09c759bcfa4c2880c571df4da20458b2f781debf>
- Log ----------------------------------------------------------------- commit 4bba85d0fdb428e77c7a589a992b892d7999bb33 Author: Chad Granum <[email protected]> Date: Mon Dec 22 07:39:38 2014 -0800 Test-Simple Version Bump, 1.301001_093 (RC13) Add alternate email address for Chad Granum to Porting/checkAUTHORS.pl. ----------------------------------------------------------------------- Summary of changes: MANIFEST | 2 + Porting/checkAUTHORS.pl | 1 + cpan/Test-Simple/lib/Test/Builder.pm | 26 ++- cpan/Test-Simple/lib/Test/Builder/Module.pm | 2 +- cpan/Test-Simple/lib/Test/Builder/Tester.pm | 4 +- cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm | 2 +- cpan/Test-Simple/lib/Test/CanThread.pm | 4 +- cpan/Test-Simple/lib/Test/More.pm | 4 +- cpan/Test-Simple/lib/Test/Simple.pm | 4 +- cpan/Test-Simple/lib/Test/Stream.pm | 111 ++++++---- cpan/Test-Simple/lib/Test/Stream/Architecture.pod | 239 +++++++++++---------- cpan/Test-Simple/lib/Test/Stream/Block.pm | 197 +++++++++++++++++ cpan/Test-Simple/lib/Test/Stream/Context.pm | 43 +++- cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm | 1 + cpan/Test-Simple/lib/Test/Stream/Event/Note.pm | 1 + cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm | 2 + cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm | 4 +- cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm | 45 ++-- .../lib/Test/Stream/ExitMagic/Context.pm | 2 + cpan/Test-Simple/lib/Test/Stream/Subtest.pm | 72 +++++-- cpan/Test-Simple/lib/Test/Stream/Toolset.pm | 3 - cpan/Test-Simple/lib/Test/Tester.pm | 14 +- cpan/Test-Simple/lib/Test/use/ok.pm | 2 +- cpan/Test-Simple/lib/ok.pm | 2 +- cpan/Test-Simple/t/Test-Stream-API.t | 1 - cpan/Test-Simple/t/Test-Stream-Block.t | 108 ++++++++++ cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm | 2 +- 27 files changed, 667 insertions(+), 231 deletions(-) create mode 100644 cpan/Test-Simple/lib/Test/Stream/Block.pm create mode 100644 cpan/Test-Simple/t/Test-Stream-Block.t diff --git a/MANIFEST b/MANIFEST index e781d3a..b69726d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2276,6 +2276,7 @@ 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 +cpan/Test-Simple/lib/Test/Stream/Block.pm Test::Simple module cpan/Test-Simple/lib/Test/Stream/Carp.pm Test::Simple module cpan/Test-Simple/lib/Test/Stream/Context.pm Test::Simple module cpan/Test-Simple/lib/Test/Stream/Event/Bail.pm Test::Simple module @@ -2490,6 +2491,7 @@ 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-Block.t Test::Simple Test cpan/Test-Simple/t/Test-Stream-Carp.t Test::Simple Test cpan/Test-Simple/t/Test-Stream-Event-Diag.t Test::Simple Test cpan/Test-Simple/t/Test-Stream-Event-Finish.t Test::Simple Test diff --git a/Porting/checkAUTHORS.pl b/Porting/checkAUTHORS.pl index b33ec57..24843fa 100755 --- a/Porting/checkAUTHORS.pl +++ b/Porting/checkAUTHORS.pl @@ -564,6 +564,7 @@ brian.d.foy\100gmail.com bdfoy\100cpan.org BQW10602\100nifty.com sadahiro\100cpan.org bulk88\100hotmail.com bulk88 +chad.granum\100dreamhost.com exodist7\100gmail.com chromatic\100wgz.org chromatic\100rmci.net ckuskie\100cadence.com colink\100perldreamer.com claes\100surfar.nu claes\100versed.se diff --git a/cpan/Test-Simple/lib/Test/Builder.pm b/cpan/Test-Simple/lib/Test/Builder.pm index 099d389..1528248 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_090'; +our $VERSION = '1.301001_093'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) @@ -156,9 +156,8 @@ sub child { } $name ||= "Child of " . $self->{Name}; - $ctx->child('push', $name, 1); - my $stream = $self->{stream} || Test::Stream->shared; + $ctx->subtest_start($name, parent_todo => $ctx->in_todo); my $child = bless { %$self, @@ -190,7 +189,6 @@ sub finalize { my $passing = $ctx->stream->is_passing; my $count = $ctx->stream->count; my $name = $self->{Name}; - $ctx = undef; my $stream = $self->{stream} || Test::Stream->shared; @@ -200,8 +198,24 @@ sub finalize { $? = $self->{'?'}; - $ctx = $parent->ctx; - $ctx->child('pop', $self->{Name}); + my $st = $ctx->subtest_stop($name); + + $parent->ctx->subtest( + # Stuff from ok (most of this gets initialized inside) + undef, # real_bool, gets set properly by initializer + $st->{name}, # name + undef, # diag + undef, # bool + undef, # level + + # Subtest specific stuff + $st->{state}, + $st->{events}, + $st->{exception}, + $st->{early_return}, + $st->{delayed}, + $st->{instant}, + ); } sub in_subtest { diff --git a/cpan/Test-Simple/lib/Test/Builder/Module.pm b/cpan/Test-Simple/lib/Test/Builder/Module.pm index c5baa2c..e31eded 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_090'; +our $VERSION = '1.301001_093'; $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 688dace..367608f 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_090'; +our $VERSION = '1.301001_093'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Stream 1.301001 '-internal'; @@ -370,7 +370,7 @@ sub test_test { # re-enable the original setting of the harness $ENV{HARNESS_ACTIVE} = $original_harness_env; - $original_stream->state->[-1] = $original_state; + @{$original_stream->state->[-1]} = @$original_state; # check the output we've stashed unless( builder()->ok( ( $args{skip_out} || $out->check ) && diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm index f8646b5..e5d91a1 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_090'; +our $VERSION = '1.301001_093'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Stream 1.301001 '-internal'; diff --git a/cpan/Test-Simple/lib/Test/CanThread.pm b/cpan/Test-Simple/lib/Test/CanThread.pm index 5902f84..58ac8da 100644 --- a/cpan/Test-Simple/lib/Test/CanThread.pm +++ b/cpan/Test-Simple/lib/Test/CanThread.pm @@ -34,8 +34,8 @@ sub import { Test::More::plan(skip_all => "This threaded test will only run when the '$var' environment variable is set."); } - unshift @_ => 'threads'; - goto &threads::import; + my $caller = caller; + eval "package $caller; use threads; 1" || die $@; } 1; diff --git a/cpan/Test-Simple/lib/Test/More.pm b/cpan/Test-Simple/lib/Test/More.pm index 5744c22..c0d958e 100644 --- a/cpan/Test-Simple/lib/Test/More.pm +++ b/cpan/Test-Simple/lib/Test/More.pm @@ -4,7 +4,7 @@ use 5.008001; use strict; use warnings; -our $VERSION = '1.301001_090'; +our $VERSION = '1.301001_093'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Stream 1.301001 '-internal'; @@ -1695,8 +1695,6 @@ magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO -=head2 - =head2 ALTERNATIVES L<Test::Simple> if all this confuses you and you just want to write diff --git a/cpan/Test-Simple/lib/Test/Simple.pm b/cpan/Test-Simple/lib/Test/Simple.pm index 4da7713..ac30ea4 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_090'; +our $VERSION = '1.301001_093'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) -use Test::Stream 1.301001_090 '-internal'; +use Test::Stream 1.301001_093 '-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 1558eb0..0690625 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_090'; +our $VERSION = '1.301001_093'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Stream::Context qw/context/; @@ -17,7 +17,7 @@ use Test::Stream::ArrayBase( no_ending no_diag no_header pid tid state - subtests subtest_todo subtest_exception + subtests subtest_tap_instant subtest_tap_delayed mungers @@ -422,47 +422,66 @@ sub done_testing { } } -sub send { - my ($self, $e) = @_; +sub subtest_start { + my $self = shift; + my ($name, %params) = @_; - # Subtest state management - if ($e->isa('Test::Stream::Event::Child')) { - if ($e->action eq 'push') { - $e->context->note("Subtest: " . $e->name) if $self->[SUBTEST_TAP_INSTANT] && !$e->no_note; + my $state = [0, 0, undef, 1]; - push @{$self->[STATE]} => [0, 0, undef, 1]; - push @{$self->[SUBTESTS]} => []; - push @{$self->[SUBTEST_TODO]} => $e->context->in_todo; - push @{$self->[SUBTEST_EXCEPTION]} => undef; + $params{parent_todo} ||= Test::Stream::Context::context->in_todo; - return $e; - } - else { - pop @{$self->[SUBTEST_TODO]}; - my $events = pop @{$self->[SUBTESTS]} || confess "Unbalanced subtest stack (events)!"; - my $state = pop @{$self->[STATE]} || confess "Unbalanced subtest stack (state)!"; - confess "Child pop left the stream without a state!" unless @{$self->[STATE]}; - - $e = Test::Stream::Event::Subtest->new_from_pairs( - context => $e->context, - created => $e->created, - events => $events, - state => $state, - name => $e->name, - exception => pop @{$self->[SUBTEST_EXCEPTION]}, - ); - } + if(@{$self->[SUBTESTS]}) { + $params{parent_todo} ||= $self->[SUBTESTS]->[-1]->{parent_todo}; } + push @{$self->[STATE]} => $state; + push @{$self->[SUBTESTS]} => { + instant => $self->[SUBTEST_TAP_INSTANT], + delayed => $self->[SUBTEST_TAP_DELAYED], + + %params, + + state => $state, + events => [], + name => $name, + }; + + return $self->[SUBTESTS]->[-1]; +} + +sub subtest_stop { + my $self = shift; + my ($name) = @_; + + confess "No subtest to stop!" + unless @{$self->[SUBTESTS]}; + + confess "Subtest name mismatch!" + unless $self->[SUBTESTS]->[-1]->{name} eq $name; + + my $st = pop @{$self->[SUBTESTS]}; + pop @{$self->[STATE]}; + + return $st; +} + +sub subtest { @{$_[0]->[SUBTESTS]} ? $_[0]->[SUBTESTS]->[-1] : () } + +sub send { + my ($self, $e) = @_; + my $cache = $self->_update_state($self->[STATE]->[-1], $e); # Subtests get dibbs on events - if (@{$self->[SUBTESTS]}) { - $e->context->set_diag_todo(1) if $self->[SUBTEST_TODO]->[-1]; - $e->set_in_subtest(scalar @{$self->[SUBTESTS]}); - push @{$self->[SUBTESTS]->[-1]} => $e; + if (my $num = @{$self->[SUBTESTS]}) { + my $st = $self->[SUBTESTS]->[-1]; + + $e->set_in_subtest($num); + $e->context->set_diag_todo(1) if $st->{parent_todo}; - $self->_render_tap($cache) if $self->[SUBTEST_TAP_INSTANT] && !$cache->{no_out}; + push @{$st->{events}} => $e; + + $self->_render_tap($cache) if $st->{instant} && !$cache->{no_out}; } elsif($self->[_USE_FORK] && ($$ != $self->[PID] || get_tid() != $self->[TID])) { $self->fork_out($e); @@ -556,8 +575,7 @@ sub _render_tap { return unless $cache->{do_tap} || $e->can('to_tap'); my $num = $self->use_numbers ? $cache->{number} : undef; - confess "XXX" unless $e->can('to_tap'); - my @sets = $e->to_tap($num, $self->[SUBTEST_TAP_DELAYED]); + my @sets = $e->to_tap($num); my $in_subtest = $e->in_subtest || 0; my $indent = ' ' x $in_subtest; @@ -594,9 +612,11 @@ sub _finalize_event { return unless $e->directive; return unless $e->directive eq 'SKIP'; - $self->[SUBTEST_EXCEPTION]->[-1] = $e if $e->in_subtest; + my $subtest = @{$self->[SUBTESTS]}; + + $self->[SUBTESTS]->[-1]->{early_return} = $e if $subtest; - if ($e->in_subtest) { + if ($subtest) { my $begin = _scan_for_begin('Test::Stream::Subtest::subtest'); if ($begin) { @@ -623,9 +643,11 @@ sub _finalize_event { $self->[BAILED_OUT] = $e; $self->[NO_ENDING] = 1; - $self->[SUBTEST_EXCEPTION]->[-1] = $e if $e->in_subtest; + my $subtest = @{$self->[SUBTESTS]}; - if ($e->in_subtest) { + $self->[SUBTESTS]->[-1]->{early_return} = $e if $subtest; + + if ($subtest) { my $begin = _scan_for_begin('Test::Stream::Subtest::subtest'); if ($begin) { @@ -895,6 +917,15 @@ Turn legacy result storing on and off. Turn test numbers on and off. +=item $stash = $stream->subtest_start($name, %params) + +=item $stash = $stream->subtest_stop($name) + +These will push/pop new states and subtest stashes. + +B<Using these directly is not recommended.> Also see the wrapper methods in +L<Test::Stream::Context>. + =back =head2 SENDING EVENTS diff --git a/cpan/Test-Simple/lib/Test/Stream/Architecture.pod b/cpan/Test-Simple/lib/Test/Stream/Architecture.pod index b98ce50..b67fe7e 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Architecture.pod +++ b/cpan/Test-Simple/lib/Test/Stream/Architecture.pod @@ -1,15 +1,14 @@ =head1 NAME -Test::Stream::Architecture - Overview of how the Test-More dist works. +Test::Stream::Architecture - overview of how the Test-More dist works. =head1 DESCRIPTION -This is the document that explains the architecture of Test::More and all the -stuff driving it under the hood. +This document explains the Test::More architecture from top to bottom. =head1 KEY COMPONENTS -This is the list of primary components and their brief description, The most +This is the list of primary components and their brief description, the most critical ones will have more details in later sections. =over 4 @@ -18,44 +17,48 @@ critical ones will have more details in later sections. =item Test::Simple -These are the primary public interfaces for anyone who wishes to write tests. +These contain the public subroutines for anyone who wishes to write tests. =item Test::More::Tools -All of the tools Test::More provides have been relocated and refactored into -Test::More::Tools in such a way as to make them generic and reusable. This -means you can use them without firing off events, you can then fire off your -own events compiled from multiple tools. In many cases this is what tool -builders actually want, but instead they settle for bumping C<$Level> and -calling is/like/ok and producing extra events. +All of the tools that L<Test::More> provided have been relocated into +L<Test::More::Tools> and refactored to make them generic and reusable. + +This means you can use them without inadvertently firing off events. In many +cases this is what tool builders actually want but instead they settle for +bumping C<$Level> and calling is(), like(), or ok() and producing extra +events. =item Test::Builder -This B<used> to be the main under the hood module for anyone who wished to -write a L<Test::More> compatible test library. It still works, and should be -fully functional and backwards compatible. It is however discouraged as it is -mostly a compatability wrapper. +This was the B<old> under-the-hood module for anyone who wished to write +a L<Test::More>-compatible test library. It still works and should be fully +functional and backwards compatible. It is, however, discouraged as it is +mostly a compatibility wrapper. =item Test::Stream -This is the B<new> heart and soul of the Test::* architecture. However it is -not the primary interface. This module is responsible for collecting all events -from all threads and processes, then forwarding them to TAP and any added -listeners. +This is the B<new> heart and soul of the Test::* architecture. It is not the +primary interface that a unit-test author will use. This module is responsible +for collecting all events from all threads and processes and then forwarding +them to TAP and any other added listeners. =item Test::Stream::IOSets -This module is used to manage the IO handles to which all TAP is sent. -Test::Builder cloned STDERR and STDOUT, then applied various magic to them. -This module provides that legacy support while also adding support for utf8 and -other encodings. By default all TAP goes to the 'legacy' outputs, which mimick -what Test::Builder has always done. The 'legacy' outputs are also what get -altered if someone uses the Test::Builder->output interface. +This manages the IO handles to which all TAP is sent. + +In the old days, L<Test::Builder> cloned STDERR and STDOUT and applied various +magic to them. + +This module provides that legacy support while also adding support for L<utf8> +and other encodings. By default, all TAP goes to the 'legacy' outputs, which +mimick what Test::Builder has always done. The 'legacy' outputs are also +what get altered if someone uses the C<Test::Builder-E<gt>output> interface. =item Test::Stream::Toolset This is the primary interface a test module author should use. It ties together -some key functions you should use. It proved 3 critical functions: +some key functions you should use. It provides 3 critical functions: is_tester($package) @@ -65,13 +68,13 @@ some key functions you should use. It proved 3 critical functions: =item Test::Stream::Context -This is the primary interface as far as generating events goes. Every test -function should grab a context, and use it to generate events. +A context is used to generate events in test functions. -Once a context object is created (the normal way) it is remembered, and -anything that requests a context object will obtain the same instance. However -once the instance is destroyed (end of your test function) it is forgotten, the -next test function to run will then obtain a new context instance. +Once a context object is created (the normal way) it is remembered and +anything that requests a context object will obtain the same instance. + +After the context instance is destroyed (at end of your test function) it is +forgotten. The next test function to run must obtain a new context instance. =item Test::Stream::Event @@ -83,21 +86,19 @@ next test function to run will then obtain a new context instance. =item Test::Stream::Event::* -All events generated by Test::More and other test tools now boil down to a -proper object. All events must use Test::Stream::Event as a base. +All events generated by L<Test::More> and other test tools now boil down to a +proper object. All event subclasses must use L<Test::Stream::Event> as a base. =item Test::Stream::ArrayBase -This is the L<Moose> of Test::Stream. It is responsible for generating -accessors and similar work. Unlike moose and others it uses an arrayref as the -underlying object. This design decision was made to improve performance. -Performance was a real problem in some early alphas, the gains from the -decision are huge. +This is the L<Moose> of L<Test::Stream>. It is responsible for generating +accessors and similar work. Unlike Moose, it uses an arrayref as the +underlying object to improve performance. Performance was a real problem in +some early alphas and the speed gains from this decision are huge. =item Test::Stream::Tester -This is actually what spawned the ideas for the new Test::Stream work. This is -a module that lets you validate your testing tools. +This module can validate testing tools and their events. =back @@ -111,27 +112,27 @@ a module that lets you validate your testing tools. =head2 HISTORY -L<Test::Builder> is/was a singleton. The singleton model was chosen to solve -the problem of synchronizing everything to a central location. Ultimately all -results need to make their way to a central place that can assign them a -number, and shove them through the correct output. +L<Test::Builder> was (and still is) a singleton. The singleton model was +chosen to solve the problem of synchronizing everything to a central location. +Ultimately, all test results needed to make their way to a central place that +could assign each test a number and create output in the correct order. The singleton model proved to be a major headache. Intercepting events typically meant replacing the singleton permanently -(Test::Tester) or for a limited scope. Another option people took -(Test::Builder::Tester) was to simply replace the IO handles Test::Builder was -tracking. +(L<Test::Tester>) or for a limited scope. Another option people took +(L<Test::Builder::Tester>) was to simply replace the IO handles +Test::Builder was tracking. -Test::Builder did not provide any real mechanisms for altering events before -processing them, or for intercepting them before they were turned into TAP. As -a result many modules have monkeypatched Test::Builder, particularily the -C<ok()> method. +Test::Builder did not provide any real mechanisms for altering events +before processing them, or for intercepting them before they were turned into +TAP. As a result many modules have monkeypatched Test::Builder, particularily +the C<ok()> method. =head2 CURRENT DESIGN -Test::Stream unfortunately must still act as a singleton (mostly). But this -time the design was to put as little as possible into the singleton. +L<Test::Stream> unfortunately must still act as a singleton (mostly). This +time, the design put as little logic as possible into the singleton. =head3 RESPONSIBILITIES OF TEST::STREAM @@ -143,60 +144,60 @@ Test::Stream has 4 main jobs: $stream->send($event); -The send() method will ensure that the event gets to the right place, no matter -what thread or process you are in. (Forking support must be turned on, it is -off by default). +The send() method will ensure that the event gets to the right place, no +matter which thread or process your code is in. (Forking support must be turned +on. It is off by default). -B<Note:> This method is key to performance. This method and everything it calls +B<Note:> This method is key to performance. C<send()> and everything it calls must remain as lean and tight as possible. -=item Provide a pre-output hook for altering events +=item Provide a pre-output hook to alter events $stream->munge(sub { my ($stream, $event) = @_; ... }) -This lets you modify events before they are turned into output. You cannot -remove the event, nor can you add events. Mungers are additive, and proceessed +C<munge()> lets you modify events before they are turned into output. It cannot +remove the event, nor can it add events. Mungers are additive and proceessed in the order they are added. There is not currently any way to remove a munger. -B<Note:> each munger is called in a loop in the C<send()> method, so keep it as -fast and small as possible. +B<Note:> each munger is called in a loop in the C<send()> method, so keep them +as fast and small as possible. -=item Forward all events to listeners (including TAP output) +=item Forward all events to all listeners (including TAP output) $stream->listen(sub { my ($stream, $event) = @_; .... }) -This lets you add a listener. All events that come to the stream object will be -sent to all listeners. +C<listen()> adds a listener. All events that come from the stream object will +be sent to all listeners. There is not currently any way to remove a listener. -B<Note:> each listener is called in a loop in the C<send()> method, so keep it is -fast and small as possible. +B<Note:> each listener is called in a loop in the C<send()> method, so keep +them as fast and small as possible. =item Maintaining the legacy exit behavior from Test::Builder -This is primarily setting $? to the number of tests that failed, up to 255, as -well as providing other output such as missing a plan. +This is sets C<$?> to the number of tests that failed (up to 255). It also +provides some other output such as when a test file is missing a plan. =back =head3 SEMI-SINGLETON MODEL -Test::Stream has a semi-singleton model. Instead of 1 singleton, it is a +L<Test::Stream> has a semi-singleton model. Instead of 1 singleton, it has a singleton stack. Anything that wants to send an event to the B<current> acting -stream should send it to the stream returned by C<< Test::Stream->shared >>. +stream should send it to the stream returned by C<Test::Stream-E<gt>shared>. Nothing should ever cache this result as the B<current> stream may change. -This mechanism is primarily used for intercepting, and hiding, all events for a -limited scope. L<Test::Stream::Tester> uses this to push a stream onto the stack so -that you can generate events that do not go to the listeners or TAP. Once the -stack is popped the previous stream is restored allowing you to generate real -events. +This mechanism is primarily used for intercepting and hiding all events for a +limited scope. L<Test::Stream::Tester> uses this to push a stream onto the +stack so that events can be generated that do not go to the listeners or TAP. +Once the stack is popped, the previous stream is restored, which allows real +events to be generated. You can also create new Test::Stream objects at-will that are not present in -the stack, this lets you create alternate streams for any purpose you want. +the stack. This lets you create alternate streams for any purpose you want. =head1 THE CONTEXT OBJECT @@ -206,12 +207,12 @@ the stack, this lets you create alternate streams for any purpose you want. =back -This module is responsbile for 2 things, knowing where to report errors, and +This module is responsible for 2 things: knowing where to report errors and making it easy to issue events. =head2 ERROR REPORTING -To get the context you use the C<context()> function. +Use the C<context()> function to get the current context. sub ok { my $context = context(); @@ -221,13 +222,17 @@ To get the context you use the C<context()> function. ok() # Errors are reported here. If there is a context already in play, that instance will be returned. -Otherwise a new context will be returned. The context assumes that the stack -level just above your call is where errors should be reported. +Otherwise, a new context will be returned. + +The context assumes that the stack level just above your call is where errors +should be reported. You can optionally provide an integer as the only argument, in which case that number will be added to the C<caller()> call to find the correct frame for -reporting. This will be completely ignored if there is already an active -context. +reporting. + +B<Note:> The integer argument will be completely ignored if there is already +an active context. sub ok { my $context = context(); @@ -241,16 +246,17 @@ context. my_ok(); -In the example above c<my_ok()> generates a new context, then it calls C<ok()>, -in this case both function will have the same context object, the one generated -by my_ok. The result is that C<ok> will report errors to the correct place. +In the example above, c<my_ok()> generates a new context and then it calls +C<ok()>. In this case, both functions will have the same context object (the +one generated by C<my_ok()>). The result is that C<ok> will report errors to +the correct place. =head3 IMPLEMENTATION -There is a variable C<$CURRENT> in C<Test::Stream::Context>, it is a lexical, -so you can not touch it directly. When the C<context()> function is called, it -first checks if $CURRENT is set, if so it returns that. If there is no current -context it generates a new one. +There is a lexical variable C<$CURRENT> in C<Test::Stream::Context> that can +not be directly touched. When the C<context()> function is called, it first +checks if $CURRENT is set, and if so, returns that. If there is no current +context, it generates a new one. When a new context is generated, it is assigned to C<$CURRENT>, but then the reference is weakened. This means that once the returned copy falls out of @@ -260,29 +266,30 @@ it. B<The caveat> here is that if you decide to hold on to your context beyond your scope, you could sabatoge any future test functions. If you need to hold -on to a context you need to call C<< $context->snapshot >>, and store the -cloned object it returns. In general you should not need to do this, event -objects all store the context, but do so using a snapshot. +on to a context you need to call C<$context-E<gt>snapshot>, and store the +cloned object it returns. In general you should not need to do this. Event +objects all store the context but do so using a snapshot. B<Note> I am open to changing this to remove the weak-reference magic and -instead require someone to call C<< $context->release >> or similar when they -are done with a context, but that seems more likely to result in rougue -contexts... This method would also require its own form of reference counting.. +instead require someone to call C<$context-E<gt>release> or similar when they +are done with a context but that seems more likely to result in rogue +contexts. This method would also require its own form of reference counting. This decision will need to be made before we go stable. =head2 GENERATING EVENTS -All event objects should use L<Test::Stream::Event> which will set them up as a -proper event object, as well as add a method to L<Test::Stream::Context> which -is a shortcut for generating that event type. As such you can fire off an event -directly from your context object using the lowercase name of the event class. +All event subclasses should use L<Test::Stream::Event> to set them up as +proper event objects. They should also add a method to +L<Test::Stream::Context> to be used as a shortcut for generating that event +type. That will let you can fire off an event directly from your context +object using the lowercase name of the event class. my $ctx = context; $ctx->ok(1, "pass"); $ctx->ok(0, "fail, ["This test failed, here is some diag ..."]); $ctx->note("I am a teapot"); -All events take a context, and 2 other arguments as the first 3 arguments of +All events take a context and 2 other arguments as the first 3 arguments of their constructor, these shortcut methods handle those first 3 arguments for you, making life much easier. @@ -292,7 +299,7 @@ The other arguments are: =item created -Should be an arrayref with caller information for where the event was generated. +an arrayref with caller information for where the event was generated. =item in_subtest @@ -302,14 +309,14 @@ True if the event belongs in a subtest, false otherwise. =head1 EVENT OBJECTS -Here are the primary/public events. There are other events, but they are used +Here are the primary public events. There are other events, but they are used internally. =over 4 =item L<Test::Stream::Event> -This is just a base-class, you do not use it directly. +This is just a base class. Do not use it directly. =item L<Test::Stream::Event::Diag> @@ -319,7 +326,7 @@ This is just a base-class, you do not use it directly. =item L<Test::Stream::Event::Bail> -These are faily simple and obvious event types. +These are fairly simple and obvious event types. =item L<Test::Stream::Event::Ok> @@ -327,21 +334,21 @@ These are faily simple and obvious event types. B<Note:> C<Subtest> is a subclass of C<Ok>. -Ok can contain diag objects related to that specific ok. Subtest contains all -the events that went into the final subtest result. +C<Ok> can contain diag objects related to that specific ok. C<Subtest> +contains all the events that went into the final subtest result. =back -All events have a context in which they were created, which includes the file -and line number where errors should be reported. They also have details on -where/how they were generated. All other details are event specific. +All events have the context in which they were created, which includes the +file and line number where errors should be reported. They also have details +on where and how they were generated. All other details are event-specific. The subclass event should never be generated on its own. In fact, just use the -subtest helpers provided by Test::More, or Test::Stream::Context. Under the -hood a Child event is started which adds a subtest to a stack in Test::Stream, -all events then get intercepted by that subtest. When the subtest is done you -issue another Child event to close it out. Once closed a Subtest event will be -generated for you and sent to the stream. +subtest helpers provided by L<Test::More>, or L<Test::Stream::Context>. Under +the hood, a L<Child> event is started which adds a subtest to a stack in +Test::Stream, and then all events get intercepted by that subtest. When the +subtest is done, issue another Child event to close it out. Once closed, a +Subtest event will be generated for you and sent to the stream. =encoding utf8 diff --git a/cpan/Test-Simple/lib/Test/Stream/Block.pm b/cpan/Test-Simple/lib/Test/Stream/Block.pm new file mode 100644 index 0000000..9acb851 --- /dev/null +++ b/cpan/Test-Simple/lib/Test/Stream/Block.pm @@ -0,0 +1,197 @@ +package Test::Stream::Block; +use strict; +use warnings; + +use Scalar::Util qw/blessed reftype/; +use Test::Stream::Carp qw/confess carp/; + +use Test::Stream::ArrayBase( + accessors => [qw/name coderef params caller deduced _start_line _end_line/], +); + +our %SUB_MAPS; + +sub PACKAGE() { 0 }; +sub FILE() { 1 }; +sub LINE() { 2 }; +sub SUBNAME() { 3 }; + +sub init { + my $self = shift; + + confess "coderef is a mandatory field for " . blessed($self) . " instances" + unless $self->[CODEREF]; + + confess "caller is a mandatory field for " . blessed($self) . " instances" + unless $self->[CALLER]; + + confess "coderef must be a code reference" + unless ref($self->[CODEREF]) && reftype($self->[CODEREF]) eq 'CODE'; + + require B; + my $code = $self->[CODEREF]; + my $cobj = B::svref_2object($code); + my $pkg = $cobj->GV->STASH->NAME; + my $file = $cobj->FILE; + my $line = $cobj->START->line; + my $subname = $cobj->GV->NAME; + + $SUB_MAPS{$file}->{$line} = $self->[NAME]; + + $self->[DEDUCED] = [$pkg, $file, $line, $subname]; + $self->[NAME] ||= $subname; + $self->[PARAMS] ||= {}; +} + +sub merge_params { + my $self = shift; + my ($new) = @_; + my $old = $self->[PARAMS]; + + # Use existing ref, merge in new ones, but old ones are kept since the + # block can override the workflow. + %$old = ( %$new, %$old ); +} + +sub package { $_[0]->[DEDUCED]->[PACKAGE] } +sub file { $_[0]->[DEDUCED]->[FILE] } +sub subname { $_[0]->[DEDUCED]->[SUBNAME] } + +sub run { + my $self = shift; + my @args = @_; + + $self->[CODEREF]->(@args); +} + +sub detail { + my $self = shift; + + my $name = $self->[NAME]; + my $file = $self->file; + + my $start = $self->start_line; + my $end = $self->end_line; + + my $lines; + if ($end && $end != $start) { + $lines = "lines $start -> $end"; + } + elsif ($end) { + $lines = "line $start"; + } + else { + my ($dpkg, $dfile, $dline) = @{$self->caller}; + $lines = "line $start (declared in $dfile line $dline)"; + } + + my $known = ""; + if ($self->[DEDUCED]->[SUBNAME] ne '__ANON__') { + $known = " (" . $self->[DEDUCED]->[SUBNAME] . ")"; + } + + return "${name}${known} in ${file} ${lines}"; +} + +sub start_line { + my $self = shift; + return $self->[_START_LINE] if $self->[_START_LINE]; + + my $start = $self->[DEDUCED]->[LINE]; + my $end = $self->end_line || 0; + + if ($start == $end || $start == 1) { + $self->[_START_LINE] = $start; + } + else { + $self->[_START_LINE] = $start - 1; + } + + return $self->[_START_LINE]; +} + +sub end_line { + my $self = shift; + return $self->[_END_LINE] if $self->[_END_LINE]; + + my $call = $self->[CALLER]; + my $dedu = $self->[DEDUCED]; + + _map_package_file($dedu->[PACKAGE], $dedu->[FILE]); + + # Check if caller and deduced seem to be from the same place. + my $match = $call->[PACKAGE] eq $dedu->[PACKAGE]; + $match &&= $call->[FILE] eq $dedu->[FILE]; + $match &&= $call->[LINE] >= $dedu->[LINE]; + $match &&= !_check_interrupt($dedu->[FILE], $dedu->[LINE], $call->[LINE]); + + if ($match) { + $self->[_END_LINE] = $call->[LINE]; + return $call->[LINE]; + } + + # Uhg, see if we can figure it out. + my @lines = sort { $a <=> $b } keys %{$SUB_MAPS{$dedu->[FILE]}}; + for my $line (@lines) { + next if $line <= $dedu->[LINE]; + $self->[_END_LINE] = $line; + $self->[_END_LINE] -= 2 unless $SUB_MAPS{$dedu->[FILE]}->{$line} eq '__EOF__'; + return $self->[_END_LINE]; + } + + return undef; +} + +sub _check_interrupt { + my ($file, $start, $end) = @_; + return 0 if $start == $end; + + my @lines = sort { $a <=> $b } keys %{$SUB_MAPS{$file}}; + + for my $line (@lines) { + next if $line <= $start; + return $line <= $end; + } + + return 0; +} + +my %MAPPED; +sub _map_package_file { + my ($pkg, $file) = @_; + + return if $MAPPED{$pkg}->{$file}++; + + require B; + + my %seen; + my @symbols = do { no strict 'refs'; %{"$pkg\::"} }; + for my $sym (@symbols) { + my $code = $pkg->can($sym) || next; + next if $seen{$code}++; + + my $cobj = B::svref_2object($code); + + # Skip imported subs + my $pname = $cobj->GV->STASH->NAME; + next unless $pname eq $pkg; + + my $f = $cobj->FILE; + next unless $f eq $file; + + # Skip XS/C Files + next if $file =~ m/\.c$/; + next if $file =~ m/\.xs$/; + + my $line = $cobj->START->line; + $SUB_MAPS{$file}->{$line} ||= $sym; + } + + if (open(my $fh, '<', $file)) { + my $length = () = <$fh>; + close($fh); + $SUB_MAPS{$file}->{$length} = '__EOF__'; + } +} + +1; diff --git a/cpan/Test-Simple/lib/Test/Stream/Context.pm b/cpan/Test-Simple/lib/Test/Stream/Context.pm index 333fe4f..d2aaf10 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Context.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Context.pm @@ -28,6 +28,8 @@ Test::Stream::Exporter->cleanup(); my @TODO; my $CURRENT; +sub from_end_block { 0 }; + sub init { $_[0]->[FRAME] ||= _find_context(1); # +1 for call to init $_[0]->[STREAM] ||= Test::Stream->shared; @@ -262,6 +264,31 @@ sub send { $self->[STREAM]->send(@_); } +sub subtest_start { + my $self = shift; + my ($name, %params) = @_; + + $params{parent_todo} ||= $self->in_todo; + + $self->clear; + my $todo = $self->hide_todo; + + my $st = $self->stream->subtest_start($name, todo_stash => $todo, %params); + return $st; +} + +sub subtest_stop { + my $self = shift; + my ($name) = @_; + + my $st = $self->stream->subtest_stop($name); + + $self->set; + $self->restore_todo($st->{todo_stash}); + + return $st; +} + # Uhg.. support legacy monkeypatching # If this is still here in 2020 I will be a sad panda. { @@ -533,7 +560,7 @@ Get the current context object, if there is one. =item $ctx->set -=item $cclass->set($ctx) +=item $class->set($ctx) Set the context object as the current one, replacing any that might already be current. @@ -562,6 +589,20 @@ ref used by the package, so please do not alter it. These are used to temporarily hide the TODO value in ALL places where it might be found. The returned C<$stash> must be used to restore it later. +=item $stash = $ctx->subtest_start($name, %params) + +=item $stash = $ctx->subtest_stop($name) + +Used to start and stop subtests in the test stream. The stash can be used to +configure and manipulate the subtest information. C<subtest_start> will hide +the current TODO settings, and unset the current context. C<subtest_stop> will +restore the TODO and reset the context back to what it was. + +B<It is your job> to take the results in the stash and produce a +L<Test::Stream::Event::Subtest> event from them. + +B<Using this directly is not recommended>. + =back =head2 CLASS METHODS diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm index 696c70d..0e12c0c 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Diag.pm @@ -12,6 +12,7 @@ use Scalar::Util qw/weaken/; use Test::Stream::Carp qw/confess/; sub init { + $_[0]->SUPER::init(); $_[0]->[MESSAGE] = 'undef' unless defined $_[0]->[MESSAGE]; weaken($_[0]->[LINKED]) if $_[0]->[LINKED]; } diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Note.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Note.pm index 91185f0..263b08c 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Note.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Note.pm @@ -10,6 +10,7 @@ use Test::Stream::Event( use Test::Stream::Carp qw/confess/; sub init { + $_[0]->SUPER::init(); $_[0]->[MESSAGE] = 'undef' unless defined $_[0]->[MESSAGE]; } diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm index bfc614b..2390638 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Ok.pm @@ -17,6 +17,8 @@ sub todo { $_[0]->[CONTEXT]->todo } sub init { my $self = shift; + $self->SUPER::init(); + # Do not store objects here, only true/false/undef if ($self->[REAL_BOOL]) { $self->[REAL_BOOL] = 1; diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm index 84be2a0..7467b99 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Plan.pm @@ -15,6 +15,8 @@ my %ALLOWED = ( ); sub init { + $_[0]->SUPER::init(); + if ($_[0]->[DIRECTIVE]) { $_[0]->[DIRECTIVE] = 'SKIP' if $_[0]->[DIRECTIVE] eq 'skip_all'; $_[0]->[DIRECTIVE] = 'NO PLAN' if $_[0]->[DIRECTIVE] eq 'no_plan'; @@ -29,8 +31,6 @@ sub init { confess "No number of tests specified" unless defined $_[0]->[MAX]; - - } } diff --git a/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm b/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm index f29636a..ce6ec32 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Event/Subtest.pm @@ -8,29 +8,23 @@ use Test::Stream qw/-internal STATE_PASSING STATE_COUNT STATE_FAILED STATE_PLAN/ use Test::Stream::Event( base => 'Test::Stream::Event::Ok', - accessors => [qw/state events exception/], + accessors => [qw/state events exception early_return delayed instant/], ); -sub subevents { - return ( - @{$_[0]->[DIAG] || []}, - map { $_, $_->subevents } @{$_[0]->[EVENTS] || []}, - ); -} - sub init { my $self = shift; + $self->[EVENTS] ||= []; + + $self->[REAL_BOOL] = $self->[STATE]->[STATE_PASSING] && $self->[STATE]->[STATE_COUNT]; - if ($self->[EXCEPTION] && !(blessed($self->[EXCEPTION]) && $self->[EXCEPTION]->isa('Test::Stream::Event'))) { + if ($self->[EXCEPTION]) { push @{$self->[DIAG]} => "Exception in subtest '$self->[NAME]': $self->[EXCEPTION]"; $self->[STATE]->[STATE_PASSING] = 0; $self->[BOOL] = 0; + $self->[REAL_BOOL] = 0; } - $self->[REAL_BOOL] = $self->[STATE]->[STATE_PASSING] && $self->[STATE]->[STATE_COUNT]; - $self->[EVENTS] ||= []; - - if (my $le = $self->[EXCEPTION]) { + if (my $le = $self->[EARLY_RETURN]) { my $is_skip = $le->isa('Test::Stream::Event::Plan'); $is_skip &&= $le->directive; $is_skip &&= $le->directive eq 'SKIP'; @@ -41,17 +35,30 @@ sub init { $self->[CONTEXT]->set_skip($skip); $self->[REAL_BOOL] = 1; } + else { # BAILOUT + $self->[REAL_BOOL] = 0; + } } - push @{$self->[DIAG]} => ' No tests run for subtest.' - unless $self->[EXCEPTION] || $self->[STATE]->[STATE_COUNT]; + push @{$self->[DIAG]} => " No tests run for subtest." + unless $self->[EXCEPTION] || $self->[EARLY_RETURN] || $self->[STATE]->[STATE_COUNT]; + # Have the 'OK' init run $self->SUPER::init(); } +sub subevents { + return ( + @{$_[0]->[DIAG] || []}, + map { $_, $_->subevents } @{$_[0]->[EVENTS] || []}, + ); +} + sub to_tap { my $self = shift; - my ($num, $delayed) = @_; + my ($num) = @_; + + my $delayed = $self->[DELAYED]; unless($delayed) { return if $self->[EXCEPTION] @@ -64,7 +71,7 @@ sub to_tap { $self->[NAME] =~ s/$/ {/mg; my @out = ( $self->SUPER::to_tap($num), - $self->_render_events(@_), + $self->_render_events($num), [OUT_STD, "}\n"], ); $self->[NAME] =~ s/ \{$//mg; @@ -73,7 +80,9 @@ sub to_tap { sub _render_events { my $self = shift; - my ($num, $delayed) = @_; + my ($num) = @_; + + my $delayed = $self->[DELAYED]; my $idx = 0; my @out; diff --git a/cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm b/cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm index 599631e..babad93 100644 --- a/cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm +++ b/cpan/Test-Simple/lib/Test/Stream/ExitMagic/Context.pm @@ -13,6 +13,8 @@ sub init { sub snapshot { $_[0] } +sub from_end_block { 1 }; + 1; __END__ diff --git a/cpan/Test-Simple/lib/Test/Stream/Subtest.pm b/cpan/Test-Simple/lib/Test/Stream/Subtest.pm index 39533e4..06016d2 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Subtest.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Subtest.pm @@ -9,6 +9,9 @@ Test::Stream::Exporter->cleanup; use Test::Stream::Context qw/context/; use Scalar::Util qw/reftype blessed/; use Test::Stream::Util qw/try/; +use Test::Stream::Carp qw/confess/; + +use Test::Stream::Block; sub subtest { my ($name, $code, @args) = @_; @@ -18,23 +21,24 @@ sub subtest { $ctx->throw("subtest()'s second argument must be a code ref") unless $code && 'CODE' eq reftype($code); - $ctx->child('push', $name); - $ctx->clear; - my $todo = $ctx->hide_todo; + my $block = Test::Stream::Block->new( + $name, $code, undef, [caller(0)], + ); - my $pid = $$; + $ctx->note("Subtest: $name") + if $ctx->stream->subtest_tap_instant; - my ($succ, $err) = try { - my $early_return = 1; + my $st = $ctx->subtest_start($name); + my $pid = $$; + my ($succ, $err) = try { TEST_STREAM_SUBTEST: { no warnings 'once'; local $Test::Builder::Level = 1; - $code->(@args); - $early_return = 0; + $block->run(@args); } - die $ctx->stream->subtest_exception->[-1] if $early_return; + return if $st->{early_return}; $ctx->set; my $stream = $ctx->stream; @@ -47,32 +51,54 @@ sub subtest { } }; - if ($$ != $pid && !$ctx->stream->_use_fork) { - warn <<" EOT"; + my $er = $st->{early_return}; + if (!$succ) { + # Early return is not a *real* exception. + if ($er && $er == $err) { + $succ = 1; + $err = undef; + } + else { + $st->{exception} = $err; + } + } + + if ($$ != $pid) { + warn <<" EOT" unless $ctx->stream->_use_fork; Subtest finished with a new PID ($$ vs $pid) while forking support was turned off! This is almost certainly not what you wanted. Did you fork and forget to exit? EOT # Did the forked process try to exit via die? + # If a subtest forked, then threw an exception, we need to propogate that right away. die $err unless $succ; } - # If a subtest forked, then threw an exception, we need to propogate that right away. - die $err unless $succ || $$ == $pid || $err->isa('Test::Stream::Event'); + my $st_check = $ctx->subtest_stop($name); + confess "Subtest mismatch!" unless $st == $st_check; - $ctx->set; - $ctx->restore_todo($todo); - $ctx->stream->subtest_exception->[-1] = $err unless $succ; + $ctx->bail($st->{early_return}->reason) if $er && $er->isa('Test::Stream::Event::Bail'); - # This sends the subtest event - my $st = $ctx->child('pop', $name); + my $e = $ctx->subtest( + # Stuff from ok (most of this gets initialized inside) + undef, # real_bool, gets set properly by initializer + $st->{name}, # name + undef, # diag + undef, # bool + undef, # level - unless ($succ) { - die $err unless blessed($err) && $err->isa('Test::Stream::Event'); - $ctx->bail($err->reason) if $err->isa('Test::Stream::Event::Bail'); - } + # Subtest specific stuff + $st->{state}, + $st->{events}, + $st->{exception}, + $st->{early_return}, + $st->{delayed}, + $st->{instant}, + ); + + die $err unless $succ; - return $st->bool; + return $e->bool; } 1; diff --git a/cpan/Test-Simple/lib/Test/Stream/Toolset.pm b/cpan/Test-Simple/lib/Test/Stream/Toolset.pm index c3910d2..1a2ad03 100644 --- a/cpan/Test-Simple/lib/Test/Stream/Toolset.pm +++ b/cpan/Test-Simple/lib/Test/Stream/Toolset.pm @@ -8,7 +8,6 @@ use Test::Stream::Carp qw/carp/; # Preload these so the autoload is not necessary use Test::Stream::Event::Bail; -use Test::Stream::Event::Child; use Test::Stream::Event::Diag; use Test::Stream::Event::Finish; use Test::Stream::Event::Note; @@ -227,8 +226,6 @@ this event to stop everything and print the reason. =item L<Test::Stream::Event::Finish> -=item L<Test::Stream::Event::Child> - =item L<Test::Stream::Event::Subtest> These are not intended for public use, but are documented for completeness. diff --git a/cpan/Test-Simple/lib/Test/Tester.pm b/cpan/Test-Simple/lib/Test/Tester.pm index 072ea77..deb192c 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_090'; +our $VERSION = '1.301001_093'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) @EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); @@ -573,7 +573,7 @@ variable also works (if both are set then the British spelling wins out). =head1 EXPORTED FUNCTIONS -=head3 ($premature, @results) = run_tests(\&test_sub) +=head2 ($premature, @results) = run_tests(\&test_sub) \&test_sub is a reference to a subroutine. @@ -586,7 +586,7 @@ the first test. @results is an array of test result hashes. -=head3 cmp_result(\%result, \%expect, $name) +=head2 cmp_result(\%result, \%expect, $name) \%result is a ref to a test result hash. @@ -596,7 +596,7 @@ cmp_result compares the result with the expected values. If any differences are found it outputs diagnostics. You may leave out any field from the expected result and cmp_result will not do the comparison of that field. -=head3 cmp_results(\@results, \@expects, $name) +=head2 cmp_results(\@results, \@expects, $name) \@results is a ref to an array of test results. @@ -608,7 +608,7 @@ number of elements in \@results and \@expects is the same. Then it goes through each result checking it against the expected result as in cmp_result() above. -=head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name) +=head2 ($premature, @results) = check_tests(\&test_sub, \@expects, $name) \&test_sub is a reference to a subroutine. @@ -620,7 +620,7 @@ checks if the tests died at any stage. It returns the same values as run_tests, so you can further examine the test results if you need to. -=head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name) +=head2 ($premature, @results) = check_test(\&test_sub, \%expect, $name) \&test_sub is a reference to a subroutine. @@ -634,7 +634,7 @@ make sure this is true. It returns the same values as run_tests, so you can further examine the test results if you need to. -=head3 show_space() +=head2 show_space() Turn on the escaping of characters as described in the SPACES AND TABS section. diff --git a/cpan/Test-Simple/lib/Test/use/ok.pm b/cpan/Test-Simple/lib/Test/use/ok.pm index 27d4721..d241554 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_090'; +our $VERSION = '1.301001_093'; $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 db4995a..d1b2341 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_090'; +our $VERSION = '1.301001_093'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) sub import { diff --git a/cpan/Test-Simple/t/Test-Stream-API.t b/cpan/Test-Simple/t/Test-Stream-API.t index 7ad57ee..318af7e 100644 --- a/cpan/Test-Simple/t/Test-Stream-API.t +++ b/cpan/Test-Simple/t/Test-Stream-API.t @@ -97,7 +97,6 @@ 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; diff --git a/cpan/Test-Simple/t/Test-Stream-Block.t b/cpan/Test-Simple/t/Test-Stream-Block.t new file mode 100644 index 0000000..e181024 --- /dev/null +++ b/cpan/Test-Simple/t/Test-Stream-Block.t @@ -0,0 +1,108 @@ +use strict; +use warnings; + +use Test::More; + +use ok 'Test::Stream::Block'; + +our %BLOCKS; +our %STARTS; +our %ENDS; + +is(keys %BLOCKS, 6, "created 6 blocks"); + +isa_ok($_, 'Test::Stream::Block') for values %BLOCKS; + +is($BLOCKS{one}->start_line, $STARTS{one}, "got start line for block one"); +is($BLOCKS{one}->end_line, $STARTS{two} - 1, "got end line for block one"); + +is($BLOCKS{two}->start_line, $STARTS{two}, "got start line for block two"); +is($BLOCKS{two}->end_line, $ENDS{two}, "got end line for block two"); + +ok($BLOCKS{three}->start_line > $ENDS{two}, "got start line for block three"); +ok($BLOCKS{three}->end_line < $STARTS{four}, "got end line for block three"); + +is($BLOCKS{four}->start_line, $STARTS{four}, "got start line for block four"); +is($BLOCKS{four}->end_line, $STARTS{four}, "got end line for block four"); + +is($BLOCKS{five}->start_line, $STARTS{five}, "got start line for block five"); +is($BLOCKS{five}->end_line, $ENDS{EOF}, "got end line for block five"); + +is( + $BLOCKS{one}->detail, + 'one (block_one) in ' . __FILE__ . " lines $STARTS{one} -> " . ($STARTS{two} - 1), + "Got expected detail for multiline" +); + +is( + $BLOCKS{four}->detail, + 'four in ' . __FILE__ . " line $STARTS{four}", + "Got expected detail for single line" +); + +like( + $BLOCKS{foo}->detail, + qr/foo \(foo\) in \(eval \d+\) line 2 \(declared in \(eval \d+\) line 1\)/, + "Got expected detail for endless sub" +); + +done_testing; + +BEGIN { + package TheTestPackage; + + sub build_block { + my $name = shift; + my $code = pop; + my %params = @_; + my @caller = caller; + + $main::BLOCKS{$name} = Test::Stream::Block->new_from_pairs( + name => $name, + params => \%params, + coderef => $code, + caller => \@caller, + ); + } + + build_block five => \&block_five; + + BEGIN {$main::STARTS{one} = __LINE__ + 1} + sub block_one { + my $x = 1; + my $y = 1; + return "one: " . $x + $y; + } + + build_block two => sub { + my $x = 1; BEGIN {$main::STARTS{two} = __LINE__ - 1} + my $y = 1; + return "three: " . $x + $y; + }; + BEGIN {$main::ENDS{two} = __LINE__ - 1} + + sub block_three { return "three: 2" } BEGIN {$main::STARTS{three} = __LINE__} + + BEGIN {$main::STARTS{four} = __LINE__ + 1} + build_block four => sub { return "four: 2" }; + + BEGIN {$main::STARTS{five} = __LINE__ + 1} + sub block_five { + my $x = 1; + my $y = 1; + return "five: " . $x + $y; + } + + build_block one => \&block_one; + build_block three => (this_is => 3, \&block_three); + + package Foo; + eval <<' EOT' || die $@; + TheTestPackage::build_block foo => \&foo; + sub foo { + 'foo' + }; + 1 + EOT +} +BEGIN {$main::ENDS{EOF} = __LINE__} diff --git a/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm b/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm index bbdf732..7c6bb69 100644 --- a/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm +++ b/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm @@ -26,7 +26,7 @@ Test::Builder::NoOutput - A subclass of Test::Builder which prints nothing This is a subclass of Test::Builder which traps all its output. It is mostly useful for testing Test::Builder. -=head3 read +=head2 read my $all_output = $tb->read; my $output = $tb->read($stream); -- Perl5 Master Repository
