diff options
Diffstat (limited to 'cpan/Test-Simple/lib')
64 files changed, 3658 insertions, 1135 deletions
diff --git a/cpan/Test-Simple/lib/Test/Builder.pm b/cpan/Test-Simple/lib/Test/Builder.pm index 052e2793b9..e2a0caa686 100644 --- a/cpan/Test-Simple/lib/Test/Builder.pm +++ b/cpan/Test-Simple/lib/Test/Builder.pm @@ -4,7 +4,7 @@ use 5.006; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { if( $] < 5.008 ) { @@ -42,6 +42,7 @@ our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new; sub _add_ts_hooks { my $self = shift; + my $hub = $self->{Stack}->top; # Take a reference to the hash key, we do this to avoid closing over $self @@ -84,12 +85,26 @@ sub _add_ts_hooks { }, inherit => 1); } +{ + no warnings; + INIT { + use warnings; + Test2::API::test2_load() unless Test2::API::test2_in_preload(); + } +} + sub new { my($class) = shift; unless($Test) { - my $ctx = context(); $Test = $class->create(singleton => 1); - $ctx->release; + + Test2::API::test2_add_callback_post_load( + sub { + $Test->{Original_Pid} = $$ if !$Test->{Original_Pid} || $Test->{Original_Pid} == 0; + $Test->reset(singleton => 1); + $Test->_add_ts_hooks; + } + ); # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So # we only want the level to change if $Level != 1. @@ -117,9 +132,10 @@ sub create { formatter => Test::Builder::Formatter->new, ipc => Test2::API::test2_ipc(), ); + + $self->reset(%params); + $self->_add_ts_hooks; } - $self->reset(%params); - $self->_add_ts_hooks; return $self; } @@ -143,7 +159,8 @@ sub parent { my $chub = $self->{Hub} || $ctx->hub; $ctx->release; - my $parent = $chub->meta(__PACKAGE__, {})->{parent}; + my $meta = $chub->meta(__PACKAGE__, {}); + my $parent = $meta->{parent}; return undef unless $parent; @@ -187,7 +204,7 @@ sub child { $hub->listen(sub { push @$subevents => $_[1] }); - $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 ); + $hub->set_nested( $parent->nested + 1 ); my $meta = $hub->meta(__PACKAGE__, {}); $meta->{Name} = $name; @@ -202,7 +219,7 @@ sub child { $self->_add_ts_hooks; $ctx->release; - return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub }, blessed($self); + return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub, no_log_results => $self->{no_log_results} }, blessed($self); } sub finalize { @@ -229,7 +246,7 @@ sub finalize { my $trace = $ctx->trace; delete $ctx->hub->meta(__PACKAGE__, {})->{child}; - $chub->finalize($trace, 1) + $chub->finalize($trace->snapshot(hid => $chub->hid, nested => $chub->nested), 1) if $ok && $chub->count && !$chub->no_ending @@ -372,15 +389,21 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) # hash keys is just asking for pain. Also, it was documented. $Level = 1; - $self->{Original_Pid} = $$; + $self->{no_log_results} = $ENV{TEST_NO_LOG_RESULTS} ? 1 : 0 + unless $params{singleton}; + + $self->{Original_Pid} = Test2::API::test2_in_preload() ? -1 : $$; my $ctx = $self->ctx; + my $hub = $ctx->hub; + $ctx->release; unless ($params{singleton}) { - $ctx->hub->reset_state(); - $ctx->hub->set_pid($$); - $ctx->hub->set_tid(get_tid); + $hub->reset_state(); + $hub->_tb_reset(); } + $ctx = $self->ctx; + my $meta = $ctx->hub->meta(__PACKAGE__, {}); %$meta = ( Name => $0, @@ -388,9 +411,10 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) Done_Testing => undef, Skip_All => 0, Test_Results => [], + parent => $meta->{parent}, ); - $self->{Exported_To} = undef; + $self->{Exported_To} = undef unless $params{singleton}; $self->{Orig_Handles} ||= do { my $format = $ctx->hub->format; @@ -402,8 +426,8 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) }; $self->use_numbers(1); - $self->no_header(0); - $self->no_ending(0); + $self->no_header(0) unless $params{singleton}; + $self->no_ending(0) unless $params{singleton}; $self->reset_outputs; $ctx->release; @@ -629,7 +653,7 @@ sub ok { (name => defined($name) ? $name : ''), }; - $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result; + $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result unless $self->{no_log_results}; my $orig_name = $name; @@ -644,7 +668,7 @@ sub ok { } my $e = bless { - trace => bless( {%$trace}, 'Test2::Util::Trace'), + trace => bless( {%$trace}, 'Test2::EventFacet::Trace'), pass => $test, name => $name, _meta => {'Test::Builder' => $result}, @@ -667,9 +691,6 @@ sub _ok_debug { my $msg = $is_todo ? "Failed (TODO)" : "Failed"; - my $dfh = $self->_diag_fh; - print $dfh "\n" if $ENV{HARNESS_ACTIVE} && $dfh; - my (undef, $file, $line) = $trace->call; if (defined $orig_name) { $self->diag(qq[ $msg test '$orig_name'\n]); @@ -1004,7 +1025,7 @@ sub skip { name => $name, type => 'skip', reason => $why, - }; + } unless $self->{no_log_results}; $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $name =~ s{\n}{\n# }sg; @@ -1029,7 +1050,7 @@ sub todo_skip { name => '', type => 'todo_skip', reason => $why, - }; + } unless $self->{no_log_results}; $why =~ s{\n}{\n# }sg; my $tctx = $ctx->snapshot; @@ -1196,8 +1217,17 @@ sub diag { my $self = shift; return unless @_; + my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; + + if (Test2::API::test2_in_preload()) { + chomp($text); + $text =~ s/^/# /msg; + print STDERR $text, "\n"; + return 0; + } + my $ctx = $self->ctx; - $ctx->diag(join '' => map {defined($_) ? $_ : 'undef'} @_); + $ctx->diag($text); $ctx->release; return 0; } @@ -1207,8 +1237,17 @@ sub note { my $self = shift; return unless @_; + my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; + + if (Test2::API::test2_in_preload()) { + chomp($text); + $text =~ s/^/# /msg; + print STDOUT $text, "\n"; + return 0; + } + my $ctx = $self->ctx; - $ctx->note(join '' => map {defined($_) ? $_ : 'undef'} @_); + $ctx->note($text); $ctx->release; return 0; } @@ -1351,23 +1390,25 @@ sub current_test { if( defined $num ) { $hub->set_count($num); - # If the test counter is being pushed forward fill in the details. - my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; - if( $num > @$test_results ) { - my $start = @$test_results ? @$test_results : 0; - for( $start .. $num - 1 ) { - $test_results->[$_] = { - 'ok' => 1, - actual_ok => undef, - reason => 'incrementing test number', - type => 'unknown', - name => undef - }; + unless ($self->{no_log_results}) { + # If the test counter is being pushed forward fill in the details. + my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; + if ($num > @$test_results) { + my $start = @$test_results ? @$test_results : 0; + for ($start .. $num - 1) { + $test_results->[$_] = { + 'ok' => 1, + actual_ok => undef, + reason => 'incrementing test number', + type => 'unknown', + name => undef + }; + } + } + # If backward, wipe history. Its their funeral. + elsif ($num < @$test_results) { + $#{$test_results} = $num - 1; } - } - # If backward, wipe history. Its their funeral. - elsif( $num < @$test_results ) { - $#{$test_results} = $num - 1; } } return release $ctx, $hub->count; @@ -1393,6 +1434,8 @@ sub is_passing { sub summary { my($self) = shift; + return if $self->{no_log_results}; + my $ctx = $self->ctx; my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; $ctx->release; @@ -1402,6 +1445,9 @@ sub summary { sub details { my $self = shift; + + return if $self->{no_log_results}; + my $ctx = $self->ctx; my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; $ctx->release; @@ -1702,12 +1748,15 @@ sub coordinate_forks { } Test2::IPC->import; Test2::API::test2_ipc_enable_polling(); + Test2::API::test2_load(); my $ipc = Test2::IPC::apply_ipc($self->{Stack}); $ipc->set_no_fatal(1); Test2::API::test2_no_wait(1); Test2::API::test2_ipc_enable_shm(); } +sub no_log_results { $_[0]->{no_log_results} = 1 } + 1; __END__ @@ -2082,7 +2131,7 @@ test failed. Defaults to 1. -Setting L<$Test::Builder::Level> overrides. This is typically useful +Setting C<$Test::Builder::Level> overrides. This is typically useful localized: sub my_ok { @@ -2251,6 +2300,16 @@ point where the original test function was called (C<< $tb->caller >>). =over 4 +=item B<no_log_results> + +This will turn off result long-term storage. Calling this method will make +C<details> and C<summary> useless. You may want to use this if you are running +enough tests to fill up all available memory. + + Test::Builder->new->no_log_results(); + +There is no way to turn it back on. + =item B<current_test> my $curr_test = $Test->current_test; diff --git a/cpan/Test-Simple/lib/Test/Builder/Formatter.pm b/cpan/Test-Simple/lib/Test/Builder/Formatter.pm index 96571c6005..44b7cd43ea 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Formatter.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Formatter.pm @@ -2,7 +2,7 @@ package Test::Builder::Formatter; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } @@ -16,43 +16,42 @@ BEGIN { *OUT_TODO = sub() { $todo }; } -__PACKAGE__->register_event('Test::Builder::TodoDiag', 'event_todo_diag'); - sub init { my $self = shift; $self->SUPER::init(@_); $self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD]; } -sub event_todo_diag { - my $self = shift; - my @out = $self->event_diag(@_); - $out[0]->[0] = OUT_TODO(); - return @out; +sub plan_tap { + my ($self, $f) = @_; + + return if $self->{+NO_HEADER}; + return $self->SUPER::plan_tap($f); } -sub event_diag { - my $self = shift; +sub debug_tap { + my ($self, $f, $num) = @_; return if $self->{+NO_DIAG}; - return $self->SUPER::event_diag(@_); + my @out = $self->SUPER::debug_tap($f, $num); + $self->redirect(\@out) if @out && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; + return @out; } -sub event_plan { - my $self = shift; - return if $self->{+NO_HEADER}; - return $self->SUPER::event_plan(@_); +sub info_tap { + my ($self, $f) = @_; + return if $self->{+NO_DIAG}; + my @out = $self->SUPER::info_tap($f); + $self->redirect(\@out) if @out && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; + return @out; } -sub event_ok_multiline { - my $self = shift; - my ($out, $space, @extra) = @_; - - return( - [OUT_STD, "$out\n"], - map {[OUT_STD, "# $_\n"]} @extra, - ); +sub redirect { + my ($self, $out) = @_; + $_->[0] = OUT_TODO for @$out; } +sub no_subtest_space { 1 } + 1; __END__ @@ -73,22 +72,6 @@ This is what takes events and turns them into TAP. use Test::Builder; # Loads Test::Builder::Formatter for you -=head1 METHODS - -=over 4 - -=item $f->event_todo_diag - -Additional method used to process L<Test::Builder::TodoDiag> events. - -=item $f->event_diag - -=item $f->event_plan - -These override the parent class methods to do nothing if C<no_header> is set. - -=back - =head1 SOURCE The source code repository for Test2 can be found at @@ -112,7 +95,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/Test/Builder/Module.pm b/cpan/Test-Simple/lib/Test/Builder/Module.pm index 6fbba79fc0..1114ec9bb5 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Module.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Module.pm @@ -7,7 +7,7 @@ use Test::Builder; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; =head1 NAME @@ -75,6 +75,8 @@ C<import_extra()>. sub import { my($class) = shift; + Test2::API::test2_load() unless Test2::API::test2_in_preload(); + # Don't run all this when loading ourself. return 1 if $class eq 'Test::Builder::Module'; diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester.pm b/cpan/Test-Simple/lib/Test/Builder/Tester.pm index 647ea2d371..00dc38dd66 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester; use strict; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Test::Builder; use Symbol; @@ -117,7 +117,7 @@ sub _start_testing { $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; $ENV{HARNESS_ACTIVE} = 0; - my $hub = $t->{Hub} || Test2::API::test2_stack->top; + my $hub = $t->{Hub} || ($t->{Stack} ? $t->{Stack}->top : Test2::API::test2_stack->top); $original_formatter = $hub->format; unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) { my $fmt = Test::Builder::Formatter->new; diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm index 939e7f1cd3..a3f1f708ae 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester::Color; use strict; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; require Test::Builder::Tester; diff --git a/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm b/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm index 74ae0787b6..8c02d73834 100644 --- a/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm +++ b/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm @@ -2,12 +2,19 @@ package Test::Builder::TodoDiag; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) } sub diagnostics { 0 } +sub facet_data { + my $self = shift; + my $out = $self->SUPER::facet_data(); + $out->{info}->[0]->{debug} = 0; + return $out; +} + 1; __END__ @@ -51,7 +58,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/Test/More.pm b/cpan/Test-Simple/lib/Test/More.pm index 2863c1bba5..4c08fea63f 100644 --- a/cpan/Test-Simple/lib/Test/More.pm +++ b/cpan/Test-Simple/lib/Test/More.pm @@ -17,7 +17,7 @@ sub _carp { return warn @_, " at $file line $line\n"; } -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); diff --git a/cpan/Test-Simple/lib/Test/Simple.pm b/cpan/Test-Simple/lib/Test/Simple.pm index f148fe62c9..16a657489e 100644 --- a/cpan/Test-Simple/lib/Test/Simple.pm +++ b/cpan/Test-Simple/lib/Test/Simple.pm @@ -4,7 +4,7 @@ use 5.006; use strict; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); diff --git a/cpan/Test-Simple/lib/Test/Tester.pm b/cpan/Test-Simple/lib/Test/Tester.pm index a324a1bf47..b8dde127df 100644 --- a/cpan/Test-Simple/lib/Test/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Tester.pm @@ -18,7 +18,7 @@ require Exporter; use vars qw( @ISA @EXPORT ); -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; @EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); @ISA = qw( Exporter ); diff --git a/cpan/Test-Simple/lib/Test/Tester/Capture.pm b/cpan/Test-Simple/lib/Test/Tester/Capture.pm index d8eb170b6c..e6965fc69b 100644 --- a/cpan/Test-Simple/lib/Test/Tester/Capture.pm +++ b/cpan/Test-Simple/lib/Test/Tester/Capture.pm @@ -2,7 +2,7 @@ use strict; package Test::Tester::Capture; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Test::Builder; diff --git a/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm b/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm index bed18e8c48..18c17f7a14 100644 --- a/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm +++ b/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm @@ -3,7 +3,7 @@ use strict; package Test::Tester::CaptureRunner; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Test::Tester::Capture; diff --git a/cpan/Test-Simple/lib/Test/Tester/Delegate.pm b/cpan/Test-Simple/lib/Test/Tester/Delegate.pm index ed627db442..8e87ca6254 100644 --- a/cpan/Test-Simple/lib/Test/Tester/Delegate.pm +++ b/cpan/Test-Simple/lib/Test/Tester/Delegate.pm @@ -3,7 +3,7 @@ use warnings; package Test::Tester::Delegate; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use Scalar::Util(); diff --git a/cpan/Test-Simple/lib/Test/Tutorial.pod b/cpan/Test-Simple/lib/Test/Tutorial.pod index a71a9c1b3f..eb38018b8b 100644 --- a/cpan/Test-Simple/lib/Test/Tutorial.pod +++ b/cpan/Test-Simple/lib/Test/Tutorial.pod @@ -297,7 +297,7 @@ Now we can test bunches of dates by just adding them to C<%ICal_Dates>. Now that it's less work to test with more dates, you'll be inclined to just throw more in as you think of them. Only problem is, every time we add to that we have to keep adjusting -the L<< use Test::More tests => ## >> line. That can rapidly get +the C<< use Test::More tests => ## >> line. That can rapidly get annoying. There are ways to make this work better. First, we can calculate the plan dynamically using the C<plan()> @@ -358,7 +358,7 @@ for you or for the next person who runs your test. =head2 Skipping tests -Poking around in the existing Date::ICal tests, I found this in +Poking around in the existing L<Date::ICal> tests, I found this in F<t/01sanity.t> [7] #!/usr/bin/perl -w diff --git a/cpan/Test-Simple/lib/Test/use/ok.pm b/cpan/Test-Simple/lib/Test/use/ok.pm index fdc7326b3d..042996bf08 100644 --- a/cpan/Test-Simple/lib/Test/use/ok.pm +++ b/cpan/Test-Simple/lib/Test/use/ok.pm @@ -1,7 +1,7 @@ package Test::use::ok; use 5.005; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; __END__ diff --git a/cpan/Test-Simple/lib/Test2.pm b/cpan/Test-Simple/lib/Test2.pm index 1b65b334b5..61eee99d57 100644 --- a/cpan/Test-Simple/lib/Test2.pm +++ b/cpan/Test-Simple/lib/Test2.pm @@ -2,7 +2,7 @@ package Test2; use strict; use warnings; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; 1; @@ -203,7 +203,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.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 diff --git a/cpan/Test-Simple/lib/ok.pm b/cpan/Test-Simple/lib/ok.pm index 143885dd53..04c38d8700 100644 --- a/cpan/Test-Simple/lib/ok.pm +++ b/cpan/Test-Simple/lib/ok.pm @@ -1,5 +1,5 @@ package ok; -our $VERSION = '1.302073'; +our $VERSION = '1.302096'; use strict; use Test::More (); |