diff options
| author | Steve Hay <steve.m.hay@googlemail.com> | 2017-10-02 14:03:48 +0100 |
|---|---|---|
| committer | Steve Hay <steve.m.hay@googlemail.com> | 2017-10-03 08:56:11 +0100 |
| commit | 07bc328a0524ea51d473545282321341bcd61e03 (patch) | |
| tree | b7f274428d34df1ad82f3f6ef2969b1d9e14fb18 /cpan/Test-Simple/lib/Test2 | |
| parent | 9995b99e160dcf6aabd893a490cbc95bc736f00f (diff) | |
| download | perl-07bc328a0524ea51d473545282321341bcd61e03.tar.gz | |
Upgrade Test-Simple from version 1.302073 to 1.302096
(includes regen/lib_cleanup.pl)
Diffstat (limited to 'cpan/Test-Simple/lib/Test2')
48 files changed, 3507 insertions, 1035 deletions
diff --git a/cpan/Test-Simple/lib/Test2/API.pm b/cpan/Test-Simple/lib/Test2/API.pm index 41cd0af209..e43a0d6c57 100644 --- a/cpan/Test-Simple/lib/Test2/API.pm +++ b/cpan/Test-Simple/lib/Test2/API.pm @@ -2,12 +2,14 @@ package Test2::API; use strict; use warnings; +use Test2::Util qw/USE_THREADS/; + BEGIN { $ENV{TEST_ACTIVE} ||= 1; $ENV{TEST2_ACTIVE} = 1; } -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; my $INST; @@ -16,12 +18,23 @@ sub test2_set_is_end { ($ENDING) = @_ ? @_ : (1) } sub test2_get_is_end { $ENDING } use Test2::API::Instance(\$INST); + # Set the exit status END { test2_set_is_end(); # See gh #16 $INST->set_exit(); } +sub CLONE { + my $init = test2_init_done(); + my $load = test2_load_done(); + + return if $init && $load; + + require Carp; + Carp::croak "Test2 must be fully loaded before you start a new thread!\n"; +} + # See gh #16 { no warnings; @@ -38,7 +51,8 @@ BEGIN { } } -use Test2::Util::Trace(); +use Test2::EventFacet::Trace(); +use Test2::Util::Trace(); # Legacy use Test2::Hub::Subtest(); use Test2::Hub::Interceptor(); @@ -56,17 +70,21 @@ use Test2::Event::Subtest(); use Carp qw/carp croak confess longmess/; use Scalar::Util qw/blessed weaken/; -use Test2::Util qw/get_tid/; +use Test2::Util qw/get_tid clone_io pkg_to_file/; our @EXPORT_OK = qw{ context release context_do no_context - intercept + intercept intercept_deep run_subtest test2_init_done test2_load_done + test2_load + test2_start_preload + test2_stop_preload + test2_in_preload test2_set_is_end test2_get_is_end @@ -97,12 +115,18 @@ our @EXPORT_OK = qw{ test2_ipc_enable_polling test2_ipc_get_pending test2_ipc_set_pending + test2_ipc_get_timeout + test2_ipc_set_timeout test2_ipc_enable_shm test2_formatter test2_formatters test2_formatter_add test2_formatter_set + + test2_stdout + test2_stderr + test2_reset_io }; BEGIN { require Exporter; our @ISA = qw(Exporter) } @@ -111,9 +135,29 @@ my $CONTEXTS = $INST->contexts; my $INIT_CBS = $INST->context_init_callbacks; my $ACQUIRE_CBS = $INST->context_acquire_callbacks; +my $STDOUT = clone_io(\*STDOUT); +my $STDERR = clone_io(\*STDERR); +sub test2_stdout { $STDOUT ||= clone_io(\*STDOUT) } +sub test2_stderr { $STDERR ||= clone_io(\*STDERR) } + +sub test2_post_preload_reset { + test2_reset_io(); + $INST->post_preload_reset; +} + +sub test2_reset_io { + $STDOUT = clone_io(\*STDOUT); + $STDERR = clone_io(\*STDERR); +} + sub test2_init_done { $INST->finalized } sub test2_load_done { $INST->loaded } +sub test2_load { $INST->load } +sub test2_start_preload { $ENV{T2_IN_PRELOAD} = 1; $INST->start_preload } +sub test2_stop_preload { $ENV{T2_IN_PRELOAD} = 0; $INST->stop_preload } +sub test2_in_preload { $INST->preload } + sub test2_pid { $INST->pid } sub test2_tid { $INST->tid } sub test2_stack { $INST->stack } @@ -143,9 +187,21 @@ sub test2_ipc_enable_polling { $INST->enable_ipc_polling } sub test2_ipc_disable_polling { $INST->disable_ipc_polling } sub test2_ipc_get_pending { $INST->get_ipc_pending } sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) } +sub test2_ipc_set_timeout { $INST->set_ipc_timeout(@_) } +sub test2_ipc_get_timeout { $INST->ipc_timeout() } sub test2_ipc_enable_shm { $INST->ipc_enable_shm } -sub test2_formatter { $INST->formatter } +sub test2_formatter { + if ($ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { + my $formatter = $1 ? $2 : "Test2::Formatter::$2"; + my $file = pkg_to_file($formatter); + require $file; + return $formatter; + } + + return $INST->formatter; +} + sub test2_formatters { @{$INST->formatters} } sub test2_formatter_add { $INST->add_formatter(@_) } sub test2_formatter_set { @@ -207,6 +263,7 @@ sub no_context(&;$) { return; }; +my $CID = 1; sub context { # We need to grab these before anything else to ensure they are not # changed. @@ -283,11 +340,15 @@ sub context { # hit with how often this needs to be called. my $trace = bless( { - frame => [$pkg, $file, $line, $sub], - pid => $$, - tid => get_tid(), + frame => [$pkg, $file, $line, $sub], + pid => $$, + tid => get_tid(), + cid => 'C' . $CID++, + hid => $hid, + nested => $hub->{nested}, + buffered => $hub->{buffered}, }, - 'Test2::Util::Trace' + 'Test2::EventFacet::Trace' ); # Directly bless the object here, calling new is a noticeable performance @@ -374,7 +435,29 @@ sub release($;$) { sub intercept(&) { my $code = shift; + my $ctx = context(); + + my $events = _intercept($code, deep => 0); + + $ctx->release; + + return $events; +} + +sub intercept_deep(&) { + my $code = shift; + my $ctx = context(); + + my $events = _intercept($code, deep => 1); + $ctx->release; + + return $events; +} + +sub _intercept { + my $code = shift; + my %params = @_; my $ctx = context(); my $ipc; @@ -389,7 +472,7 @@ sub intercept(&) { ); my @events; - $hub->listen(sub { push @events => $_[1] }); + $hub->listen(sub { push @events => $_[1] }, inherit => $params{deep}); $ctx->stack->top; # Make sure there is a top hub before we begin. $ctx->stack->push($hub); @@ -427,23 +510,26 @@ sub run_subtest { my ($name, $code, $params, @args) = @_; $params = {buffered => $params} unless ref $params; - my $buffered = delete $params->{buffered}; my $inherit_trace = delete $params->{inherit_trace}; my $ctx = context(); - $ctx->note($name) unless $buffered; - my $parent = $ctx->hub; + # If a parent is buffered then the child must be as well. + my $buffered = $params->{buffered} || $parent->{buffered}; + + $ctx->note($name) unless $buffered; + my $stack = $ctx->stack || $STACK; my $hub = $stack->new_hub( class => 'Test2::Hub::Subtest', + buffered => $buffered, %$params, + buffered => $buffered, ); my @events; - $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 ); $hub->listen(sub { push @events => $_[1] }); if ($buffered) { @@ -452,14 +538,6 @@ sub run_subtest { $hub->format(undef) if $hide; } } - elsif (! $parent->format) { - # If our parent has no format that means we're in a buffered subtest - # and now we're trying to run a streaming subtest. There's really no - # way for that to work, so we need to force the use of a buffered - # subtest here as - # well. https://github.com/Test-More/test-more/issues/721 - $buffered = 1; - } if ($inherit_trace) { my $orig = $code; @@ -487,20 +565,44 @@ sub run_subtest { $finished = 1; } } + + if ($params->{no_fork}) { + if ($$ != $ctx->trace->pid) { + warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; + exit 255; + } + + if (get_tid() != $ctx->trace->tid) { + warn $ok ? "Started new thread inside subtest, but thread never finished!\n" : $err; + exit 255; + } + } + elsif (!$parent->is_local && !$parent->ipc) { + warn $ok ? "A new process or thread was started inside subtest, but IPC is not enabled!\n" : $err; + exit 255; + } + $stack->pop($hub); my $trace = $ctx->trace; + my $bailed = $hub->bailed_out; + if (!$finished) { - if(my $bailed = $hub->bailed_out) { + if ($bailed && !$buffered) { $ctx->bail($bailed->reason); } - my $code = $hub->exit_code; - $ok = !$code; - $err = "Subtest ended with exit code $code" if $code; + elsif ($bailed && $buffered) { + $ok = 1; + } + else { + my $code = $hub->exit_code; + $ok = !$code; + $err = "Subtest ended with exit code $code" if $code; + } } - $hub->finalize($trace, 1) + $hub->finalize($trace->snapshot(hid => $hub->hid, nested => $hub->nested, buffered => $buffered), 1) if $ok && !$hub->no_ending && !$hub->ended; @@ -526,6 +628,8 @@ sub run_subtest { $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count) if defined($plan_ok) && !$plan_ok; + $ctx->bail($bailed->reason) if $bailed && $buffered; + $ctx->release; return $pass; } @@ -618,6 +722,35 @@ generated by the test system: my_ok($events->[0]->pass, "first event passed"); my_ok(!$events->[1]->pass, "second event failed"); +=head3 DEEP EVENT INTERCEPTION + +Normally C<intercept { ... }> only intercepts events sent to the main hub (as +added by intercept itself). Nested hubs, such as those created by subtests, +will not be intercepted. This is normally what you will still see the nested +events by inspecting the subtest event. However there are times where you want +to verify each event as it is sent, in that case use C<intercept_deep { ... }>. + + my $events = intercept_Deep { + buffered_subtest foo => sub { + ok(1, "pass"); + }; + }; + +C<$events> in this case will contain 3 items: + +=over 4 + +=item The event from C<ok(1, "pass")> + +=item The plan event for the subtest + +=item The subtest event itself, with the first 2 events nested inside it as children. + +=back + +This lets you see the order in which the events were sent, unlike +C<intercept { ... }> which only lets you see events as the main hub sees them. + =head2 OTHER API FUNCTIONS use Test2::API qw{ @@ -958,6 +1091,12 @@ created for the hub that shares the same trace as the current context. Set this to true if your tool is producing subtests without user-specified subs. +=item 'no_fork' => $bool + +Defaults to off. Normally forking inside a subtest will actually fork the +subtest, resulting in 2 final subtest events. This parameter will turn off that +behavior, only the original process/thread will return a final subtest event. + =back =item @ARGS @@ -1213,6 +1352,15 @@ This returns 0 if there are (most likely) no pending events. This returns 1 if there are (likely) pending events. Upon return it will reset, nothing else will be able to see that there were pending events. +=item $timeout = test2_ipc_get_timeout() + +=item test2_ipc_set_timeout($timeout) + +Get/Set the timeout value for the IPC system. This timeout is how long the IPC +system will wait for child processes and threads to finish before aborting. + +The default value is C<30> seconds. + =back =head2 MANAGING FORMATTERS @@ -1300,7 +1448,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/API/Breakage.pm b/cpan/Test-Simple/lib/Test2/API/Breakage.pm index b85e4d54c9..f97984f129 100644 --- a/cpan/Test-Simple/lib/Test2/API/Breakage.pm +++ b/cpan/Test-Simple/lib/Test2/API/Breakage.pm @@ -2,7 +2,7 @@ package Test2::API::Breakage; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Test2::Util qw/pkg_to_file/; @@ -31,7 +31,12 @@ sub upgrade_required { 'Test::SharedFork' => '0.34', 'Test::Alien' => '0.04', 'Test::UseAllModules' => '0.14', + 'Test::More::Prefix' => '0.005', + 'Test2::Tools::EventDumper' => 0.000007, + 'Test2::Harness' => 0.000013, + + 'Test::DBIx::Class::Schema' => '1.0.9', 'Test::Clustericious::Cluster' => '0.30', ); } @@ -43,12 +48,10 @@ sub known_broken { 'Test::Aggregate' => '0.373', 'Test::Flatten' => '0.11', 'Test::Group' => '0.20', - 'Test::More::Prefix' => '0.005', 'Test::ParallelSubtest' => '0.05', 'Test::Pretty' => '0.32', 'Test::Wrapper' => '0.3.0', - 'Test::DBIx::Class::Schema' => '1.0.9', 'Log::Dispatch::Config::TestLog' => '0.02', ); } @@ -165,7 +168,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/API/Context.pm b/cpan/Test-Simple/lib/Test2/API/Context.pm index 7660fa69ea..db803c03c6 100644 --- a/cpan/Test-Simple/lib/Test2/API/Context.pm +++ b/cpan/Test-Simple/lib/Test2/API/Context.pm @@ -2,14 +2,14 @@ package Test2::API::Context; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Carp qw/confess croak longmess/; use Scalar::Util qw/weaken blessed/; use Test2::Util qw/get_tid try pkg_to_file get_tid/; -use Test2::Util::Trace(); +use Test2::EventFacet::Trace(); use Test2::API(); # Preload some key event types @@ -19,7 +19,7 @@ my %LOADED = ( my $file = "Test2/Event/$_.pm"; require $file unless $INC{$file}; ( $pkg => $pkg, $_ => $pkg ) - } qw/Ok Diag Note Info Plan Bail Exception Waiting Skip Subtest/ + } qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest Pass Fail/ ); use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; @@ -155,9 +155,7 @@ sub do_in_context { # We need to update the pid/tid and error vars. my $clone = $self->snapshot; @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?); - $clone->{+TRACE} = $clone->{+TRACE}->snapshot; - $clone->{+TRACE}->set_pid($$); - $clone->{+TRACE}->set_tid(get_tid()); + $clone->{+TRACE} = $clone->{+TRACE}->snapshot(pid => $$, tid => get_tid()); my $hub = $clone->{+HUB}; my $hid = $hub->hid; @@ -202,6 +200,13 @@ sub alert { $self->trace->alert($msg); } +sub send_event_and_release { + my $self = shift; + my $out = $self->send_event(@_); + $self->release; + return $out; +} + sub send_event { my $self = shift; my $event = shift; @@ -209,12 +214,19 @@ sub send_event { my $pkg = $LOADED{$event} || $self->_parse_event($event); - my $e = $pkg->new( - trace => $self->{+TRACE}->snapshot, - %args, - ); + my $e; + { + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $e = $pkg->new( + trace => $self->{+TRACE}->snapshot, + %args, + ); + } - ${$self->{+_ABORTED}}++ if $self->{+_ABORTED} && defined $e->terminate; + if ($self->{+_ABORTED}) { + my $f = $e->facet_data; + ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); + } $self->{+HUB}->send($e); } @@ -225,12 +237,81 @@ sub build_event { my $pkg = $LOADED{$event} || $self->_parse_event($event); + local $Carp::CarpLevel = $Carp::CarpLevel + 1; $pkg->new( trace => $self->{+TRACE}->snapshot, %args, ); } +sub pass { + my $self = shift; + my ($name) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Pass" + ); + + $self->{+HUB}->send($e); + return $e; +} + +sub pass_and_release { + my $self = shift; + my ($name) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Pass" + ); + + $self->{+HUB}->send($e); + $self->release; + return 1; +} + +sub fail { + my $self = shift; + my ($name, @diag) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Fail" + ); + + $e->add_info({tag => 'DIAG', debug => 1, details => $_}) for @diag; + $self->{+HUB}->send($e); + return $e; +} + +sub fail_and_release { + my $self = shift; + my ($name, @diag) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Fail" + ); + + $e->add_info({tag => 'DIAG', debug => 1, details => $_}) for @diag; + $self->{+HUB}->send($e); + $self->release; + return 0; +} + sub ok { my $self = shift; my ($pass, $name, $on_fail) = @_; @@ -238,7 +319,7 @@ sub ok { my $hub = $self->{+HUB}; my $e = bless { - trace => bless( {%{$self->{+TRACE}}}, 'Test2::Util::Trace'), + trace => bless( {%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), pass => $pass, name => $name, }, 'Test2::Event::Ok'; @@ -250,14 +331,7 @@ sub ok { $self->failure_diag($e); if ($on_fail && @$on_fail) { - for my $of (@$on_fail) { - if (ref($of) eq 'CODE' || (blessed($of) && $of->can('render'))) { - $self->info($of, diagnostics => 1); - } - else { - $self->diag($of); - } - } + $self->diag($_) for @$on_fail; } return $e; @@ -267,13 +341,6 @@ sub failure_diag { my $self = shift; my ($e) = @_; - # This behavior is inherited from Test::Builder which injected a newline at - # the start of the first diagnostics when the harness is active, but not - # verbose. This is important to keep the diagnostics from showing up - # appended to the existing line, which is hard to read. In a verbose - # harness there is no need for this. - my $prefix = $ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_IS_VERBOSE} ? "\n" : ""; - # Figure out the debug info, this is typically the file name and line # number, but can also be a custom message. If no trace object is provided # then we have nothing useful to display. @@ -284,8 +351,8 @@ sub failure_diag { # Create the initial diagnostics. If the test has a name we put the debug # info on a second line, this behavior is inherited from Test::Builder. my $msg = defined($name) - ? qq[${prefix}Failed test '$name'\n$debug.\n] - : qq[${prefix}Failed test $debug.\n]; + ? qq[Failed test '$name'\n$debug.\n] + : qq[Failed test $debug.\n]; $self->diag($msg); } @@ -302,12 +369,6 @@ sub skip { ); } -sub info { - my $self = shift; - my ($renderer, %params) = @_; - $self->send_event('Info', renderer => $renderer, %params); -} - sub note { my $self = shift; my ($message) = @_; @@ -509,7 +570,7 @@ current one to which all events should be sent. =item $dbg = $ctx->trace() -This will return the L<Test2::Util::Trace> instance used by the context. +This will return the L<Test2::EventFacet::Trace> instance used by the context. =item $ctx->do_in_context(\&code, @args); @@ -555,23 +616,100 @@ The value of C<$@> when the context was created. =over 4 +=item $event = $ctx->pass() + +=item $event = $ctx->pass($name) + +This will send and return an L<Test2::Event::Pass> event. You may optionally +provide a C<$name> for the assertion. + +The L<Test2::Event::Pass> is a specially crafted and optimized event, using +this will help the performance of passing tests. + +=item $true = $ctx->pass_and_release() + +=item $true = $ctx->pass_and_release($name) + +This is a combination of C<pass()> and C<release()>. You can use this if you do +not plan to do anything with the context after sending the event. This helps +write more clear and compact code. + + sub shorthand { + my ($bool, $name) = @_; + my $ctx = context(); + return $ctx->pass_and_release($name) if $bool; + + ... Handle a failure ... + } + + sub longform { + my ($bool, $name) = @_; + my $ctx = context(); + + if ($bool) { + $ctx->pass($name); + $ctx->release; + return 1; + } + + ... Handle a failure ... + } + +=item my $event = $ctx->fail() + +=item my $event = $ctx->fail($name) + +=item my $event = $ctx->fail($name, @diagnostics) + +This lets you send an L<Test2::Event::Fail> event. You may optionally provide a +C<$name> and C<@diagnostics> messages. + +=item my $false = $ctx->fail_and_release() + +=item my $false = $ctx->fail_and_release($name) + +=item my $false = $ctx->fail_and_release($name, @diagnostics) + +This is a combination of C<fail()> and C<release()>. This can be used to write +clearer and shorter code. + + sub shorthand { + my ($bool, $name) = @_; + my $ctx = context(); + return $ctx->fail_and_release($name) unless $bool; + + ... Handle a success ... + } + + sub longform { + my ($bool, $name) = @_; + my $ctx = context(); + + unless ($bool) { + $ctx->pass($name); + $ctx->release; + return 1; + } + + ... Handle a success ... + } + + =item $event = $ctx->ok($bool, $name) =item $event = $ctx->ok($bool, $name, \@on_fail) +B<NOTE:> Use of this method is discouraged in favor of C<pass()> and C<fail()> +which produce L<Test2::Event::Pass> and L<Test2::Event::Fail> events. These +newer event types are faster and less crufty. + This will create an L<Test2::Event::Ok> object for you. If C<$bool> is false then an L<Test2::Event::Diag> event will be sent as well with details about the failure. If you do not want automatic diagnostics you should use the C<send_event()> method directly. The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in -the event of a test failure. Plain strings will be sent as -L<Test2::Event::Diag> events. References will be used to construct -L<Test2::Event::Info> events with C<< diagnostics => 1 >>. - -=item $event = $ctx->info($renderer, diagnostics => $bool, %other_params) - -Send an L<Test2::Event::Info>. +the event of a test failure. =item $event = $ctx->note($message) @@ -617,6 +755,22 @@ or This is the same as C<send_event()>, except it builds and returns the event without sending it. +=item $event = $ctx->send_event_and_release($Type, %parameters) + +This is a combination of C<send_event()> and C<release()>. + + sub shorthand { + my $ctx = context(); + return $ctx->send_event_and_release(Pass => { name => 'foo' }); + } + + sub longform { + my $ctx = context(); + my $event = $ctx->send_event(Pass => { name => 'foo' }); + $ctx->release; + return $event; + } + =back =head1 HOOKS @@ -729,7 +883,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/API/Instance.pm b/cpan/Test-Simple/lib/Test2/API/Instance.pm index 70d4cd7bb7..c9714581bf 100644 --- a/cpan/Test-Simple/lib/Test2/API/Instance.pm +++ b/cpan/Test-Simple/lib/Test2/API/Instance.pm @@ -2,16 +2,16 @@ package Test2::API::Instance; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; use Carp qw/confess carp/; use Scalar::Util qw/reftype/; -use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try/; +use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try CAN_SIGSYS/; -use Test2::Util::Trace(); +use Test2::EventFacet::Trace(); use Test2::API::Stack(); use Test2::Util::HashBase qw{ @@ -21,11 +21,14 @@ use Test2::Util::HashBase qw{ ipc stack formatter contexts + -preload + ipc_shm_size ipc_shm_last ipc_shm_id ipc_polling ipc_drivers + ipc_timeout formatters exit_callbacks @@ -35,8 +38,10 @@ use Test2::Util::HashBase qw{ context_release_callbacks }; -sub pid { $_[0]->{+_PID} ||= $$ } -sub tid { $_[0]->{+_TID} ||= get_tid() } +sub DEFAULT_IPC_TIMEOUT() { 30 } + +sub pid { $_[0]->{+_PID} } +sub tid { $_[0]->{+_TID} } # Wrap around the getters that should call _finalize. BEGIN { @@ -63,6 +68,46 @@ sub import { sub init { $_[0]->reset } +sub start_preload { + my $self = shift; + + confess "preload cannot be started, Test2::API has already been initialized" + if $self->{+FINALIZED} || $self->{+LOADED}; + + return $self->{+PRELOAD} = 1; +} + +sub stop_preload { + my $self = shift; + + return 0 unless $self->{+PRELOAD}; + $self->{+PRELOAD} = 0; + + $self->post_preload_reset(); + + return 1; +} + +sub post_preload_reset { + my $self = shift; + + delete $self->{+_PID}; + delete $self->{+_TID}; + + $self->{+CONTEXTS} = {}; + + $self->{+FORMATTERS} = []; + + $self->{+FINALIZED} = undef; + $self->{+IPC} = undef; + + $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; + + $self->{+LOADED} = 0; + + $self->{+STACK} ||= Test2::API::Stack->new; +} + sub reset { my $self = shift; @@ -80,6 +125,8 @@ sub reset { $self->{+FINALIZED} = undef; $self->{+IPC} = undef; + $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; + $self->{+NO_WAIT} = 0; $self->{+LOADED} = 0; @@ -97,6 +144,9 @@ sub _finalize { my ($caller) = @_; $caller ||= [caller(1)]; + confess "Attempt to initialize Test2::API during preload" + if $self->{+PRELOAD}; + $self->{+FINALIZED} = $caller; $self->{+_PID} = $$ unless defined $self->{+_PID}; @@ -227,6 +277,9 @@ sub add_post_load_callback { sub load { my $self = shift; unless ($self->{+LOADED}) { + confess "Attempt to initialize Test2::API during preload" + if $self->{+PRELOAD}; + $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; @@ -309,7 +362,7 @@ sub ipc_enable_shm { # In some systems (*BSD) accessing the SysV IPC APIs without # them being enabled can cause a SIGSYS. We suppress the SIGSYS # and then get ENOSYS from the calls. - local $SIG{SYS} = 'IGNORE'; + local $SIG{SYS} = 'IGNORE' if CAN_SIGSYS; require IPC::SysV; @@ -367,41 +420,66 @@ sub disable_ipc_polling { } sub _ipc_wait { + my ($timeout) = @_; my $fail = 0; - if (CAN_FORK) { - while (1) { - my $pid = CORE::wait(); - my $err = $?; - last if $pid == -1; - next unless $err; - $fail++; - $err = $err >> 8; - warn "Process $pid did not exit cleanly (status: $err)\n"; + $timeout = DEFAULT_IPC_TIMEOUT() unless defined $timeout; + + my $ok = eval { + if (CAN_FORK) { + local $SIG{ALRM} = sub { die "Timeout waiting on child processes" }; + alarm $timeout; + + while (1) { + my $pid = CORE::wait(); + my $err = $?; + last if $pid == -1; + next unless $err; + $fail++; + $err = $err >> 8; + warn "Process $pid did not exit cleanly (status: $err)\n"; + } + + alarm 0; } - } - if (USE_THREADS) { - for my $t (threads->list()) { - $t->join; - # In older threads we cannot check if a thread had an error unless - # we control it and its return. - my $err = $t->can('error') ? $t->error : undef; - next unless $err; - my $tid = $t->tid(); - $fail++; - chomp($err); - warn "Thread $tid did not end cleanly: $err\n"; + if (USE_THREADS) { + my $start = time; + + while (1) { + last unless threads->list(); + die "Timeout waiting on child thread" if time - $start >= $timeout; + sleep 1; + for my $t (threads->list) { + # threads older than 1.34 do not have this :-( + next if $t->can('is_joinable') && !$t->is_joinable; + $t->join; + # In older threads we cannot check if a thread had an error unless + # we control it and its return. + my $err = $t->can('error') ? $t->error : undef; + next unless $err; + my $tid = $t->tid(); + $fail++; + chomp($err); + warn "Thread $tid did not end cleanly: $err\n"; + } + } } - } - return 0 unless $fail; + 1; + }; + my $error = $@; + + return 0 if $ok && !$fail; + warn $error unless $ok; return 255; } sub DESTROY { my $self = shift; + return if $self->{+PRELOAD}; + return unless defined($self->{+_PID}) && $self->{+_PID} == $$; return unless defined($self->{+_TID}) && $self->{+_TID} == get_tid(); @@ -412,6 +490,8 @@ sub DESTROY { sub set_exit { my $self = shift; + return if $self->{+PRELOAD}; + my $exit = $?; my $new_exit = $exit; @@ -470,13 +550,13 @@ This is not a supported configuration, you will have problems. $ipc->waiting(); } - my $ipc_exit = _ipc_wait(); + my $ipc_exit = _ipc_wait($self->{+IPC_TIMEOUT}); $new_exit ||= $ipc_exit; } # None of this is necessary if we never got a root hub if(my $root = shift @hubs) { - my $trace = Test2::Util::Trace->new( + my $trace = Test2::EventFacet::Trace->new( frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'], detail => __PACKAGE__ . ' END Block finalization', ); @@ -645,6 +725,12 @@ pending events. When 1 is returned this will set C<< $obj->ipc_shm_last() >>. +=item $timeout = $obj->ipc_timeout; + +=item $obj->set_ipc_timeout($timeout); + +How long to wait for child processes and threads before aborting. + =item $drivers = $obj->ipc_drivers Get the list of IPC drivers. @@ -744,7 +830,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/API/Stack.pm b/cpan/Test-Simple/lib/Test2/API/Stack.pm index 534cd78d1b..d38563dcc8 100644 --- a/cpan/Test-Simple/lib/Test2/API/Stack.pm +++ b/cpan/Test-Simple/lib/Test2/API/Stack.pm @@ -2,7 +2,7 @@ package Test2::API::Stack; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Test2::Hub(); @@ -27,7 +27,7 @@ sub new_hub { } else { require Test2::API; - $hub->format(Test2::API::test2_formatter()->new) + $hub->format(Test2::API::test2_formatter()->new_root) unless $hub->format || exists($params{formatter}); my $ipc = Test2::API::test2_ipc(); @@ -210,7 +210,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event.pm b/cpan/Test-Simple/lib/Test2/Event.pm index a59a366081..f7be152ebd 100644 --- a/cpan/Test-Simple/lib/Test2/Event.pm +++ b/cpan/Test-Simple/lib/Test2/Event.pm @@ -2,17 +2,47 @@ package Test2::Event; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; -use Test2::Util::HashBase qw/trace nested in_subtest subtest_id/; +use Test2::Util::HashBase qw/trace -amnesty/; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util qw(pkg_to_file); -use Test2::Util::Trace; + +use Test2::EventFacet::About(); +use Test2::EventFacet::Amnesty(); +use Test2::EventFacet::Assert(); +use Test2::EventFacet::Control(); +use Test2::EventFacet::Error(); +use Test2::EventFacet::Info(); +use Test2::EventFacet::Meta(); +use Test2::EventFacet::Parent(); +use Test2::EventFacet::Plan(); +use Test2::EventFacet::Trace(); + +my @FACET_TYPES = qw{ + Test2::EventFacet::About + Test2::EventFacet::Amnesty + Test2::EventFacet::Assert + Test2::EventFacet::Control + Test2::EventFacet::Error + Test2::EventFacet::Info + Test2::EventFacet::Meta + Test2::EventFacet::Parent + Test2::EventFacet::Plan + Test2::EventFacet::Trace +}; + +sub FACET_TYPES() { @FACET_TYPES } + +# Legacy tools will expect this to be loaded now +require Test2::Util::Trace; + sub causes_fail { 0 } sub increments_count { 0 } sub diagnostics { 0 } sub no_display { 0 } +sub subtest_id { undef } sub callback { } @@ -22,31 +52,152 @@ sub sets_plan { () } sub summary { ref($_[0]) } -sub from_json { - my $class = shift; - my %p = @_; +sub related { + my $self = shift; + my ($event) = @_; + + my $tracea = $self->trace or return undef; + my $traceb = $event->trace or return undef; + + my $siga = $tracea->signature or return undef; + my $sigb = $traceb->signature or return undef; + + return 1 if $siga eq $sigb; + return 0; +} + +sub add_amnesty { + my $self = shift; + + for my $am (@_) { + $am = {%$am} if ref($am) ne 'ARRAY'; + $am = Test2::EventFacet::Amnesty->new($am); - my $event_pkg = delete $p{__PACKAGE__}; - require(pkg_to_file($event_pkg)); + push @{$self->{+AMNESTY}} => $am; + } +} + +sub common_facet_data { + my $self = shift; + + my %out; + + $out{about} = {package => ref($self) || undef}; + + if (my $trace = $self->trace) { + $out{trace} = { %$trace }; + } + + $out{amnesty} = [map {{ %{$_} }} @{$self->{+AMNESTY}}] + if $self->{+AMNESTY}; + + my $key = Test2::Util::ExternalMeta::META_KEY(); + if (my $hash = $self->{$key}) { + $out{meta} = {%$hash}; + } + + return \%out; +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{about}->{details} = $self->summary || undef; + $out->{about}->{no_display} = $self->no_display || undef; + + # Might be undef, we want to preserve that + my $terminate = $self->terminate; + $out->{control} = { + global => $self->global || 0, + terminate => $terminate, + has_callback => $self->can('callback') == \&callback ? 0 : 1, + }; + + $out->{assert} = { + no_debug => 1, # Legacy behavior + pass => $self->causes_fail ? 0 : 1, + details => $self->summary, + } if $self->increments_count; + + $out->{parent} = {hid => $self->subtest_id} if $self->subtest_id; + + if (my @plan = $self->sets_plan) { + $out->{plan} = {}; + + $out->{plan}->{count} = $plan[0] if defined $plan[0]; + $out->{plan}->{details} = $plan[2] if defined $plan[2]; + + if ($plan[1]) { + $out->{plan}->{skip} = 1 if $plan[1] eq 'SKIP'; + $out->{plan}->{none} = 1 if $plan[1] eq 'NO PLAN'; + } + + $out->{control}->{terminate} ||= 0 if $out->{plan}->{skip}; + } - if (exists $p{trace}) { - $p{trace} = Test2::Util::Trace->from_json(%{$p{trace}}); - } + if ($self->causes_fail && !$out->{assert}) { + $out->{errors} = [ + { + tag => 'FAIL', + fail => 1, + details => $self->summary, + } + ]; + } - if (exists $p{subevents}) { - my @subevents; - for my $subevent (@{delete $p{subevents} || []}) { - push @subevents, Test2::Event->from_json(%$subevent); - } - $p{subevents} = \@subevents; - } + my %IGNORE = (trace => 1, about => 1, control => 1); + my $do_info = !grep { !$IGNORE{$_} } keys %$out; + + if ($do_info && !$self->no_display && $self->diagnostics) { + $out->{info} = [ + { + tag => 'DIAG', + debug => 1, + details => $self->summary, + } + ]; + } - return $event_pkg->new(%p); + return $out; } -sub TO_JSON { +sub facets { my $self = shift; - return {%$self, __PACKAGE__ => ref $self}; + my $data = $self->facet_data; + my %out; + + for my $type (FACET_TYPES()) { + my $key = $type->facet_key; + next unless $data->{$key}; + + if ($type->is_list) { + $out{$key} = [map { $type->new($_) } @{$data->{$key}}]; + } + else { + $out{$key} = $type->new($data->{$key}); + } + } + + return \%out; +} + +sub nested { + Carp::cluck("Use of Test2::Event->nested() is deprecated, use Test2::Event->trace->nested instead") + if $ENV{AUTHOR_TESTING}; + + $_[0]->{+TRACE}->{nested}; +} + +sub in_subtest { + Carp::cluck("Use of Test2::Event->in_subtest() is deprecated, use Test2::Event->trace->hid instead") + if $ENV{AUTHOR_TESTING}; + + # Return undef if we are not nested, Legacy did not return the hid if nestign was 0. + return undef unless $_[0]->{+TRACE}->{nested}; + + $_[0]->{+TRACE}->{hid}; } 1; @@ -80,6 +231,10 @@ L<Test2>. # want, or roll your own accessors. use Test2::Util::HashBase qw/foo bar baz/; + # Use this if you want the legacy API to be written for you, for this to + # work you will need to implement a facet_data() method. + use Test2::Util::Facets2Legacy; + # Chance to initialize some defaults sub init { my $self = shift; @@ -90,17 +245,232 @@ L<Test2>. ... } + # This is the new way for events to convey data to the Test2 system + sub facet_data { + my $self = shift; + + # Get common facets such as 'about', 'trace' 'amnesty', and 'meta' + my $facet_data = $self->common_facet_data(); + + # Are you making an assertion? + $facet_data->{assert} = {pass => 1, details => 'my assertion'}; + ... + + return $facet_data; + } + 1; =head1 METHODS +=head2 GENERAL + =over 4 =item $trace = $e->trace -Get a snapshot of the L<Test2::Util::Trace> as it was when this event was +Get a snapshot of the L<Test2::EventFacet::Trace> as it was when this event was generated +=item $bool_or_undef = $e->related($e2) + +Check if 2 events are related. In this case related means their traces share a +signature meaning they were created with the same context (or at the very least +by contexts which share an id, which is the same thing unless someone is doing +something very bad). + +This can be used to reliably link multiple events created by the same tool. For +instance a failing test like C<ok(0, "fail"> will generate 2 events, one being +a L<Test2::Event::Ok>, the other being a L<Test2::Event::Diag>, both of these +events are related having been created under the same context and by the same +initial tool (though multiple tools may have been nested under the initial +one). + +This will return C<undef> if the relationship cannot be checked, which happens +if either event has an incomplete or missing trace. This will return C<0> if +the traces are complete, but do not match. C<1> will be returned if there is a +match. + +=item $e->add_amnesty({tag => $TAG, details => $DETAILS}); + +This can be used to add amnesty to this event. Amnesty only effects failing +assertions in most cases, but some formatters may display them for passing +assertions, or even non-assertions as well. + +Amnesty will prevent a failed assertion from causing the overall test to fail. +In other words it marks a failure as expected and allowed. + +B<Note:> This is how 'TODO' is implemented under the hood. TODO is essentially +amnesty with the 'TODO' tag. The details are the reason for the TODO. + +=back + +=head2 NEW API + +=over 4 + +=item $hashref = $e->common_facet_data(); + +This can be used by subclasses to generate a starting facet data hashref. This +will populate the hashref with the trace, meta, amnesty, and about facets. +These facets are nearly always produced the same way for all events. + +=item $hashref = $e->facet_data() + +If you do not override this then the default implementation will attempt to +generate facets from the legacy API. This generation is limited only to what +the legacy API can provide. It is recommended that you override this method and +write out explicit facet data. + +=item $hashref = $e->facets() + +This takes the hashref from C<facet_data()> and blesses each facet into the +proper C<Test2::EventFacet::*> subclass. + +=back + +=head3 WHAT ARE FACETS? + +Facets are how events convey their purpose to the Test2 internals and +formatters. An event without facets will have no intentional effect on the +overall test state, and will not be displayed at all by most formatters, except +perhaps to say that an event of an unknown type was seen. + +Facets are produced by the C<facet_data()> subroutine, which you should +nearly-always override. C<facet_data()> is expected to return a hashref where +each key is the facet type, and the value is either a hashref with the data for +that facet, or an array of hashref's. Some facets must be defined as single +hashrefs, some must be defined as an array of hashrefs, No facets allow both. + +C<facet_data()> B<MUST NOT> bless the data it returns, the main hashref, and +nested facet hashref's B<MUST> be bare, though items contained within each +facet may be blessed. The data returned by this method B<should> also be copies +of the internal data in order to prevent accidental state modification. + +C<facets()> takes the data from C<facet_data()> and blesses it into the +C<Test2::EventFacet::*> packages. This is rarely used however, the EventFacet +packages are primarily for convenience and documentation. The EventFacet +classes are not used at all internally, instead the raw data is used. + +Here is a list of facet types by package. The packages are not used internally, +but are where the documentation for each type is kept. + +B<Note:> Every single facet type has the C<'details'> field. This field is +always intended for human consumption, and when provided, should explain the +'why' for the facet. All other fields are facet specific. + +=over 4 + +=item about => {...} + +L<Test2::EventFacet::About> + +This contains information about the event itself such as the event package +name. The C<details> field for this facet is an overall summary of the event. + +=item assert => {...} + +L<Test2::EventFacet::Assert> + +This facet is used if an assertion was made. The C<details> field of this facet +is the description of the assertion. + +=item control => {...} + +L<Test2::EventFacet::Control> + +This facet is used to tell the L<Test2::Event::Hub> about special actions the +event causes. Things like halting all testing, terminating the current test, +etc. In this facet the C<details> field explains why any special action was +taken. + +B<Note:> This is how bail-out is implemented. + +=item meta => {...} + +L<Test2::EventFacet::Meta> + +The meta facet contains all the meta-data attached to the event. In this case +the C<details> field has no special meaning, but may be present if something +sets the 'details' meta-key on the event. + +=item parent => {...} + +L<Test2::EventFacet::Parent> + +This facet contains nested events and similar details for subtests. In this +facet the C<details> field will typically be the name of the subtest. + +=item plan => {...} + +L<Test2::EventFacet::Plan> + +This facet tells the system that a plan has been set. The C<details> field of +this is usually left empty, but when present explains why the plan is what it +is, this is most useful if the plan is to skip-all. + +=item trace => {...} + +L<Test2::EventFacet::Trace> + +This facet contains information related to when and where the event was +generated. This is how the test file and line number of a failure is known. +This facet can also help you to tell if tests are related. + +In this facet the C<details> field overrides the "failed at test_file.t line +42." message provided on assertion failure. + +=item amnesty => [{...}, ...] + +L<Test2::EventFacet::Amnesty> + +The amnesty facet is a list instead of a single item, this is important as +amnesty can come from multiple places at once. + +For each instance of amnesty the C<details> field explains why amnesty was +granted. + +B<Note:> Outside of formatters amnesty only acts to forgive a failing +assertion. + +=item errors => [{...}, ...] + +L<Test2::EventFacet::Error> + +The errors facet is a list instead of a single item, any number of errors can +be listed. In this facet C<details> describes the error, or may contain the raw +error message itself (such as an exception). In perl exception may be blessed +objects, as such the raw data for this facet may contain nested items which are +blessed. + +Not all errors are considered fatal, there is a C<fail> field that must be set +for an error to cause the test to fail. + +B<Note:> This facet is unique in that the field name is 'errors' while the +package is 'Error'. This is because this is the only facet type that is both a +list, and has a name where the plural is not the same as the singular. This may +cause some confusion, but I feel it will be less confusing than the +alternative. + +=item info => [{...}, ...] + +L<Test2::EventFacet::Info> + +The 'info' facet is a list instead of a single item, any quantity of extra +information can be attached to an event. Some information may be critical +diagnostics, others may be simply commentary in nature, this is determined by +the C<debug> flag. + +For this facet the C<details> flag is the info itself. This info may be a +string, or it may be a data structure to display. This is one of the few facet +types that may contain blessed items. + +=back + +=head2 LEGACY API + +=over 4 + =item $bool = $e->causes_fail Returns true if this event should result in a test failure. In general this @@ -117,11 +487,6 @@ this method. This is called B<BEFORE> your event is passed to the formatter. -=item $call = $e->created - -Get the C<caller()> details from when the event was generated. This is usually -inside a tools package. This is typically used for debugging. - =item $num = $e->nested If this event is nested inside of other events, this should be the depth of @@ -150,23 +515,6 @@ to exit with a failure. This is called after the event has been sent to the formatter in order to ensure the event is seen and understood. -=item $todo = $e->todo - -=item $e->set_todo($todo) - -Get/Set the todo reason on the event. Any value other than C<undef> makes the -event 'TODO'. - -Not all events make use of this field, but they can all have it set/cleared. - -=item $bool = $e->diag_todo - -=item $e->diag_todo($todo) - -True if this event should be considered 'TODO' for diagnostics purposes. This -essentially means that any message that would go to STDERR will go to STDOUT -instead so that a harness will hide it outside of verbose mode. - =item $msg = $e->summary This is intended to be a human readable summary of the event. This should @@ -202,17 +550,6 @@ If the event is inside a subtest this should have the subtest ID. If the event is a final subtest event, this should contain the subtest ID. -=item $hashref = $e->TO_JSON - -This returns a hashref suitable for passing to the C<< Test2::Event->from_json ->> constructor. It is intended for use with the L<JSON> family of modules, -which will look for a C<TO_JSON> method when C<convert_blessed> is true. - -=item $e = Test2::Event->from_json(%$hashref) - -Given the hash of data returned by C<< $e->TO_JSON >>, this method returns a -new event object of the appropriate subclass. - =back =head1 THIRD PARTY META-DATA @@ -244,7 +581,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Bail.pm b/cpan/Test-Simple/lib/Test2/Event/Bail.pm index 0284aecd00..bd1dda90fa 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Bail.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Bail.pm @@ -2,18 +2,11 @@ package Test2::Event::Bail; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } -use Test2::Util::HashBase qw{reason}; - -sub callback { - my $self = shift; - my ($hub) = @_; - - $hub->set_bailed_out($self); -} +use Test2::Util::HashBase qw{reason buffered}; # Make sure the tests terminate sub terminate { 255 }; @@ -32,6 +25,20 @@ sub summary { sub diagnostics { 1 } +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + + $out->{control} = { + global => 1, + halt => 1, + details => $self->{+REASON}, + terminate => 255, + }; + + return $out; +} + 1; __END__ @@ -92,7 +99,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Diag.pm b/cpan/Test-Simple/lib/Test2/Event/Diag.pm index 9d2ba88d6e..974a2038e1 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Diag.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Diag.pm @@ -2,7 +2,7 @@ package Test2::Event::Diag; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } @@ -16,6 +16,22 @@ sub summary { $_[0]->{+MESSAGE} } sub diagnostics { 1 } +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{info} = [ + { + tag => 'DIAG', + debug => 1, + details => $self->{+MESSAGE}, + } + ]; + + return $out; +} + 1; __END__ @@ -73,7 +89,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Encoding.pm b/cpan/Test-Simple/lib/Test2/Event/Encoding.pm index 52af3f2dc5..78f8aa2f01 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Encoding.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Encoding.pm @@ -2,18 +2,29 @@ package Test2::Event::Encoding; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; + +use Carp qw/croak/; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/encoding/; sub init { my $self = shift; - defined $self->{+ENCODING} or $self->trace->throw("'encoding' is a required attribute"); + defined $self->{+ENCODING} or croak "'encoding' is a required attribute"; } sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} } +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + $out->{control}->{encoding} = $self->{+ENCODING}; + $out->{about}->{details} = $self->summary; + return $out; +} + + 1; __END__ @@ -76,7 +87,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Exception.pm b/cpan/Test-Simple/lib/Test2/Event/Exception.pm index a10ca6756c..4ef3916736 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Exception.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Exception.pm @@ -2,7 +2,7 @@ package Test2::Event::Exception; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } @@ -18,6 +18,22 @@ sub summary { sub diagnostics { 1 } +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + + $out->{errors} = [ + { + tag => 'ERROR', + fail => 1, + details => $self->{+ERROR}, + } + ]; + + return $out; +} + + 1; __END__ @@ -78,7 +94,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Fail.pm b/cpan/Test-Simple/lib/Test2/Event/Fail.pm new file mode 100644 index 0000000000..f298bc5d93 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/Event/Fail.pm @@ -0,0 +1,118 @@ +package Test2::Event::Fail; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +use Test2::EventFacet::Info; + +BEGIN { + require Test2::Event; + our @ISA = qw(Test2::Event); + *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; +} + +use Test2::Util::HashBase qw{ -name -info }; + +############# +# Old API +sub summary { "fail" } +sub increments_count { 1 } +sub diagnostics { 0 } +sub no_display { 0 } +sub subtest_id { undef } +sub terminate { () } +sub global { () } +sub sets_plan { () } + +sub causes_fail { + my $self = shift; + return 0 if $self->{+AMNESTY} && @{$self->{+AMNESTY}}; + return 1; +} + +############# +# New API + +sub add_info { + my $self = shift; + + for my $in (@_) { + $in = {%$in} if ref($in) ne 'ARRAY'; + $in = Test2::EventFacet::Info->new($in); + + push @{$self->{+INFO}} => $in; + } +} + +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + + $out->{about}->{details} = 'fail'; + + $out->{assert} = {pass => 0, details => $self->{+NAME}}; + + $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Fail - Event for a simple failed assertion + +=head1 DESCRIPTION + +This is an optimal representation of a failed assertion. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + + sub fail { + my ($name) = @_; + my $ctx = context(); + $ctx->fail($name); + $ctx->release; + } + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/Event/Generic.pm b/cpan/Test-Simple/lib/Test2/Event/Generic.pm index ad00f5a963..04611a651c 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Generic.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Generic.pm @@ -5,14 +5,14 @@ use warnings; use Carp qw/croak/; use Scalar::Util qw/reftype/; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase; my @FIELDS = qw{ causes_fail increments_count diagnostics no_display callback terminate - global sets_plan summary + global sets_plan summary facet_data }; my %DEFAULTS = ( causes_fail => 0, @@ -35,15 +35,24 @@ sub init { for my $field (@FIELDS) { no strict 'refs'; - my $stash = \%{__PACKAGE__ . "::"}; *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () } - unless defined $stash->{$field} - && defined *{$stash->{$field}}{CODE}; + unless exists &{$field}; *{"set_$field"} = sub { $_[0]->{$field} = $_[1] } - unless defined $stash->{"set_$field"} - && defined *{$stash->{"set_$field"}}{CODE}; + unless exists &{"set_$field"}; +} + +sub can { + my $self = shift; + my ($name) = @_; + return $self->SUPER::can($name) unless $name eq 'callback'; + return $self->{callback} || \&Test2::Event::callback; +} + +sub facet_data { + my $self = shift; + return $self->{facet_data} || $self->SUPER::facet_data(); } sub summary { @@ -157,6 +166,14 @@ a published reusable event subclass. =over 4 +=item $e->facet_data($data) + +=item $data = $e->facet_data + +Get or set the facet data (see L<Test2::Event>). If no facet_data is set then +C<< Test2::Event->facet_data >> will be called to produce facets from the other +data. + =item $e->callback($hub) Call the custom callback if one is set, otherwise this does nothing. @@ -253,7 +270,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Info.pm b/cpan/Test-Simple/lib/Test2/Event/Info.pm deleted file mode 100644 index 51c4bbcd31..0000000000 --- a/cpan/Test-Simple/lib/Test2/Event/Info.pm +++ /dev/null @@ -1,127 +0,0 @@ -package Test2::Event::Info; -use strict; -use warnings; - -use Scalar::Util qw/blessed/; - -our $VERSION = '1.302073'; - -BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } -use Test2::Util::HashBase qw/diagnostics renderer/; - -sub init { - my $self = shift; - - my $r = $self->{+RENDERER} or $self->trace->throw("'renderer' is a required attribute"); - - return if ref($r) eq 'CODE'; - return if blessed($r) && $r->can('render'); - - $self->trace->throw("renderer '$r' is not a valid renderer, must be a coderef or an object implementing the 'render()' method"); -} - -sub render { - my $self = shift; - my ($fmt) = @_; - - $fmt ||= 'text'; - - my $r = $self->{+RENDERER}; - - return $r->($fmt) if ref($r) eq 'CODE'; - return $r->render($fmt); -} - -sub summary { $_[0]->render($_[1] || 'text') } - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Event::Info - Info event base class - -=head1 DESCRIPTION - -Successor for note and diag events. This event base class supports multiple -formats. This event makes it possible to send additional information such as -color and highlighting to the harness. - -=head1 SYNOPSIS - - use Test2::API::Context qw/context/; - - $ctx->info($obj, diagnostics => $bool); - -=head1 FORMATS - -Format will be passed in to C<render()> and C<summary()> as a string. Any -string is considered valid, if your event does not recognize the format it -should fallback to 'text'. - -=over 4 - -=item 'text' - -Plain and ordinary text. - -=item 'ansi' - -Text that may include ansi sequences such as colors. - -=item 'html' - -HTML formatted text. - -=back - -=head1 ACCESSORS - -=over 4 - -=item $bool = $info->diagnostics() - -=item $info->set_diagnostics($bool) - -True if this info is essential for diagnostics. The implication is that -diagnostics will got to STDERR while everything else goes to STDOUT, but that -is formatter/harness specific. - -=back - -=head1 SOURCE - -The source code repository for Test2 can be found at -F<http://github.com/Test-More/test-more/>. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum E<lt>exodist@cpan.orgE<gt> - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum E<lt>exodist@cpan.orgE<gt> - -=back - -=head1 COPYRIGHT - -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F<http://dev.perl.org/licenses/> - -=cut diff --git a/cpan/Test-Simple/lib/Test2/Event/Note.pm b/cpan/Test-Simple/lib/Test2/Event/Note.pm index b9a2ded1e1..35e4be7a13 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Note.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Note.pm @@ -2,7 +2,7 @@ package Test2::Event::Note; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } @@ -14,6 +14,22 @@ sub init { sub summary { $_[0]->{+MESSAGE} } +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{info} = [ + { + tag => 'NOTE', + debug => 0, + details => $self->{+MESSAGE}, + } + ]; + + return $out; +} + 1; __END__ @@ -71,7 +87,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Ok.pm b/cpan/Test-Simple/lib/Test2/Event/Ok.pm index 456d6bbcf3..5cc02d24fe 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Ok.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Ok.pm @@ -2,7 +2,7 @@ package Test2::Event::Ok; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } @@ -48,6 +48,33 @@ sub summary { return $name; } +sub extra_amnesty { + my $self = shift; + return unless defined($self->{+TODO}) || ($self->{+EFFECTIVE_PASS} && !$self->{+PASS}); + return { + tag => 'TODO', + details => $self->{+TODO}, + }; +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{assert} = { + no_debug => 1, # Legacy behavior + pass => $self->{+PASS}, + details => $self->{+NAME}, + }; + + if (my @exra_amnesty = $self->extra_amnesty) { + unshift @{$out->{amnesty}} => @exra_amnesty; + } + + return $out; +} + 1; __END__ @@ -100,11 +127,6 @@ Name of the test. This is the true/false value of the test after TODO and similar modifiers are taken into account. -=item $b = $e->allow_bad_name - -This relaxes the test name checks such that they allow characters that can -confuse a TAP parser. - =back =head1 SOURCE @@ -130,7 +152,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Pass.pm b/cpan/Test-Simple/lib/Test2/Event/Pass.pm new file mode 100644 index 0000000000..a3e91e4f14 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/Event/Pass.pm @@ -0,0 +1,114 @@ +package Test2::Event::Pass; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +use Test2::EventFacet::Info; + +BEGIN { + require Test2::Event; + our @ISA = qw(Test2::Event); + *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; +} + +use Test2::Util::HashBase qw{ -name -info }; + +############## +# Old API +sub summary { "pass" } +sub increments_count { 1 } +sub causes_fail { 0 } +sub diagnostics { 0 } +sub no_display { 0 } +sub subtest_id { undef } +sub terminate { () } +sub global { () } +sub sets_plan { () } + +############## +# New API + +sub add_info { + my $self = shift; + + for my $in (@_) { + $in = {%$in} if ref($in) ne 'ARRAY'; + $in = Test2::EventFacet::Info->new($in); + + push @{$self->{+INFO}} => $in; + } +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{about}->{details} = 'pass'; + + $out->{assert} = {pass => 1, details => $self->{+NAME}}; + + $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Pass - Event for a simple passing assertion + +=head1 DESCRIPTION + +This is an optimal representation of a passing assertion. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + + sub pass { + my ($name) = @_; + my $ctx = context(); + $ctx->pass($name); + $ctx->release; + } + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/Event/Plan.pm b/cpan/Test-Simple/lib/Test2/Event/Plan.pm index 94b3030c34..3a647a5db4 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Plan.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Plan.pm @@ -2,7 +2,7 @@ package Test2::Event::Plan; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } @@ -46,17 +46,6 @@ sub sets_plan { ); } -sub callback { - my $self = shift; - my ($hub) = @_; - - $hub->plan($self->{+DIRECTIVE} || $self->{+MAX}); - - return unless $self->{+DIRECTIVE}; - - $hub->set_skip_reason($self->{+REASON} || 1) if $self->{+DIRECTIVE} eq 'SKIP'; -} - sub terminate { my $self = shift; # On skip_all we want to terminate the hub @@ -79,6 +68,26 @@ sub summary { return "Plan is '$directive'"; } +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{control}->{terminate} = $self->{+DIRECTIVE} eq 'SKIP' ? 0 : undef + unless defined $out->{control}->{terminate}; + + $out->{plan} = {count => $self->{+MAX}}; + $out->{plan}->{details} = $self->{+REASON} if defined $self->{+REASON}; + + if (my $dir = $self->{+DIRECTIVE}) { + $out->{plan}->{skip} = 1 if $dir eq 'SKIP'; + $out->{plan}->{none} = 1 if $dir eq 'NO PLAN'; + } + + return $out; +} + + 1; __END__ @@ -150,7 +159,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Skip.pm b/cpan/Test-Simple/lib/Test2/Event/Skip.pm index 7cca06165b..69c57192dc 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Skip.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Skip.pm @@ -2,7 +2,7 @@ package Test2::Event::Skip; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } @@ -30,6 +30,25 @@ sub summary { return $out; } +sub extra_amnesty { + my $self = shift; + + my @out; + + push @out => { + tag => 'TODO', + details => $self->{+TODO}, + } if defined $self->{+TODO}; + + push @out => { + tag => 'skip', + details => $self->{+REASON}, + inherited => 0, + }; + + return @out; +} + 1; __END__ @@ -98,7 +117,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Subtest.pm b/cpan/Test-Simple/lib/Test2/Event/Subtest.pm index 2b3c773bf6..56c4c0735f 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Subtest.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Subtest.pm @@ -2,50 +2,49 @@ package Test2::Event::Subtest; use strict; use warnings; -our $VERSION = '1.302073'; - +our $VERSION = '1.302096'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } use Test2::Util::HashBase qw{subevents buffered subtest_id}; sub init { - my $self = shift; - $self->SUPER::init(); - $self->{+SUBEVENTS} ||= []; - if ($self->{+EFFECTIVE_PASS}) { - $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; - } + my $self = shift; + $self->SUPER::init(); + $self->{+SUBEVENTS} ||= []; + if ($self->{+EFFECTIVE_PASS}) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; + } } { - no warnings 'redefine'; - - sub set_subevents { - my $self = shift; - my @subevents = @_; - - if ($self->{+EFFECTIVE_PASS}) { - $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents; - } - - $self->{+SUBEVENTS} = \@subevents; - } - - sub set_effective_pass { - my $self = shift; - my ($pass) = @_; - - if ($pass) { - $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; - } - elsif ($self->{+EFFECTIVE_PASS} && !$pass) { - for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) { - $_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo; - } - } - - $self->{+EFFECTIVE_PASS} = $pass; - } + no warnings 'redefine'; + + sub set_subevents { + my $self = shift; + my @subevents = @_; + + if ($self->{+EFFECTIVE_PASS}) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents; + } + + $self->{+SUBEVENTS} = \@subevents; + } + + sub set_effective_pass { + my $self = shift; + my ($pass) = @_; + + if ($pass) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; + } + elsif ($self->{+EFFECTIVE_PASS} && !$pass) { + for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) { + $_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo; + } + } + + $self->{+EFFECTIVE_PASS} = $pass; + } } sub summary { @@ -58,12 +57,42 @@ sub summary { $name .= " (TODO: $todo)"; } elsif (defined $todo) { - $name .= " (TODO)" + $name .= " (TODO)"; } return $name; } +sub facet_data { + my $self = shift; + + my $out = $self->SUPER::facet_data(); + + $out->{parent} = { + hid => $self->subtest_id, + children => [map {$_->facet_data} @{$self->{+SUBEVENTS}}], + buffered => $self->{+BUFFERED}, + }; + + return $out; +} + +sub add_amnesty { + my $self = shift; + + for my $am (@_) { + $am = {%$am} if ref($am) ne 'ARRAY'; + $am = Test2::EventFacet::Amnesty->new($am); + + push @{$self->{+AMNESTY}} => $am; + + for my $e (@{$self->{+SUBEVENTS}}) { + $e->add_amnesty($am->clone(inherited => 1)); + } + } +} + + 1; __END__ @@ -121,7 +150,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm b/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm index b96a25adde..bd539f99e5 100644 --- a/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm +++ b/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm @@ -2,18 +2,36 @@ package Test2::Event::TAP::Version; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; + +use Carp qw/croak/; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/version/; sub init { my $self = shift; - defined $self->{+VERSION} or $self->trace->throw("'version' is a required attribute"); + defined $self->{+VERSION} or croak "'version' is a required attribute"; } sub summary { 'TAP version ' . $_[0]->{+VERSION} } +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{about}->{details} = $self->summary; + + push @{$out->{info}} => { + tag => 'INFO', + debug => 0, + details => $self->summary, + }; + + return $out; +} + 1; __END__ @@ -73,7 +91,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Event/Waiting.pm b/cpan/Test-Simple/lib/Test2/Event/Waiting.pm index fa87c6e8dd..bdf8fdeded 100644 --- a/cpan/Test-Simple/lib/Test2/Event/Waiting.pm +++ b/cpan/Test-Simple/lib/Test2/Event/Waiting.pm @@ -2,15 +2,30 @@ package Test2::Event::Waiting; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase; sub global { 1 }; sub summary { "IPC is waiting for children to finish..." } +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + push @{$out->{info}} => { + tag => 'INFO', + debug => 0, + details => $self->summary, + }; + + return $out; +} + 1; __END__ @@ -51,7 +66,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/EventFacet.pm b/cpan/Test-Simple/lib/Test2/EventFacet.pm new file mode 100644 index 0000000000..794c454058 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet.pm @@ -0,0 +1,93 @@ +package Test2::EventFacet; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +use Test2::Util::HashBase qw/-details/; +use Carp qw/croak/; + +my $SUBLEN = length(__PACKAGE__ . '::'); +sub facet_key { + my $key = ref($_[0]) || $_[0]; + substr($key, 0, $SUBLEN, ''); + return lc($key); +} + +sub is_list { 0 } + +sub clone { + my $self = shift; + my $type = ref($self); + return bless {%$self, @_}, $type; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet - Base class for all event facets. + +=head1 DESCRIPTION + +Base class for all event facets. + +=head1 METHODS + +=over 4 + +=item $key = $facet_class->facet_key() + +This will return the key for the facet in the facet data hash. + +=item $bool = $facet_class->is_list() + +This will return true if the facet should be in a list instead of a single +item. + +=item $clone = $facet->clone() + +=item $clone = $facet->clone(%replace) + +This will make a shallow clone of the facet. You may specify fields to override +as arguments. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/About.pm b/cpan/Test-Simple/lib/Test2/EventFacet/About.pm new file mode 100644 index 0000000000..58000d3027 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet/About.pm @@ -0,0 +1,80 @@ +package Test2::EventFacet::About; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -package -no_display }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::About - Facet with event details. + +=head1 DESCRIPTION + +This facet has information about the event, such as event package. + +=head1 FIELDS + +=over 4 + +=item $string = $about->{details} + +=item $string = $about->details() + +Summary about the event. + +=item $package = $about->{package} + +=item $package = $about->package() + +Event package name. + +=item $bool = $about->{no_display} + +=item $bool = $about->no_display() + +True if the event should be skipped by formatters. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm new file mode 100644 index 0000000000..409a9e35c8 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm @@ -0,0 +1,91 @@ +package Test2::EventFacet::Amnesty; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -tag -inherited }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Amnesty - Facet for assertion amnesty. + +=head1 DESCRIPTION + +This package represents what is expected in units of amnesty. + +=head1 NOTES + +This facet appears in a list instead of being a single item. + +=head1 FIELDS + +=over 4 + +=item $string = $amnesty->{details} + +=item $string = $amnesty->details() + +Human readable explanation of why amnesty was granted. + +Example: I<Not implemented yet, will fix> + +=item $short_string = $amnesty->{tag} + +=item $short_string = $amnesty->tag() + +Short string (usually 10 characters or less, not enforced, but may be truncated +by renderers) categorizing the amnesty. + +=item $bool = $amnesty->{inherited} + +=item $bool = $amnesty->inherited() + +This will be true if the amnesty was granted to a parent event and inherited by +this event, which is a child, such as an assertion within a subtest that is +marked todo. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm new file mode 100644 index 0000000000..d42677f5f3 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm @@ -0,0 +1,93 @@ +package Test2::EventFacet::Assert; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -pass -no_debug -number }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Assert - Facet representing an assertion. + +=head1 DESCRIPTION + +The assertion facet is provided by any event representing an assertion that was +made. + +=head1 FIELDS + +=over 4 + +=item $string = $assert->{details} + +=item $string = $assert->details() + +Human readable description of the assertion. + +=item $bool = $assert->{pass} + +=item $bool = $assert->pass() + +True if the assertion passed. + +=item $bool = $assert->{no_debug} + +=item $bool = $assert->no_debug() + +Set this to true if you have provided custom diagnostics and do not want the +defaults to be displayed. + +=item $int = $assert->{number} + +=item $int = $assert->number() + +(Optional) assertion number. This may be omitted or ignored. This is usually +only useful when parsing/processing TAP. + +B<Note>: This is not set by the Test2 system, assertion number is not known +until AFTER the assertion has been processed. This attribute is part of the +spec only for harnesses. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm new file mode 100644 index 0000000000..79f2f89d61 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm @@ -0,0 +1,100 @@ +package Test2::EventFacet::Control; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Control - Facet for hub actions and behaviors. + +=head1 DESCRIPTION + +This facet is used when the event needs to give instructions to the Test2 +internals. + +=head1 FIELDS + +=over 4 + +=item $string = $control->{details} + +=item $string = $control->details() + +Human readable explanation for the special behavior. + +=item $bool = $control->{global} + +=item $bool = $control->global() + +True if the event is global in nature and should be seen by all hubs. + +=item $exit = $control->{terminate} + +=item $exit = $control->terminate() + +Defined if the test should immediately exit, the value is the exit code and may +be C<0>. + +=item $bool = $control->{halt} + +=item $bool = $control->halt() + +True if all testing should be halted immediately. + +=item $bool = $control->{has_callback} + +=item $bool = $control->has_callback() + +True if the C<callback($hub)> method on the event should be called. + +=item $encoding = $control->{encoding} + +=item $encoding = $control->encoding() + +This can be used to change the encoding from this event onward. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm new file mode 100644 index 0000000000..2f9f9d7b36 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm @@ -0,0 +1,93 @@ +package Test2::EventFacet::Error; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +sub facet_key { 'errors' } +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -tag -fail }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Error - Facet for errors that need to be shown. + +=head1 DESCRIPTION + +This facet is used when an event needs to convey errors. + +=head1 NOTES + +This facet has the hash key C<'errors'>, and is a list of facets instead of a +single item. + +=head1 FIELDS + +=over 4 + +=item $string = $error->{details} + +=item $string = $error->details() + +Explanation of the error, or the error itself (such as an exception). In perl +exceptions may be blessed objects, so this field may contain a blessed object. + +=item $short_string = $error->{tag} + +=item $short_string = $error->tag() + +Short tag to categorize the error. This is usually 10 characters or less, +formatters may truncate longer tags. + +=item $bool = $error->{fail} + +=item $bool = $error->fail() + +Not all errors are fatal, some are displayed having already been handled. Set +this to true if you want the error to cause the test to fail. Without this the +error is simply a diagnostics message that has no effect on the overall +pass/fail result. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm new file mode 100644 index 0000000000..a7fac912e4 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm @@ -0,0 +1,102 @@ +package Test2::EventFacet::Info; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{-tag -debug -important}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Info - Facet for information a developer might care about. + +=head1 DESCRIPTION + +This facet represents messages intended for humans that will help them either +understand a result, or diagnose a failure. + +=head1 NOTES + +This facet appears in a list instead of being a single item. + +=head1 FIELDS + +=over 4 + +=item $string_or_structure = $info->{details} + +=item $string_or_structure = $info->details() + +Human readable string or data structure, this is the information to display. +Formatters are free to render the structures however they please. This may +contain a blessed object. + +=item $short_string = $info->{tag} + +=item $short_string = $info->tag() + +Short tag to categorize the info. This is usually 10 characters or less, +formatters may truncate longer tags. + +=item $bool = $info->{debug} + +=item $bool = $info->debug() + +Set this to true if the message is critical, or explains a failure. This is +info that should be displayed by formatters even in less-verbose modes. + +When false the information is not considered critical and may not be rendered +in less-verbose modes. + +=item $bool = $info->{important} + +=item $bool = $info->important + +This should be set for non debug messages that are still important enough to +show when a formatter is in quiet mode. A formatter should send these to STDOUT +not STDERR, but should show them even in non-verbose mode. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm new file mode 100644 index 0000000000..bab0631599 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm @@ -0,0 +1,104 @@ +package Test2::EventFacet::Meta; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use vars qw/$AUTOLOAD/; + +# replace set_details +{ + no warnings 'redefine'; + sub set_details { $_[0]->{'set_details'} } +} + +sub can { + my $self = shift; + my ($name) = @_; + + my $existing = $self->SUPER::can($name); + return $existing if $existing; + + # Only vivify when called on an instance, do not vivify for a class. There + # are a lot of magic class methods used in things like serialization (or + # the forks.pm module) which cause problems when vivified. + return undef unless ref($self); + + my $sub = sub { $_[0]->{$name} }; + { + no strict 'refs'; + *$name = $sub; + } + + return $sub; +} + +sub AUTOLOAD { + my $name = $AUTOLOAD; + $name =~ s/^.*:://g; + my $sub = $_[0]->can($name); + goto &$sub; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Meta - Facet for meta-data + +=head1 DESCRIPTION + +This facet can contain any random meta-data that has been attached to the +event. + +=head1 METHODS AND FIELDS + +Any/all fields and accessors are autovivified into existence. There is no way +to know what metadata may be added, so any is allowed. + +=over 4 + +=item $anything = $meta->{anything} + +=item $anything = $meta->anything() + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm new file mode 100644 index 0000000000..5718e171d6 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm @@ -0,0 +1,98 @@ +package Test2::EventFacet::Parent; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +use Carp qw/confess/; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -hid -children -buffered }; + +sub init { + confess "Attribute 'hid' must be set" + unless defined $_[0]->{+HID}; + + $_[0]->{+CHILDREN} ||= []; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Parent - Base class for all event facets. + +=head1 DESCRIPTION + +This facet is used when an event contains other events, such as a subtest. + +=head1 FIELDS + +=over 4 + +=item $string = $parent->{details} + +=item $string = $parent->details() + +Human readable description of the event. + +=item $hid = $parent->{hid} + +=item $hid = $parent->hid() + +Hub ID of the hub that is represented in the parent-child relationship. + +=item $arrayref = $parent->{children} + +=item $arrayref = $parent->children() + +Arrayref containing the facet-data hashes of events nested under this one. + +I<To get the actual events you need to get them from the parent event directly> + +=item $bool = $parent->{buffered} + +=item $bool = $parent->buffered() + +True if the subtest is buffered (meaning the formatter has probably not seen +them yet). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm new file mode 100644 index 0000000000..1584efb443 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm @@ -0,0 +1,94 @@ +package Test2::EventFacet::Plan; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -count -skip -none }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Plan - Facet for setting the plan + +=head1 DESCRIPTION + +Events use this facet when they need to set the plan. + +=head1 FIELDS + +=over 4 + +=item $string = $plan->{details} + +=item $string = $plan->details() + +Human readable explanation for the plan being set. This is normally not +rendered by most formatters except when the C<skip> field is also set. + +=item $positive_int = $plan->{count} + +=item $positive_int = $plan->count() + +Set the number of expected assertions. This should usually be set to C<0> when +C<skip> or C<none> are also set. + +=item $bool = $plan->{skip} + +=item $bool = $plan->skip() + +When true the entire test should be skipped. This is usually paired with an +explanation in the C<details> field, and a C<control> facet that has +C<terminate> set to C<0>. + +=item $bool = $plan->{none} + +=item $bool = $plan->none() + +This is mainly used by legacy L<Test::Builder> tests which set the plan to C<no +plan>, a construct that predates the much better C<done_testing()>. + +If you are using this in non-legacy code you may need to reconsider the course +of your life, maybe a hermitage would suite you? + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm b/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm new file mode 100644 index 0000000000..6f933173b8 --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm @@ -0,0 +1,249 @@ +package Test2::EventFacet::Trace; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } + +use Test2::Util qw/get_tid pkg_to_file/; +use Carp qw/confess/; + +use Test2::Util::HashBase qw{^frame ^pid ^tid ^cid -hid -nested details -buffered}; + +{ + no warnings 'once'; + *DETAIL = \&DETAILS; + *detail = \&details; + *set_detail = \&set_details; +} + +sub init { + confess "The 'frame' attribute is required" + unless $_[0]->{+FRAME}; + + $_[0]->{+DETAILS} = delete $_[0]->{detail} if $_[0]->{detail}; + + $_[0]->{+PID} = $$ unless defined $_[0]->{+PID}; + $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID}; +} + +sub snapshot { + my ($orig, @override) = @_; + bless {%$orig, @override}, __PACKAGE__; +} + +sub signature { + my $self = shift; + + # Signature is only valid if all of these fields are defined, there is no + # signature if any is missing. '0' is ok, but '' is not. + return join ':' => map { (defined($_) && length($_)) ? $_ : return undef } ( + $self->{+CID}, + $self->{+PID}, + $self->{+TID}, + $self->{+FRAME}->[1], + $self->{+FRAME}->[2], + ); +} + +sub debug { + my $self = shift; + return $self->{+DETAILS} if $self->{+DETAILS}; + my ($pkg, $file, $line) = $self->call; + return "at $file line $line"; +} + +sub alert { + my $self = shift; + my ($msg) = @_; + warn $msg . ' ' . $self->debug . ".\n"; +} + +sub throw { + my $self = shift; + my ($msg) = @_; + die $msg . ' ' . $self->debug . ".\n"; +} + +sub call { @{$_[0]->{+FRAME}} } + +sub package { $_[0]->{+FRAME}->[0] } +sub file { $_[0]->{+FRAME}->[1] } +sub line { $_[0]->{+FRAME}->[2] } +sub subname { $_[0]->{+FRAME}->[3] } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Trace - Debug information for events + +=head1 DESCRIPTION + +The L<Test2::API::Context> object, as well as all L<Test2::Event> types need to +have access to information about where they were created. This object +represents that information. + +=head1 SYNOPSIS + + use Test2::EventFacet::Trace; + + my $trace = Test2::EventFacet::Trace->new( + frame => [$package, $file, $line, $subname], + ); + +=head1 FACET FIELDS + +=over 4 + +=item $string = $trace->{details} + +=item $string = $trace->details() + +Used as a custom trace message that will be used INSTEAD of +C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>. + +=item $frame = $trace->{frame} + +=item $frame = $trace->frame() + +Get the call frame arrayref. + +=item $int = $trace->{pid} + +=item $int = $trace->pid() + +The process ID in which the event was generated. + +=item $int = $trace->{tid} + +=item $int = $trace->tid() + +The thread ID in which the event was generated. + +=item $id = $trace->{cid} + +=item $id = $trace->cid() + +The ID of the context that was used to create the event. + +=item $hid = $trace->{hid} + +=item $hid = $trace->hid() + +The ID of the hub that was current when the event was created. + +=item $int = $trace->{nested} + +=item $int = $trace->nested() + +How deeply nested the event is. + +=item $bool = $trace->{buffered} + +=item $bool = $trace->buffered() + +True if the event was buffered and not sent to the formatter independent of a +parent (This should never be set when nested is C<0> or C<undef>). + +=back + +=head1 METHODS + +B<Note:> All facet frames are also methods. + +=over 4 + +=item $trace->set_detail($msg) + +=item $msg = $trace->detail + +Used to get/set a custom trace message that will be used INSTEAD of +C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>. + +C<detail()> is an alias to the C<details> facet field for backwards +compatibility. + +=item $str = $trace->debug + +Typically returns the string C<< at <FILE> line <LINE> >>. If C<detail> is set +then its value will be returned instead. + +=item $trace->alert($MESSAGE) + +This issues a warning at the frame (filename and line number where +errors should be reported). + +=item $trace->throw($MESSAGE) + +This throws an exception at the frame (filename and line number where +errors should be reported). + +=item ($package, $file, $line, $subname) = $trace->call() + +Get the caller details for the debug-info. This is where errors should be +reported. + +=item $pkg = $trace->package + +Get the debug-info package. + +=item $file = $trace->file + +Get the debug-info filename. + +=item $line = $trace->line + +Get the debug-info line number. + +=item $subname = $trace->subname + +Get the debug-info subroutine name. + +=item $sig = trace->signature + +Get a signature string that identifies this trace. This is used to check if +multiple events are related. The Trace includes pid, tid, file, line number, +and the cid which is C<'C\d+'> for traces created by a context, or C<'T\d+'> +for traces created by C<new()>. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/cpan/Test-Simple/lib/Test2/Formatter.pm b/cpan/Test-Simple/lib/Test2/Formatter.pm index 945d545dd6..cd1a784ac3 100644 --- a/cpan/Test-Simple/lib/Test2/Formatter.pm +++ b/cpan/Test-Simple/lib/Test2/Formatter.pm @@ -2,7 +2,7 @@ package Test2::Formatter; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; my %ADDED; @@ -14,6 +14,11 @@ sub import { Test2::API::test2_formatter_add($class); } +sub new_root { + my $class = shift; + return $class->new(@_); +} + sub hide_buffered { 1 } sub terminate { } @@ -56,6 +61,12 @@ A formatter is any package or object with a C<write($event, $num)> method. sub finalize { } + sub new_root { + my $class = shift; + ... + $class->new(@_); + } + 1; The C<write> method is a method, so it either gets a class or instance. The two @@ -81,6 +92,12 @@ The C<finalize> method is always the last thing called on the formatter, I<< except when C<terminate> is called for a Bail event >>. It is passed the following arguments: +The C<new_root> method is called when C<Test2::API::Stack> Initializes the root +hub for the first time. Most formatters will simply have this call C<< +$class->new >>, which is the default behavior. Some formatters however may want +to take extra action during construction of the root formatter, this is where +they can do that. + =over 4 =item * The number of tests that were planned @@ -118,7 +135,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm b/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm index 680095cfed..d2dbc649f1 100644 --- a/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm +++ b/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm @@ -1,49 +1,33 @@ package Test2::Formatter::TAP; use strict; use warnings; -require PerlIO; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; + +use Test2::Util qw/clone_io/; use Test2::Util::HashBase qw{ - no_numbers handles _encoding + no_numbers handles _encoding _last_fh + -made_assertion }; sub OUT_STD() { 0 } sub OUT_ERR() { 1 } -use Carp qw/croak/; - BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) } -my %CONVERTERS = ( - 'Test2::Event::Ok' => 'event_ok', - 'Test2::Event::Skip' => 'event_skip', - 'Test2::Event::Note' => 'event_note', - 'Test2::Event::Diag' => 'event_diag', - 'Test2::Event::Bail' => 'event_bail', - 'Test2::Event::Exception' => 'event_exception', - 'Test2::Event::Subtest' => 'event_subtest', - 'Test2::Event::Plan' => 'event_plan', - 'Test2::Event::TAP::Version' => 'event_version', -); - -# Initial list of converters are safe for direct hash access cause we control them. -my %SAFE_TO_ACCESS_HASH = %CONVERTERS; - -sub register_event { - my $class = shift; - my ($type, $convert) = @_; - croak "Event type is a required argument" unless $type; - croak "Event type '$type' already registered" if $CONVERTERS{$type}; - croak "The second argument to register_event() must be a code reference or method name" - unless $convert && (ref($convert) eq 'CODE' || $class->can($convert)); - $CONVERTERS{$type} = $convert; +sub _autoflush { + my($fh) = pop; + my $old_fh = select $fh; + $| = 1; + select $old_fh; } _autoflush(\*STDOUT); _autoflush(\*STDERR); +sub hide_buffered { 1 } + sub init { my $self = shift; @@ -53,7 +37,18 @@ sub init { } } -sub hide_buffered { 1 } +sub _open_handles { + my $self = shift; + + require Test2::API; + my $out = clone_io(Test2::API::test2_stdout()); + my $err = clone_io(Test2::API::test2_stderr()); + + _autoflush($out); + _autoflush($err); + + return [$out, $err]; +} sub encoding { my $self = shift; @@ -82,15 +77,21 @@ if ($^C) { *write = sub {}; } sub write { - my ($self, $e, $num) = @_; + my ($self, $e, $num, $f) = @_; - my $type = ref($e); + # The most common case, a pass event with no amnesty and a normal name. + return if $self->print_optimal_pass($e, $num); + + $f ||= $e->facet_data; + + $self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; + + my @tap = $self->event_tap($f, $num) or return; - my $converter = $CONVERTERS{$type} || 'event_other'; - my @tap = $self->$converter($e, $self->{+NO_NUMBERS} ? undef : $num) or return; + $self->{+MADE_ASSERTION} = 1 if $f->{assert}; + my $nesting = $f->{trace}->{nested} || 0; my $handles = $self->{+HANDLES}; - my $nesting = ($SAFE_TO_ACCESS_HASH{$type} ? $e->{nested} : $e->nested) || 0; my $indent = ' ' x $nesting; # Local is expensive! Only do it if we really need to. @@ -101,59 +102,137 @@ sub write { next unless $msg; my $io = $handles->[$hid] or next; + print $io "\n" + if $ENV{HARNESS_ACTIVE} + && !$ENV{HARNESS_IS_VERBOSE} + && $hid == OUT_ERR + && $self->{+_LAST_FH} != $io + && $msg =~ m/^#\s*Failed test /; + $msg =~ s/^/$indent/mg if $nesting; print $io $msg; + $self->{+_LAST_FH} = $io; } } -sub _open_handles { - my $self = shift; +sub print_optimal_pass { + my ($self, $e, $num) = @_; - my %seen; - open(my $out, '>&', STDOUT) or die "Can't dup STDOUT: $!"; - binmode($out, join(":", "", "raw", grep { $_ ne 'unix' and !$seen{$_}++ } PerlIO::get_layers(STDOUT))); + my $type = ref($e); - %seen = (); - open(my $err, '>&', STDERR) or die "Can't dup STDERR: $!"; - binmode($err, join(":", "", "raw", grep { $_ ne 'unix' and !$seen{$_}++ } PerlIO::get_layers(STDERR))); + # Only optimal if this is a Pass or a passing Ok + return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass}); - _autoflush($out); - _autoflush($err); + # Amnesty requires further processing (todo is a form of amnesty) + return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo}); - return [$out, $err]; -} + # A name with a newline or hash symbol needs extra processing + return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#')); -sub _autoflush { - my($fh) = pop; - my $old_fh = select $fh; - $| = 1; - select $old_fh; + my $ok = 'ok'; + $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; + $ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n"; + + if (my $nesting = $e->{trace}->{nested}) { + my $indent = ' ' x $nesting; + $ok = "$indent$ok"; + } + + my $io = $self->{+HANDLES}->[OUT_STD]; + + local($\, $,) = (undef, '') if $\ || $,; + print $io $ok; + $self->{+_LAST_FH} = $io; + + return 1; } sub event_tap { + my ($self, $f, $num) = @_; + + my @tap; + + # If this IS the first event the plan should come first + # (plan must be before or after assertions, not in the middle) + push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION}; + + # The assertion is most important, if present. + if ($f->{assert}) { + push @tap => $self->assert_tap($f, $num); + push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass}; + } + + # Almost as important as an assertion + push @tap => $self->error_tap($f) if $f->{errors}; + + # Now lets see the diagnostics messages + push @tap => $self->info_tap($f) if $f->{info}; + + # If this IS NOT the first event the plan should come last + # (plan must be before or after assertions, not in the middle) + push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan}; + + # Bail out + push @tap => $self->halt_tap($f) if $f->{control}->{halt}; + + return @tap if @tap; + return @tap if $f->{control}->{halt}; + return @tap if grep { $f->{$_} } qw/assert plan info errors/; + + # Use the summary as a fallback if nothing else is usable. + return $self->summary_tap($f, $num); +} + +sub error_tap { my $self = shift; - my ($e, $num) = @_; + my ($f) = @_; - my $converter = $CONVERTERS{ref($e)} or return; + return map { + my $details = $_->{details}; - $num = undef if $self->{+NO_NUMBERS}; + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + $msg =~ s/^/# /; + $msg =~ s/\n/\n# /g; + } + + [OUT_ERR, "$msg\n"]; + } @{$f->{errors}}; +} + +sub plan_tap { + my $self = shift; + my ($f) = @_; + my $plan = $f->{plan} or return; + + return if $plan->{none}; + + if ($plan->{skip}) { + my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"]; + chomp($reason); + return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"]; + } - return $self->$converter($e, $num); + return [OUT_STD, "1.." . $plan->{count} . "\n"]; } -sub event_ok { +sub no_subtest_space { 0 } +sub assert_tap { my $self = shift; - my ($e, $num) = @_; + my ($f, $num) = @_; - # We use direct hash access for performance. OK events are so common we - # need this to be fast. - my ($name, $todo) = @{$e}{qw/name todo/}; - my $in_todo = defined($todo); + my $assert = $f->{assert} or return; + my $pass = $assert->{pass}; + my $name = $assert->{details}; - my $out = ""; - $out .= "not " unless $e->{pass}; - $out .= "ok"; - $out .= " $num" if defined($num); + my $ok = $pass ? 'ok' : 'not ok'; + $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; # The regex form is ~250ms, the index form is ~50ms my @extra; @@ -162,194 +241,155 @@ sub event_ok { ((index($name, "#" ) != -1 || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g))) ); - my $space = @extra ? ' ' x (length($out) + 2) : ''; + my $extra_space = @extra ? ' ' x (length($ok) + 2) : ''; + my $extra_indent = ''; - $out .= " - $name" if defined $name; - $out .= " # TODO" if $in_todo; - $out .= " $todo" if defined($todo) && length($todo); + my ($directives, $reason, $is_skip); + if ($f->{amnesty}) { + my %directives; - # The primary line of TAP, if the test passed this is all we need. - return([OUT_STD, "$out\n"]) unless @extra; + for my $am (@{$f->{amnesty}}) { + next if $am->{inherited}; + my $tag = $am->{tag} or next; + $is_skip = 1 if $tag eq 'skip'; - return $self->event_ok_multiline($out, $space, @extra); -} + $directives{$tag} ||= $am->{details}; + } -sub event_ok_multiline { - my $self = shift; - my ($out, $space, @extra) = @_; + my %seen; + my @order = grep { !$seen{$_}++ } sort keys %directives; - return( - [OUT_STD, "$out\n"], - map {[OUT_STD, "#${space}$_\n"]} @extra, - ); -} + $directives = ' # ' . join ' & ' => @order; -sub event_skip { - my $self = shift; - my ($e, $num) = @_; - - my $name = $e->name; - my $reason = $e->reason; - my $todo = $e->todo; - - my $out = ""; - $out .= "not " unless $e->{pass}; - $out .= "ok"; - $out .= " $num" if defined $num; - $out .= " - $name" if $name; - if (defined($todo)) { - $out .= " # TODO & SKIP" - } - else { - $out .= " # skip"; + for my $tag ('skip', @order) { + next unless defined($directives{$tag}) && length($directives{$tag}); + $reason = $directives{$tag}; + last; + } } - $out .= " $reason" if defined($reason) && length($reason); - return([OUT_STD, "$out\n"]); -} + $ok .= " - $name" if defined $name && !($is_skip && !$name); -sub event_note { - my $self = shift; - my ($e, $num) = @_; + my @subtap; + if ($f->{parent} && $f->{parent}->{buffered}) { + $ok .= ' {'; - chomp(my $msg = $e->message); - $msg =~ s/^/# /; - $msg =~ s/\n/\n# /g; + # In a verbose harness we indent the extra since they will appear + # inside the subtest braces. This helps readability. In a non-verbose + # harness we do not do this because it is less readable. + if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) { + $extra_indent = " "; + $extra_space = ' '; + } - return [OUT_STD, "$msg\n"]; -} + # Render the sub-events, we use our own counter for these. + my $count = 0; + @subtap = map { + my $f2 = $_; -sub event_diag { - my $self = shift; - my ($e, $num) = @_; + # Bump the count for any event that should bump it. + $count++ if $f2->{assert}; - chomp(my $msg = $e->message); - $msg =~ s/^/# /; - $msg =~ s/\n/\n# /g; + # This indents all output lines generated for the sub-events. + # index 0 is the filehandle, index 1 is the message we want to indent. + map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($f2, $count); + } @{$f->{parent}->{children}}; - return [OUT_ERR, "$msg\n"]; -} + push @subtap => [OUT_STD, "}\n"]; + } -sub event_bail { - my $self = shift; - my ($e, $num) = @_; + if ($directives) { + $directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip'; + $ok .= $directives; + $ok .= " $reason" if defined($reason); + } - return if $e->nested; + $extra_space = ' ' if $self->no_subtest_space; - return [ - OUT_STD, - "Bail out! " . $e->reason . "\n", - ]; -} + my @out = ([OUT_STD, "$ok\n"]); + push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra; + push @out => @subtap; -sub event_exception { - my $self = shift; - my ($e, $num) = @_; - return [ OUT_ERR, $e->error ]; + return @out; } -sub event_subtest { - my $self = shift; - my ($e, $num) = @_; - - # A 'subtest' is a subclass of 'ok'. Let the code that renders 'ok' render - # this event. - my ($ok, @diag) = $self->event_ok($e, $num); - - # If the subtest is not buffered then the sub-events have already been - # rendered, we can go ahead and return. - return ($ok, @diag) unless $e->buffered; - - # In a verbose harness we indent the diagnostics from the 'Ok' event since - # they will appear inside the subtest braces. This helps readability. In a - # non-verbose harness we do not do this because it is less readable. - if ($ENV{HARNESS_IS_VERBOSE}) { - # index 0 is the filehandle, index 1 is the message we want to indent. - $_->[1] =~ s/^(.*\S.*)$/ $1/mg for @diag; - } +sub debug_tap { + my ($self, $f, $num) = @_; - # Add the trailing ' {' to the 'ok' line of TAP output. - $ok->[1] =~ s/\n/ {\n/; - - # Render the sub-events, we use our own counter for these. - my $count = 0; - my @subs = map { - # Bump the count for any event that should bump it. - $count++ if $_->increments_count; - - # This indents all output lines generated for the sub-events. - # index 0 is the filehandle, index 1 is the message we want to indent. - map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($_, $count); - } @{$e->subevents}; - - return ( - $ok, # opening ok - name { - @diag, # diagnostics if the subtest failed - @subs, # All the inner-event lines - [OUT_STD(), "}\n"], # } (closing brace) - ); -} + # Figure out the debug info, this is typically the file name and line + # number, but can also be a custom message. If no trace object is provided + # then we have nothing useful to display. + my $name = $f->{assert}->{details}; + my $trace = $f->{trace}; -sub event_plan { - my $self = shift; - my ($e, $num) = @_; + my $debug = "[No trace info available]"; + if ($trace->{details}) { + $debug = $trace->{details}; + } + elsif ($trace->{frame}) { + my ($pkg, $file, $line) = @{$trace->{frame}}; + $debug = "at $file line $line." if $file && $line; + } - my $directive = $e->directive; - return if $directive && $directive eq 'NO PLAN'; + my $amnesty = $f->{amnesty} && @{$f->{amnesty}} + ? ' (with amnesty)' + : ''; - my $reason = $e->reason; - $reason =~ s/\n/\n# /g if $reason; + # Create the initial diagnostics. If the test has a name we put the debug + # info on a second line, this behavior is inherited from Test::Builder. + my $msg = defined($name) + ? qq[# Failed test${amnesty} '$name'\n# $debug\n] + : qq[# Failed test${amnesty} $debug\n]; - my $plan = "1.." . $e->max; - if ($directive) { - $plan .= " # $directive"; - $plan .= " $reason" if defined $reason; - } + my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR; - return [OUT_STD, "$plan\n"]; + return [$IO, $msg]; } -sub event_version { - my $self = shift; - my ($e, $num) = @_; +sub halt_tap { + my ($self, $f) = @_; - my $version = $e->version; + return if $f->{trace}->{nested} && !$f->{trace}->{buffered}; + my $details = $f->{control}->{details}; - return [OUT_STD, "TAP version $version\n"]; + return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details); + return [OUT_STD, "Bail out! $details\n"]; } -sub event_other { - my $self = shift; - my ($e, $num) = @_; - return if $e->no_display; +sub info_tap { + my ($self, $f) = @_; - my @out; + return map { + my $details = $_->{details}; - if (my ($max, $directive, $reason) = $e->sets_plan) { - my $plan = "1..$max"; - $plan .= " # $directive" if $directive; - $plan .= " $reason" if defined $reason; - push @out => [OUT_STD, "$plan\n"]; - } + my $IO = $_->{debug} ? OUT_ERR : OUT_STD; - if ($e->increments_count) { - my $ok = ""; - $ok .= "not " if $e->causes_fail; - $ok .= "ok"; - $ok .= " $num" if defined($num); - $ok .= " - " . $e->summary if $e->summary; + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + $msg =~ s/^/# /; + $msg =~ s/\n/\n# /g; + } - push @out => [OUT_STD, "$ok\n"]; - } - else { # Comment - my $handle = ($e->causes_fail || $e->diagnostics) ? OUT_ERR : OUT_STD; - my $summary = $e->summary || ref($e); - chomp($summary); - $summary =~ s/^/# /smg; - push @out => [$handle, "$summary\n"]; - } + [$IO, "$msg\n"]; + } @{$f->{info}}; +} - return @out; +sub summary_tap { + my ($self, $f, $num) = @_; + + return if $f->{about}->{no_display}; + + my $summary = $f->{about}->{details} or return; + chomp($summary); + $summary =~ s/^/# /smg; + + return [OUT_STD, "$summary\n"]; } 1; @@ -408,99 +448,6 @@ This directly modifies the stored filehandles, it does not create new ones. Write an event to the console. -=item Test2::Formatter::TAP->register_event($pkg, sub { ... }); - -In general custom events are not supported. There are however occasions where -you might want to write a custom event type that results in TAP output. In -order to do this you use the C<register_event()> class method. - - package My::Event; - use Test2::Formatter::TAP; - - use base 'Test2::Event'; - use Test2::Util::HashBase qw/pass name diag note/; - - Test2::Formatter::TAP->register_event( - __PACKAGE__, - sub { - my $self = shift; - my ($e, $num) = @_; - return ( - [Test2::Formatter::TAP::OUT_STD, "ok $num - " . $e->name . "\n"], - [Test2::Formatter::TAP::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"], - [Test2::Formatter::TAP::OUT_STD, "# " . $e->name . " " . $e->note . "\n"], - ); - } - ); - - 1; - -=back - -=head2 EVENT METHODS - -All these methods require the event itself. Optionally they can all except a -test number. - -All methods return a list of array-refs. Each array-ref will have 2 items, the -first is an integer identifying an output handle, the second is a string that -should be written to the handle. - -=over 4 - -=item @out = $TAP->event_ok($e) - -=item @out = $TAP->event_ok($e, $num) - -Process an L<Test2::Event::Ok> event. - -=item @out = $TAP->event_plan($e) - -=item @out = $TAP->event_plan($e, $num) - -Process an L<Test2::Event::Plan> event. - -=item @out = $TAP->event_note($e) - -=item @out = $TAP->event_note($e, $num) - -Process an L<Test2::Event::Note> event. - -=item @out = $TAP->event_diag($e) - -=item @out = $TAP->event_diag($e, $num) - -Process an L<Test2::Event::Diag> event. - -=item @out = $TAP->event_bail($e) - -=item @out = $TAP->event_bail($e, $num) - -Process an L<Test2::Event::Bail> event. - -=item @out = $TAP->event_exception($e) - -=item @out = $TAP->event_exception($e, $num) - -Process an L<Test2::Event::Exception> event. - -=item @out = $TAP->event_skip($e) - -=item @out = $TAP->event_skip($e, $num) - -Process an L<Test2::Event::Skip> event. - -=item @out = $TAP->event_subtest($e) - -=item @out = $TAP->event_subtest($e, $num) - -Process an L<Test2::Event::Subtest> event. - -=item @out = $TAP->event_other($e, $num) - -Fallback for unregistered event types. It uses the L<Test2::Event> API to -convert the event to TAP. - =back =head1 SOURCE @@ -528,7 +475,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Hub.pm b/cpan/Test-Simple/lib/Test2/Hub.pm index 324f1a87bb..9169f0bb6c 100644 --- a/cpan/Test-Simple/lib/Test2/Hub.pm +++ b/cpan/Test-Simple/lib/Test2/Hub.pm @@ -2,17 +2,19 @@ package Test2::Hub; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Carp qw/carp croak confess/; use Test2::Util qw/get_tid ipc_separator/; use Scalar::Util qw/weaken/; +use List::Util qw/first/; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util::HashBase qw{ pid tid hid ipc + nested buffered no_ending _filters _pre_filters @@ -41,6 +43,9 @@ sub init { $self->{+TID} = get_tid(); $self->{+HID} = join ipc_separator, $self->{+PID}, $self->{+TID}, $ID_POSTFIX++; + $self->{+NESTED} = 0 unless defined $self->{+NESTED}; + $self->{+BUFFERED} = 0 unless defined $self->{+BUFFERED}; + $self->{+COUNT} = 0; $self->{+FAILED} = 0; $self->{+_PASSING} = 1; @@ -56,6 +61,21 @@ sub init { sub is_subtest { 0 } +sub _tb_reset { + my $self = shift; + + # Nothing to do + return if $self->{+PID} == $$ && $self->{+TID} == get_tid(); + + $self->{+PID} = $$; + $self->{+TID} = get_tid(); + $self->{+HID} = join ipc_separator, $self->{+PID}, $self->{+TID}, $ID_POSTFIX++; + + if (my $ipc = $self->{+IPC}) { + $ipc->add_hub($self->{+HID}); + } +} + sub reset_state { my $self = shift; @@ -73,6 +93,8 @@ sub inherit { my $self = shift; my ($from, %params) = @_; + $self->{+NESTED} ||= 0; + $self->{+_FORMATTER} = $from->{+_FORMATTER} unless $self->{+_FORMATTER} || exists($params{formatter}); @@ -281,32 +303,63 @@ sub process { } } + # Optimize the most common case my $type = ref($e); - my $is_ok = $type eq 'Test2::Event::Ok'; - my $no_fail = $type eq 'Test2::Event::Diag' || $type eq 'Test2::Event::Note'; - my $causes_fail = $is_ok ? !$e->{effective_pass} : $no_fail ? 0 : $e->causes_fail; - my $counted = $is_ok || (!$no_fail && $e->increments_count); + if ($type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass})) { + my $count = ++($self->{+COUNT}); + $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER}; - $self->{+COUNT}++ if $counted; - $self->{+FAILED}++ if $causes_fail && $counted; - $self->{+_PASSING} = 0 if $causes_fail; + if ($self->{+_LISTENERS}) { + $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}}; + } + + return $e; + } + + my $f = $e->facet_data; - my $callback = $e->callback($self) unless $is_ok || $no_fail; + my $fail = 0; + $fail = 1 if $f->{assert} && !$f->{assert}->{pass}; + $fail = 1 if $f->{error} && $f->{error}->{fail}; + $fail = 0 if $f->{amnesty}; + $self->{+COUNT}++ if $f->{assert}; + $self->{+FAILED}++ if $fail && $f->{assert}; + $self->{+_PASSING} = 0 if $fail; + + my $code = $f->{control}->{terminate}; my $count = $self->{+COUNT}; - $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER}; + if (my $plan = $f->{plan}) { + if ($plan->{skip}) { + $self->plan('SKIP'); + $self->set_skip_reason($plan->{details} || 1); + $code ||= 0; + } + elsif ($plan->{none}) { + $self->plan('NO PLAN'); + } + else { + $self->plan($plan->{count}); + } + } + + $e->callback($self) if $f->{control}->{has_callback}; + + $self->{+_FORMATTER}->write($e, $count, $f) if $self->{+_FORMATTER}; if ($self->{+_LISTENERS}) { - $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}}; + $_->{code}->($self, $e, $count, $f) for @{$self->{+_LISTENERS}}; } - return $e if $is_ok || $no_fail; + if ($f->{control}->{halt}) { + $code ||= 255; + $self->set_bailed_out($e); + } - my $code = $e->terminate; if (defined $code) { - $self->{+_FORMATTER}->terminate($e) if $self->{+_FORMATTER}; - $self->terminate($code, $e); + $self->{+_FORMATTER}->terminate($e, $f) if $self->{+_FORMATTER}; + $self->terminate($code, $e, $f); } return $e; @@ -339,11 +392,11 @@ sub finalize { my $failed = $self->{+FAILED}; my $active = $self->{+ACTIVE}; - # return if NOTHING was done. - unless ($active || $do_plan || defined($plan) || $count || $failed) { - $self->{+_FORMATTER}->finalize($plan, $count, $failed, 0, $self->is_subtest) if $self->{+_FORMATTER}; - return; - } + # return if NOTHING was done. + unless ($active || $do_plan || defined($plan) || $count || $failed) { + $self->{+_FORMATTER}->finalize($plan, $count, $failed, 0, $self->is_subtest) if $self->{+_FORMATTER}; + return; + } unless ($self->{+ENDED}) { if ($self->{+_FOLLOW_UPS}) { @@ -381,7 +434,7 @@ Second End: $sfile line $sline $self->{+ENDED} = $frame; my $pass = $self->is_passing(); # Generate the final boolean. - $self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER}; + $self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER}; return $pass; } @@ -452,7 +505,6 @@ sub DESTROY { my $ipc = $self->{+IPC} || return; return unless $$ == $self->{+PID}; return unless get_tid() == $self->{+TID}; - $ipc->drop_hub($self->{+HID}); } @@ -640,7 +692,7 @@ the reference returned by C<filter()> or C<pre_filter()>. =item $hub->follow_op(sub { ... }) Use this to add behaviors that are called just before the hub is finalized. The -only argument to your codeblock will be a L<Test2::Util::Trace> instance. +only argument to your codeblock will be a L<Test2::EventFacet::Trace> instance. $hub->follow_up(sub { my ($trace, $hub) = @_; @@ -819,7 +871,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm b/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm index 42be265f8d..efeb09f6c1 100644 --- a/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm +++ b/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm @@ -2,7 +2,7 @@ package Test2::Hub::Interceptor; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Test2::Hub::Interceptor::Terminator(); @@ -10,10 +10,18 @@ use Test2::Hub::Interceptor::Terminator(); BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase; +sub init { + my $self = shift; + $self->SUPER::init; + $self->{+NESTED} = 0; +} + sub inherit { my $self = shift; my ($from, %params) = @_; + $self->{+NESTED} = 0; + if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { my $ipc = $from->{+IPC}; $self->{+IPC} = $ipc; @@ -70,7 +78,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm b/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm index f720190468..51d5040272 100644 --- a/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm +++ b/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm @@ -2,7 +2,7 @@ package Test2::Hub::Interceptor::Terminator; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; 1; @@ -41,7 +41,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm b/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm index adb3d6f15e..aa0a939299 100644 --- a/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm +++ b/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm @@ -2,29 +2,29 @@ package Test2::Hub::Subtest; use strict; use warnings; -our $VERSION = '1.302073'; - +our $VERSION = '1.302096'; BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } -use Test2::Util::HashBase qw/nested bailed_out exit_code manual_skip_all id/; +use Test2::Util::HashBase qw/nested exit_code manual_skip_all/; use Test2::Util qw/get_tid/; -my $ID = 1; -sub init { - my $self = shift; - $self->SUPER::init(@_); - $self->{+ID} ||= join "-", $$, get_tid, $ID++; -} - sub is_subtest { 1 } -sub process { +sub inherit { my $self = shift; - my ($e) = @_; - $e->set_nested($self->nested); - $e->set_in_subtest($self->{+ID}); - $self->set_bailed_out($e) if $e->isa('Test2::Event::Bail'); - $self->SUPER::process($e); + my ($from) = @_; + + $self->SUPER::inherit($from); + + $self->{+NESTED} = $from->nested + 1; +} + +{ + # Legacy + no warnings 'once'; + *ID = \&Test2::Hub::HID; + *id = \&Test2::Hub::hid; + *set_id = \&Test2::Hub::set_hid; } sub send { @@ -34,9 +34,15 @@ sub send { my $out = $self->SUPER::send($e); return $out if $self->{+MANUAL_SKIP_ALL}; - return $out unless $e->isa('Test2::Event::Plan') - && $e->directive eq 'SKIP' - && ($e->trace->pid != $self->pid || $e->trace->tid != $self->tid); + + my $f = $e->facet_data; + + my $plan = $f->{plan} or return $out; + return $out unless $plan->{skip}; + + my $trace = $f->{trace} or die "Missing Trace!"; + return $out unless $trace->{pid} != $self->pid + || $trace->{tid} != $self->tid; no warnings 'exiting'; last T2_SUBTEST_WRAPPER; @@ -44,13 +50,18 @@ sub send { sub terminate { my $self = shift; - my ($code, $e) = @_; + my ($code, $e, $f) = @_; $self->set_exit_code($code); return if $self->{+MANUAL_SKIP_ALL}; - return if $e->isa('Test2::Event::Plan') - && $e->directive eq 'SKIP' - && ($e->trace->pid != $$ || $e->trace->tid != get_tid); + + $f ||= $e->facet_data; + + if(my $plan = $f->{plan}) { + my $trace = $f->{trace} or die "Missing Trace!"; + return if $plan->{skip} + && ($trace->{pid} != $$ || $trace->{tid} != get_tid); + } no warnings 'exiting'; last T2_SUBTEST_WRAPPER; @@ -115,7 +126,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/IPC.pm b/cpan/Test-Simple/lib/Test2/IPC.pm index 92447919c1..c6f872ead5 100644 --- a/cpan/Test-Simple/lib/Test2/IPC.pm +++ b/cpan/Test-Simple/lib/Test2/IPC.pm @@ -2,7 +2,7 @@ package Test2::IPC; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Test2::API::Instance; @@ -130,7 +130,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/IPC/Driver.pm b/cpan/Test-Simple/lib/Test2/IPC/Driver.pm index cd34f7c025..7f3e10b0bf 100644 --- a/cpan/Test-Simple/lib/Test2/IPC/Driver.pm +++ b/cpan/Test-Simple/lib/Test2/IPC/Driver.pm @@ -2,7 +2,7 @@ package Test2::IPC::Driver; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Carp qw/confess longmess/; @@ -282,7 +282,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm b/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm index 998fef5637..c847966d7a 100644 --- a/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm +++ b/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm @@ -2,7 +2,7 @@ package Test2::IPC::Driver::Files; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } @@ -15,54 +15,9 @@ use Storable(); use File::Spec(); use POSIX(); -use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator/; +use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/; use Test2::API qw/test2_ipc_set_pending/; -BEGIN { - if (IS_WIN32) { - my $max_tries = 5; - - *do_rename = sub { - my ($from, $to) = @_; - - my $err; - for (1 .. $max_tries) { - return (1) if rename($from, $to); - $err = "$!"; - last if $_ == $max_tries; - sleep 1; - } - - return (0, $err); - }; - *do_unlink = sub { - my ($file) = @_; - - my $err; - for (1 .. $max_tries) { - return (1) if unlink($file); - $err = "$!"; - last if $_ == $max_tries; - sleep 1; - } - - return (0, "$!"); - }; - } - else { - *do_rename = sub { - my ($from, $to) = @_; - return (1) if rename($from, $to); - return (0, "$!"); - }; - *do_unlink = sub { - my ($file) = @_; - return (1) if unlink($file); - return (0, "$!"); - }; - } -} - sub use_shm { 1 } sub shm_size() { 64 } @@ -199,36 +154,18 @@ do so if Test::Builder is loaded for legacy reasons. $self->{+GLOBALS}->{$hid}->{$name}++; } - my ($old, $blocked); - unless(IS_WIN32) { - my $to_block = POSIX::SigSet->new( - POSIX::SIGINT(), - POSIX::SIGALRM(), - POSIX::SIGHUP(), - POSIX::SIGTERM(), - POSIX::SIGUSR1(), - POSIX::SIGUSR2(), - ); - $old = POSIX::SigSet->new; - $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old); - # Silently go on if we failed to log signals, not much we can do. - } - # Write and rename the file. - my ($ok, $err) = try { + my ($ren_ok, $ren_err); + my ($ok, $err) = try_sig_mask { Storable::store($e, $file); - my ($ok, $err) = do_rename("$file", $ready); - unless ($ok) { - POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; - $self->abort("Could not rename file '$file' -> '$ready': $err"); - }; - test2_ipc_set_pending(substr($file, -(shm_size))); + ($ren_ok, $ren_err) = do_rename("$file", $ready); }; - # If our block was successful we want to restore the old mask. - POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; - - if (!$ok) { + if ($ok) { + $self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok; + test2_ipc_set_pending(substr($file, -(shm_size))); + } + else { my $src_file = __FILE__; $err =~ s{ at \Q$src_file\E.*$}{}; chomp($err); @@ -374,7 +311,7 @@ sub waiting { require Test2::Event::Waiting; $self->send( GLOBAL => Test2::Event::Waiting->new( - trace => Test2::Util::Trace->new(frame => [caller()]), + trace => Test2::EventFacet::Trace->new(frame => [caller()]), ), 'GLOBAL' ); @@ -487,7 +424,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm b/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm index 857a923c6a..c460196892 100644 --- a/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm +++ b/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm @@ -10,7 +10,7 @@ use Test2::API qw/context run_subtest test2_stack/; use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Exporter; our @ISA = qw(Exporter) } our @EXPORT = qw{ @@ -21,9 +21,9 @@ our @EXPORT = qw{ sub ok($;$@) { my ($bool, $name, @diag) = @_; my $ctx = context(); - $ctx->ok($bool, $name, \@diag); - $ctx->release; - return $bool ? 1 : 0; + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); } sub is($$;$@) { @@ -41,18 +41,16 @@ sub is($$;$@) { $bool = 1; } - unless ($bool) { - $got = '*NOT DEFINED*' unless defined $got; - $want = '*NOT DEFINED*' unless defined $want; - unshift @diag => ( - "GOT: $got", - "EXPECTED: $want", - ); - } + return $ctx->pass_and_release($name) if $bool; - $ctx->ok($bool, $name, \@diag); - $ctx->release; - return $bool; + $got = '*NOT DEFINED*' unless defined $got; + $want = '*NOT DEFINED*' unless defined $want; + unshift @diag => ( + "GOT: $got", + "EXPECTED: $want", + ); + + return $ctx->fail_and_release($name, @diag); } sub isnt($$;$@) { @@ -70,12 +68,12 @@ sub isnt($$;$@) { $bool = 0; } + return $ctx->pass_and_release($name) if $bool; + unshift @diag => "Strings are the same (they should not be)" unless $bool; - $ctx->ok($bool, $name, \@diag); - $ctx->release; - return $bool; + return $ctx->fail_and_release($name, @diag); } sub like($$;$@) { @@ -95,9 +93,8 @@ sub like($$;$@) { unshift @diag => "Got an undefined value."; } - $ctx->ok($bool, $name, \@diag); - $ctx->release; - return $bool; + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); } sub unlike($$;$@) { @@ -118,9 +115,8 @@ sub unlike($$;$@) { unshift @diag => "Got an undefined value."; } - $ctx->ok($bool, $name, \@diag); - $ctx->release; - return $bool; + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); } sub is_deeply($$;$@) { @@ -129,6 +125,10 @@ sub is_deeply($$;$@) { no warnings 'once'; require Data::Dumper; + + # Otherwise numbers might be unquoted + local $Data::Dumper::Useperl = 1; + local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Deparse = 1; local $Data::Dumper::Freezer = 'XXX'; @@ -147,11 +147,8 @@ sub is_deeply($$;$@) { my $bool = $g eq $w; - my $diff; - - $ctx->ok($bool, $name, [$diff ? $diff : ($g, $w), @diag]); - $ctx->release; - return $bool; + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, $g, $w, @diag); } sub diag { @@ -183,16 +180,13 @@ sub todo { my $filter = $hub->pre_filter( sub { my ($active_hub, $event) = @_; - - # Turn a diag into a note - return Test2::Event::Note->new(%$event) if ref($event) eq 'Test2::Event::Diag'; - - # Set todo on ok's - if ($hub == $active_hub && $event->isa('Test2::Event::Ok')) { - $event->set_todo($reason); - $event->set_effective_pass(1); + if ($active_hub == $hub) { + $event->set_todo($reason) if $event->can('set_todo'); + $event->add_amnesty([todo => $reason]); + } + else { + $event->add_amnesty({tag => 'todo', details => $reason, inherited => 1}); } - return $event; }, inherit => 1, @@ -237,7 +231,9 @@ sub tests { my ($name, $code) = @_; my $ctx = context(); - before_each() if __PACKAGE__->can('before_each'); + my $be = caller->can('before_each'); + + $be->($name) if $be; my $bool = run_subtest($name, $code, 1); @@ -415,7 +411,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Transition.pod b/cpan/Test-Simple/lib/Test2/Transition.pod index 95f9d77e9b..c0d9342265 100644 --- a/cpan/Test-Simple/lib/Test2/Transition.pod +++ b/cpan/Test-Simple/lib/Test2/Transition.pod @@ -256,6 +256,14 @@ internals. Fixed in version: 0.15 +=item Test::More::Prefix + +Worked by applying a role that wrapped C<< Test::Builder->_print_comment >>. +Fixed by adding an event filter that modifies the message instead when running +under Test2. + +Fixed in version: 0.007 + =back =head2 STILL BROKEN @@ -298,14 +306,6 @@ something new (Test2) to completely rewrite it in a sane way. Still broken as of version: 0.32 -=item Test::More::Prefix - -The current version, 0.005 is broken. A patch has been applied in git, and -released in 0.006, but a version issue with 0.006 prevents its installation. - -Still broken as of version: 0.005 -Potentially fixed in version: 0.006 (not installable) - =item Net::BitTorrent The tests for this module directly access L<Test::Builder> hash keys. Most, if @@ -502,7 +502,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Util.pm b/cpan/Test-Simple/lib/Test2/Util.pm index 53379d41dd..51c7fc97b5 100644 --- a/cpan/Test-Simple/lib/Test2/Util.pm +++ b/cpan/Test-Simple/lib/Test2/Util.pm @@ -2,10 +2,12 @@ package Test2::Util; use strict; use warnings; -our $VERSION = '1.302073'; - +our $VERSION = '1.302096'; +use POSIX(); use Config qw/%Config/; +use Carp qw/croak/; +use PerlIO(); our @EXPORT_OK = qw{ try @@ -17,9 +19,18 @@ our @EXPORT_OK = qw{ CAN_REALLY_FORK CAN_FORK + CAN_SIGSYS + IS_WIN32 ipc_separator + + clone_io + do_rename do_unlink + + try_sig_mask + + clone_io }; BEGIN { require Exporter; our @ISA = qw(Exporter) } @@ -143,6 +154,113 @@ sub pkg_to_file { sub ipc_separator() { "~" } +sub _check_for_sig_sys { + my $sig_list = shift; + return $sig_list =~ m/\bSYS\b/; +} + +BEGIN { + if (_check_for_sig_sys($Config{sig_name})) { + *CAN_SIGSYS = sub() { 1 }; + } + else { + *CAN_SIGSYS = sub() { 0 }; + } +} + +my %PERLIO_SKIP = ( + unix => 1, + via => 1, +); + +sub clone_io { + my ($fh) = @_; + my $fileno = fileno($fh) or croak "Could not get fileno for handle"; + + my %seen; + open(my $out, '>&', $fileno) or die "Can't dup fileno $fileno: $!"; + binmode($out, join(":", "", "raw", grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers(STDOUT))); + + my $old = select $fh; + my $af = $|; + select $out; + $| = $af; + select $old; + + return $out; +} + +BEGIN { + if (IS_WIN32) { + my $max_tries = 5; + + *do_rename = sub { + my ($from, $to) = @_; + + my $err; + for (1 .. $max_tries) { + return (1) if rename($from, $to); + $err = "$!"; + last if $_ == $max_tries; + sleep 1; + } + + return (0, $err); + }; + *do_unlink = sub { + my ($file) = @_; + + my $err; + for (1 .. $max_tries) { + return (1) if unlink($file); + $err = "$!"; + last if $_ == $max_tries; + sleep 1; + } + + return (0, "$!"); + }; + } + else { + *do_rename = sub { + my ($from, $to) = @_; + return (1) if rename($from, $to); + return (0, "$!"); + }; + *do_unlink = sub { + my ($file) = @_; + return (1) if unlink($file); + return (0, "$!"); + }; + } +} + +sub try_sig_mask(&) { + my $code = shift; + + my ($old, $blocked); + unless(IS_WIN32) { + my $to_block = POSIX::SigSet->new( + POSIX::SIGINT(), + POSIX::SIGALRM(), + POSIX::SIGHUP(), + POSIX::SIGTERM(), + POSIX::SIGUSR1(), + POSIX::SIGUSR2(), + ); + $old = POSIX::SigSet->new; + $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old); + # Silently go on if we failed to log signals, not much we can do. + } + + my ($ok, $err) = &try($code); + + # If our block was successful we want to restore the old mask. + POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; + + return ($ok, $err); +} + 1; __END__ @@ -204,6 +322,42 @@ otherwise it returns 0. Convert a package name to a filename. +=item ($ok, $err) = do_rename($old_name, $new_name) + +Rename a file, this wraps C<rename()> in a way that makes it more reliable +cross-platform when trying to rename files you recently altered. + +=item ($ok, $err) = do_unlink($filename) + +Unlink a file, this wraps C<unlink()> in a way that makes it more reliable +cross-platform when trying to unlink files you recently altered. + +=item ($ok, $err) = try_sig_mask { ... } + +Complete an action with several signals masked, they will be unmasked at the +end allowing any signals that were intercepted to get handled. + +This is primarily used when you need to make several actions atomic (against +some signals anyway). + +Signals that are intercepted: + +=over 4 + +=item SIGINT + +=item SIGALRM + +=item SIGHUP + +=item SIGTERM + +=item SIGUSR1 + +=item SIGUSR2 + +=back + =back =head1 NOTES && CAVEATS @@ -248,7 +402,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm b/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm index f9c611e0f2..b3f3884e6f 100644 --- a/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm +++ b/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm @@ -2,7 +2,7 @@ package Test2::Util::ExternalMeta; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Carp qw/croak/; @@ -172,7 +172,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm b/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm new file mode 100644 index 0000000000..5ee96e33cd --- /dev/null +++ b/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm @@ -0,0 +1,114 @@ +package Test2::Util::Facets2Legacy; +use strict; +use warnings; + +our $VERSION = '1.302096'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use base 'Exporter'; +our @EXPORT_OK = qw{ + causes_fail + diagnostics + global + increments_count + no_display + sets_plan + subtest_id + summary + terminate +}; +our %EXPORT_TAGS = ( ALL => \@EXPORT_OK ); + +our $CYCLE_DETECT = 0; +sub _get_facet_data { + my $in = shift; + + if (blessed($in) && $in->isa('Test2::Event')) { + confess "Cycle between Facets2Legacy and $in\->facet_data() (Did you forget to override the facet_data() method?)" + if $CYCLE_DETECT; + + local $CYCLE_DETECT = 1; + return $in->facet_data; + } + + return $in if ref($in) eq 'HASH'; + + croak "'$in' Does not appear to be either a Test::Event or an EventFacet hashref"; +} + +sub causes_fail { + my $facet_data = _get_facet_data(shift @_); + + return 1 if $facet_data->{errors} && grep { $_->{fail} } @{$facet_data->{errors}}; + + if (my $control = $facet_data->{control}) { + return 1 if $control->{halt}; + return 1 if $control->{terminate}; + } + + return 0 if $facet_data->{amnesty} && @{$facet_data->{amnesty}}; + return 1 if $facet_data->{assert} && !$facet_data->{assert}->{pass}; + return 0; +} + +sub diagnostics { + my $facet_data = _get_facet_data(shift @_); + return 1 if $facet_data->{errors} && @{$facet_data->{errors}}; + return 0 unless $facet_data->{info} && @{$facet_data->{info}}; + return (grep { $_->{debug} } @{$facet_data->{info}}) ? 1 : 0; +} + +sub global { + my $facet_data = _get_facet_data(shift @_); + return 0 unless $facet_data->{control}; + return $facet_data->{control}->{global}; +} + +sub increments_count { + my $facet_data = _get_facet_data(shift @_); + return $facet_data->{assert} ? 1 : 0; +} + +sub no_display { + my $facet_data = _get_facet_data(shift @_); + return 0 unless $facet_data->{about}; + return $facet_data->{about}->{no_display}; +} + +sub sets_plan { + my $facet_data = _get_facet_data(shift @_); + my $plan = $facet_data->{plan} or return; + my @out = ($plan->{count} || 0); + + if ($plan->{skip}) { + push @out => 'SKIP'; + push @out => $plan->{details} if defined $plan->{details}; + } + elsif ($plan->{none}) { + push @out => 'NO PLAN' + } + + return @out; +} + +sub subtest_id { + my $facet_data = _get_facet_data(shift @_); + return undef unless $facet_data->{parent}; + return $facet_data->{parent}->{hid}; +} + +sub summary { + my $facet_data = _get_facet_data(shift @_); + return '' unless $facet_data->{about} && $facet_data->{about}->{details}; + return $facet_data->{about}->{details}; +} + +sub terminate { + my $facet_data = _get_facet_data(shift @_); + return undef unless $facet_data->{control}; + return $facet_data->{control}->{terminate}; +} + +1; diff --git a/cpan/Test-Simple/lib/Test2/Util/HashBase.pm b/cpan/Test-Simple/lib/Test2/Util/HashBase.pm index 76041efe5e..138ac2b7b5 100644 --- a/cpan/Test-Simple/lib/Test2/Util/HashBase.pm +++ b/cpan/Test-Simple/lib/Test2/Util/HashBase.pm @@ -12,8 +12,11 @@ use warnings; { no warnings 'once'; - $Test2::Util::HashBase::VERSION = '0.002'; + $Test2::Util::HashBase::VERSION = '0.005'; *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; + *Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; + *Test2::Util::HashBase::VERSION = \%Object::HashBase::VERSION; + *Test2::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; } @@ -46,9 +49,16 @@ sub import { my $class = shift; my $into = caller; - my $isa = _isa($into); + # Make sure we list the OLDEST version used to create this class. + $Test2::Util::HashBase::VERSION{$into} = $Test2::Util::HashBase::VERSION + if !$Test2::Util::HashBase::VERSION{$into} + || $Test2::Util::HashBase::VERSION{$into} > $Test2::Util::HashBase::VERSION; + + my $isa = _isa($into); + my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$into} ||= []; my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {}; - my %subs = ( + + my %subs = ( ($into->can('new') ? () : (new => \&_new)), (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), ( @@ -56,12 +66,13 @@ sub import { my $p = substr($_, 0, 1); my $x = $_; substr($x, 0, 1) = '' if $STRIP{$p}; + push @$attr_list => $x; my ($sub, $attr) = (uc $x, $x); $sub => ($attr_subs->{$sub} = sub() { $attr }), - $attr => sub { $_[0]->{$attr} }, - $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") }) - : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] }) - : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }), + $attr => sub { $_[0]->{$attr} }, + $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") }) + : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] }) + : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }), } @_ ), ); @@ -70,10 +81,65 @@ sub import { *{"$into\::$_"} = $subs{$_} for keys %subs; } +sub attr_list { + my $class = shift; + + my $isa = _isa($class); + + my %seen; + my @list = grep { !$seen{$_}++ } map { + my @out; + + if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) { + Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()"); + } + else { + my $list = $Test2::Util::HashBase::ATTR_LIST{$_}; + @out = $list ? @$list : () + } + + @out; + } reverse @$isa; + + return @list; +} + sub _new { - my ($class, %params) = @_; - my $self = bless \%params, $class; - $self->init if $self->can('init'); + my $class = shift; + + my $self; + + if (@_ == 1) { + my $arg = shift; + my $type = ref($arg); + + if ($type eq 'HASH') { + $self = bless({%$arg}, $class) + } + else { + Carp::croak("Not sure what to do with '$type' in $class constructor") + unless $type eq 'ARRAY'; + + my %proto; + my @attributes = attr_list($class); + while (@$arg) { + my $val = shift @$arg; + my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); + $proto{$key} = $val; + } + + $self = bless(\%proto, $class); + } + } + else { + $self = bless({@_}, $class); + } + + $Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init') + unless exists $Test2::Util::HashBase::CAN_CACHE{$class}; + + $self->init if $Test2::Util::HashBase::CAN_CACHE{$class}; + $self; } @@ -139,7 +205,10 @@ use it: use warnings; use My::Class; - my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); + # These are all functionally identical + my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); + my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); + my $three = My::Class->new(['MyFoo', 'MyBar']); # Accessors! my $foo = $one->foo; # 'MyFoo' @@ -180,9 +249,13 @@ script. =over 4 -=item $it = $class->new(@VALUES) +=item $it = $class->new(%PAIRS) + +=item $it = $class->new(\%PAIRS) -Create a new instance using key/value pairs. +=item $it = $class->new(\@ORDERED_VALUES) + +Create a new instance. HashBase will not export C<new()> if there is already a C<new()> method in your packages inheritance chain. @@ -204,6 +277,21 @@ This makes it so that HashBase sees that you have your own C<new()> method. Alternatively you can define the method before loading HashBase instead of just declaring it, but that scatters your use statements. +The most common way to create an object is to pass in key/value pairs where +each key is an attribute and each value is what you want assigned to that +attribute. No checking is done to verify the attributes or values are valid, +you may do that in C<init()> if desired. + +If you would like, you can pass in a hashref instead of pairs. When you do so +the hashref will be copied, and the copy will be returned blessed as an object. +There is no way to ask HashBase to bless a specific hashref. + +In some cases an object may only have 1 or 2 attributes, in which case a +hashref may be too verbose for your liking. In these cases you can pass in an +arrayref with only values. The values will be assigned to attributes in the +order the attributes were listed. When there is inheritance involved the +attributes from parent classes will come before subclasses. + =back =head2 HOOKS @@ -215,10 +303,18 @@ declaring it, but that scatters your use statements. This gives you the chance to set some default values to your fields. The only argument is C<$self> with its indexes already set from the constructor. +B<Note:> Test2::Util::HashBase checks for an init using C<< $class->can('init') >> +during construction. It DOES NOT call C<can()> on the created object. Also note +that the result of the check is cached, it is only ever checked once, the first +time an instance of your class is created. This means that adding an C<init()> +method AFTER the first construction will result in it being ignored. + =back =head1 ACCESSORS +=head2 READ/WRITE + To generate accessors you list them when using the module: use Test2::Util::HashBase qw/foo/; @@ -246,6 +342,32 @@ and similar typos. It will not help you if you forget to prefix the '+' though. =back +=head2 READ ONLY + + use Test2::Util::HashBase qw/-foo/; + +=over 4 + +=item set_foo() + +Throws an exception telling you the attribute is read-only. This is exported to +override any active setters for the attribute in a parent class. + +=back + +=head2 DEPRECATED SETTER + + use Test2::Util::HashBase qw/^foo/; + +=over 4 + +=item set_foo() + +This will set the value, but it will also warn you that the method is +deprecated. + +=back + =head1 SUBCLASSING You can subclass an existing HashBase class. @@ -256,6 +378,27 @@ You can subclass an existing HashBase class. The base class is added to C<@ISA> for you, and all constants from base classes are added to subclasses automatically. +=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS + +Test2::Util::HashBase provides a function for retrieving a list of attributes for an +Test2::Util::HashBase class. + +=over 4 + +=item @list = Test2::Util::HashBase::attr_list($class) + +=item @list = $class->Test2::Util::HashBase::attr_list() + +Either form above will work. This will return a list of attributes defined on +the object. This list is returned in the attribute definition order, parent +class attributes are listed before subclass attributes. Duplicate attributes +will be removed before the list is returned. + +B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to +determine the attribute to which each value will be paired. + +=back + =head1 SOURCE The source code repository for HashBase can be found at @@ -279,7 +422,7 @@ F<http://github.com/Test-More/HashBase/>. =head1 COPYRIGHT -Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/cpan/Test-Simple/lib/Test2/Util/Trace.pm b/cpan/Test-Simple/lib/Test2/Util/Trace.pm index 0f10bcb6ad..50c3405265 100644 --- a/cpan/Test-Simple/lib/Test2/Util/Trace.pm +++ b/cpan/Test-Simple/lib/Test2/Util/Trace.pm @@ -1,66 +1,8 @@ package Test2::Util::Trace; -use strict; -use warnings; +require Test2::EventFacet::Trace; +@ISA = ('Test2::EventFacet::Trace'); -our $VERSION = '1.302073'; - - -use Test2::Util qw/get_tid pkg_to_file/; - -use Carp qw/confess/; - -use Test2::Util::HashBase qw{frame detail pid tid}; - -sub init { - confess "The 'frame' attribute is required" - unless $_[0]->{+FRAME}; - - $_[0]->{+PID} = $$ unless defined $_[0]->{+PID}; - $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID}; -} - -sub snapshot { bless {%{$_[0]}}, __PACKAGE__ }; - -sub debug { - my $self = shift; - return $self->{+DETAIL} if $self->{+DETAIL}; - my ($pkg, $file, $line) = $self->call; - return "at $file line $line"; -} - -sub alert { - my $self = shift; - my ($msg) = @_; - warn $msg . ' ' . $self->debug . ".\n"; -} - -sub throw { - my $self = shift; - my ($msg) = @_; - die $msg . ' ' . $self->debug . ".\n"; -} - -sub call { @{$_[0]->{+FRAME}} } - -sub package { $_[0]->{+FRAME}->[0] } -sub file { $_[0]->{+FRAME}->[1] } -sub line { $_[0]->{+FRAME}->[2] } -sub subname { $_[0]->{+FRAME}->[3] } - -sub from_json { - my $class = shift; - my %p = @_; - - my $trace_pkg = delete $p{__PACKAGE__}; - require(pkg_to_file($trace_pkg)); - - return $trace_pkg->new(%p); -} - -sub TO_JSON { - my $self = shift; - return {%$self, __PACKAGE__ => ref $self}; -} +our $VERSION = '1.302096'; 1; @@ -72,86 +14,12 @@ __END__ =head1 NAME -Test2::Util::Trace - Debug information for events +Test2::Util::Trace - Legacy wrapper fro L<Test2::EventFacet::Trace>. =head1 DESCRIPTION -The L<Test2::API::Context> object, as well as all L<Test2::Event> types need to -have access to information about where they were created. This object -represents that information. - -=head1 SYNOPSIS - - use Test2::Util::Trace; - - my $trace = Test2::Util::Trace->new( - frame => [$package, $file, $line, $subname], - ); - -=head1 METHODS - -=over 4 - -=item $trace->set_detail($msg) - -=item $msg = $trace->detail - -Used to get/set a custom trace message that will be used INSTEAD of -C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>. - -=item $str = $trace->debug - -Typically returns the string C<< at <FILE> line <LINE> >>. If C<detail> is set -then its value will be returned instead. - -=item $trace->alert($MESSAGE) - -This issues a warning at the frame (filename and line number where -errors should be reported). - -=item $trace->throw($MESSAGE) - -This throws an exception at the frame (filename and line number where -errors should be reported). - -=item $frame = $trace->frame() - -Get the call frame arrayref. - -=item ($package, $file, $line, $subname) = $trace->call() - -Get the caller details for the debug-info. This is where errors should be -reported. - -=item $pkg = $trace->package - -Get the debug-info package. - -=item $file = $trace->file - -Get the debug-info filename. - -=item $line = $trace->line - -Get the debug-info line number. - -=item $subname = $trace->subname - -Get the debug-info subroutine name. - -=item $hashref = $t->TO_JSON - -This returns a hashref suitable for passing to the C<< -Test2::Util::Trace->from_json >> constructor. It is intended for use with the -L<JSON> family of modules, which will look for a C<TO_JSON> method when -C<convert_blessed> is true. - -=item $t = Test2::Util::Trace->from_json(%$hashref) - -Given the hash of data returned by C<< $t->TO_JSON >>, this method returns a -new trace object of the appropriate subclass. - -=back +All the functionality for this class has been moved to +L<Test2::EventFacet::Trace>. =head1 SOURCE |