diff options
Diffstat (limited to 'cpan')
152 files changed, 6849 insertions, 1941 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 (); diff --git a/cpan/Test-Simple/t/Test2/modules/Util/HashBase.t b/cpan/Test-Simple/t/HashBase.t index 7f1824ae16..aa4d4358a8 100644 --- a/cpan/Test-Simple/t/Test2/modules/Util/HashBase.t +++ b/cpan/Test-Simple/t/HashBase.t @@ -90,7 +90,7 @@ BEGIN { package main::HBase::Wrapped; - use Test2::Util::HashBase qw/foo bar/; + use Test2::Util::HashBase qw/foo bar dup/; my $foo = __PACKAGE__->can('foo'); no warnings 'redefine'; @@ -107,7 +107,7 @@ BEGIN { package main::HBase::Wrapped::Inherit; use base 'main::HBase::Wrapped'; - use Test2::Util::HashBase; + use Test2::Util::HashBase qw/baz dup/; } my $o = main::HBase::Wrapped::Inherit->new(foo => 1); @@ -152,6 +152,84 @@ like(exception { $ro->set_bar('xxx') }, qr/'bar' is read-only/, "Cannot set bar" my $warnings = warnings { is($ro->set_baz('xxx'), 'xxx', 'set baz') }; like($warnings->[0], qr/set_baz\(\) is deprecated/, "Deprecation warning"); + + +is_deeply( + [Test2::Util::HashBase::attr_list('main::HBase::Wrapped::Inherit')], + [qw/foo bar dup baz/], + "Got a list of attributes in order starting from base class, duplicates removed", +); + +my $x = main::HBase::Wrapped::Inherit->new(foo => 1, baz => 2); +is($x->foo, 1, "set foo via pairs"); +is($x->baz, 2, "set baz via pairs"); + +# Now with hashref +my $y = main::HBase::Wrapped::Inherit->new({foo => 1, baz => 2}); +is($y->foo, 1, "set foo via hashref"); +is($y->baz, 2, "set baz via hashref"); + +# Now with hashref +my $z = main::HBase::Wrapped::Inherit->new([ + 1, # foo + 2, # bar + 3, # dup + 4, # baz +]); +is($z->foo, 1, "set foo via arrayref"); +is($z->baz, 4, "set baz via arrayref"); + +like( + exception { main::HBase::Wrapped::Inherit->new([1 .. 10]) }, + qr/Too many arguments for main::HBase::Wrapped::Inherit constructor/, + "Too many args in array form" +); + + +my $CAN_COUNT = 0; +my $CAN_COUNT2 = 0; +my $INIT_COUNT = 0; +BEGIN { + $INC{'Object/HashBase/Test/HBase3.pm'} = __FILE__; + package + main::HBase3; + use Test2::Util::HashBase qw/foo/; + + sub can { + my $self = shift; + $CAN_COUNT++; + $self->SUPER::can(@_); + } + + $INC{'Object/HashBase/Test/HBase4.pm'} = __FILE__; + package + main::HBase4; + use Test2::Util::HashBase qw/foo/; + + sub can { + my $self = shift; + $CAN_COUNT2++; + $self->SUPER::can(@_); + } + + sub init { $INIT_COUNT++ } +} + +is($CAN_COUNT, 0, "->can has not been called yet"); +my $it = main::HBase3->new; +is($CAN_COUNT, 1, "->can has been called once to check for init"); +$it = main::HBase3->new; +is($CAN_COUNT, 1, "->can was not called again, we cached it"); + +is($CAN_COUNT2, 0, "->can has not been called yet"); +is($INIT_COUNT, 0, "->init has not been called yet"); +$it = main::HBase4->new; +is($CAN_COUNT2, 1, "->can has been called once to check for init"); +is($INIT_COUNT, 1, "->init has been called once"); +$it = main::HBase4->new; +is($CAN_COUNT2, 1, "->can was not called again, we cached it"); +is($INIT_COUNT, 2, "->init has been called again"); + done_testing; 1; diff --git a/cpan/Test-Simple/t/Legacy/Builder/done_testing_double.t b/cpan/Test-Simple/t/Legacy/Builder/done_testing_double.t index 3a0bae247b..ef5e0778cf 100644 --- a/cpan/Test-Simple/t/Legacy/Builder/done_testing_double.t +++ b/cpan/Test-Simple/t/Legacy/Builder/done_testing_double.t @@ -16,18 +16,22 @@ use Test::Builder::NoOutput; my $tb = Test::Builder::NoOutput->create; +# $tb methods expect to be wrapped in at least 1 sub +sub done_testing { $tb->done_testing(@_) } +sub ok { $tb->ok(@_) } + { # Normalize test output local $ENV{HARNESS_ACTIVE}; - $tb->ok(1); - $tb->ok(1); - $tb->ok(1); + ok(1); + ok(1); + ok(1); #line 24 - $tb->done_testing(3); - $tb->done_testing; - $tb->done_testing; + done_testing(3); + done_testing; + done_testing; } my $Test = Test::Builder->new; diff --git a/cpan/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t b/cpan/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t index 8208635359..54e7f42a24 100644 --- a/cpan/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t +++ b/cpan/Test-Simple/t/Legacy/Builder/done_testing_plan_mismatch.t @@ -18,17 +18,22 @@ use Test::Builder::NoOutput; my $tb = Test::Builder::NoOutput->create; +# TB methods expect to be wrapped +sub ok { $tb->ok(@_) } +sub plan { $tb->plan(@_) } +sub done_testing { $tb->done_testing(@_) } + { # Normalize test output local $ENV{HARNESS_ACTIVE}; - $tb->plan( tests => 3 ); - $tb->ok(1); - $tb->ok(1); - $tb->ok(1); + plan( tests => 3 ); + ok(1); + ok(1); + ok(1); #line 24 - $tb->done_testing(2); + done_testing(2); } my $Test = Test::Builder->new; diff --git a/cpan/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t b/cpan/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t index 594402ee7f..f084571570 100644 --- a/cpan/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t +++ b/cpan/Test-Simple/t/Legacy/Builder/fork_with_new_stdout.t @@ -3,8 +3,9 @@ use strict; use warnings; use Test2::Util qw/CAN_FORK/; + BEGIN { - unless(CAN_FORK) { + unless (CAN_FORK) { require Test::More; Test::More->import(skip_all => "fork is not supported"); } @@ -20,20 +21,22 @@ $b->reset; $b->plan('tests' => 2); my $pipe = IO::Pipe->new; -if ( my $pid = fork ) { - $pipe->reader; - my ($one, $two) = <$pipe>; - $b->like($one, qr/ok 1/, "ok 1 from child"); - $b->like($two, qr/1\.\.1/, "1..1 from child"); - waitpid($pid, 0); +if (my $pid = fork) { + $pipe->reader; + my ($one, $two) = <$pipe>; + $b->like($one, qr/ok 1/, "ok 1 from child"); + $b->like($two, qr/1\.\.1/, "1..1 from child"); + waitpid($pid, 0); } else { - $pipe->writer; - $b->reset; - $b->no_plan; - $b->output($pipe); - $b->ok(1); - $b->done_testing; + require Test::Builder::Formatter; + $b->{Stack}->top->format(Test::Builder::Formatter->new()); + $pipe->writer; + $b->reset; + $b->no_plan; + $b->output($pipe); + $b->ok(1); + $b->done_testing; } diff --git a/cpan/Test-Simple/t/Legacy/Builder/is_passing.t b/cpan/Test-Simple/t/Legacy/Builder/is_passing.t index d335aada57..d0aed0c2a4 100644 --- a/cpan/Test-Simple/t/Legacy/Builder/is_passing.t +++ b/cpan/Test-Simple/t/Legacy/Builder/is_passing.t @@ -5,7 +5,9 @@ use lib 't/lib'; # We're going to need to override exit() later BEGIN { - *CORE::GLOBAL::exit = sub(;$) { + require Test2::Hub; + no warnings 'redefine'; + *Test2::Hub::terminate = sub { my $status = @_ ? 0 : shift; CORE::exit $status; }; @@ -61,22 +63,19 @@ use Test::Builder::NoOutput; ok $tb->is_passing, " and after the ending"; } - # is_passing() vs skip_all { my $tb = Test::Builder::NoOutput->create; { no warnings 'redefine'; - local *CORE::GLOBAL::exit = sub { - return 1; - }; + local *Test2::Hub::terminate = sub { 1 }; + $tb->plan( "skip_all" ); } ok $tb->is_passing, "Passing with skip_all"; } - # is_passing() vs done_testing(#) { my $tb = Test::Builder::NoOutput->create; diff --git a/cpan/Test-Simple/t/Legacy/Builder/no_diag.t b/cpan/Test-Simple/t/Legacy/Builder/no_diag.t index 6fa538a82e..ed154a7e15 100644 --- a/cpan/Test-Simple/t/Legacy/Builder/no_diag.t +++ b/cpan/Test-Simple/t/Legacy/Builder/no_diag.t @@ -1,8 +1,13 @@ #!/usr/bin/perl -w -use Test::More 'no_diag', tests => 2; +use Test::More 'no_diag'; + +plan 'skip_all' => "This test cannot be run with the current formatter" + unless Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter'); pass('foo'); diag('This should not be displayed'); is(Test::More->builder->no_diag, 1); + +done_testing; diff --git a/cpan/Test-Simple/t/Legacy/Regression/637.t b/cpan/Test-Simple/t/Legacy/Regression/637.t index c3aaf44c79..5fd2da6fce 100644 --- a/cpan/Test-Simple/t/Legacy/Regression/637.t +++ b/cpan/Test-Simple/t/Legacy/Regression/637.t @@ -1,5 +1,6 @@ use strict; use warnings; +# HARNESS-NO-STREAM use Test2::Util qw/CAN_THREAD/; BEGIN { @@ -20,6 +21,9 @@ use Test2::IPC; use threads; use Test::More; +plan 'skip_all' => "This test cannot be run with the current formatter" + unless Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter'); + ok 1 for (1 .. 2); # used to reset the counter after thread finishes @@ -46,7 +50,7 @@ my $subtest_out = async { } ->join; -$subtest_out =~ s/^/ /gm; +$subtest_out =~ s/^/ /gm; print $subtest_out; # reset as if the thread never "said" anything diff --git a/cpan/Test-Simple/t/Legacy/Tester/tbt_08subtest.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_08subtest.t index 6ec508f247..26bbc3b962 100644 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_08subtest.t +++ b/cpan/Test-Simple/t/Legacy/Tester/tbt_08subtest.t @@ -1,4 +1,5 @@ #!/usr/bin/env perl +# HARNESS-NO-STREAM use strict; use warnings; diff --git a/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t b/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t index a0c8b8e2e5..570ca9d7d1 100644 --- a/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t +++ b/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t @@ -9,6 +9,7 @@ use File::Basename qw(dirname); use File::Spec qw(); my $file = File::Spec->join(dirname(__FILE__), 'tbt_09do_script.pl'); +$file = "./$file" unless $file =~ m{^\.?/}; my $done = do $file; ok(defined($done), 'do succeeded') or do { if ($@) { diff --git a/cpan/Test-Simple/t/Legacy/bail_out.t b/cpan/Test-Simple/t/Legacy/bail_out.t index d1c3dce721..94f12acc94 100644 --- a/cpan/Test-Simple/t/Legacy/bail_out.t +++ b/cpan/Test-Simple/t/Legacy/bail_out.t @@ -1,4 +1,6 @@ #!/usr/bin/perl -w +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/cpan/Test-Simple/t/Legacy/c_flag.t b/cpan/Test-Simple/t/Legacy/c_flag.t index a33963415e..02551d09e5 100644 --- a/cpan/Test-Simple/t/Legacy/c_flag.t +++ b/cpan/Test-Simple/t/Legacy/c_flag.t @@ -1,4 +1,6 @@ #!/usr/bin/perl -w +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD # Test::More should not print anything when Perl is only doing # a compile as with the -c flag or B::Deparse or perlcc. diff --git a/cpan/Test-Simple/t/Legacy/died.t b/cpan/Test-Simple/t/Legacy/died.t index c26e86b541..af929cbb81 100644 --- a/cpan/Test-Simple/t/Legacy/died.t +++ b/cpan/Test-Simple/t/Legacy/died.t @@ -1,4 +1,6 @@ #!perl -w +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/cpan/Test-Simple/t/Legacy/extra.t b/cpan/Test-Simple/t/Legacy/extra.t index 55a0007d49..ac82aae7ce 100644 --- a/cpan/Test-Simple/t/Legacy/extra.t +++ b/cpan/Test-Simple/t/Legacy/extra.t @@ -16,35 +16,40 @@ use Test::Builder; use Test::Builder::NoOutput; use Test::Simple; +# TB methods expect to be wrapped +my $ok = sub { shift->ok(@_) }; +my $plan = sub { shift->plan(@_) }; +my $done_testing = sub { shift->done_testing(@_) }; + my $TB = Test::Builder->new; my $test = Test::Builder::NoOutput->create; -$test->plan( tests => 3 ); +$test->$plan( tests => 3 ); local $ENV{HARNESS_ACTIVE} = 0; -$test->ok(1, 'Foo'); +$test->$ok(1, 'Foo'); $TB->is_eq($test->read(), <<END); 1..3 ok 1 - Foo END #line 30 -$test->ok(0, 'Bar'); +$test->$ok(0, 'Bar'); $TB->is_eq($test->read(), <<END); not ok 2 - Bar # Failed test 'Bar' # at $0 line 30. END -$test->ok(1, 'Yar'); -$test->ok(1, 'Car'); +$test->$ok(1, 'Yar'); +$test->$ok(1, 'Car'); $TB->is_eq($test->read(), <<END); ok 3 - Yar ok 4 - Car END #line 45 -$test->ok(0, 'Sar'); +$test->$ok(0, 'Sar'); $TB->is_eq($test->read(), <<END); not ok 5 - Sar # Failed test 'Sar' @@ -57,4 +62,4 @@ $TB->is_eq($test->read(), <<END); # Looks like you failed 2 tests of 5 run. END -$TB->done_testing(5); +$TB->$done_testing(5); diff --git a/cpan/Test-Simple/t/Legacy/extra_one.t b/cpan/Test-Simple/t/Legacy/extra_one.t index d77404e15d..a1a15a67bd 100644 --- a/cpan/Test-Simple/t/Legacy/extra_one.t +++ b/cpan/Test-Simple/t/Legacy/extra_one.t @@ -1,4 +1,6 @@ #!/usr/bin/perl -w +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/cpan/Test-Simple/t/Legacy/fail-like.t b/cpan/Test-Simple/t/Legacy/fail-like.t index 6545507e3a..4ec99aeab0 100644 --- a/cpan/Test-Simple/t/Legacy/fail-like.t +++ b/cpan/Test-Simple/t/Legacy/fail-like.t @@ -1,4 +1,6 @@ #!/usr/bin/perl -w +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { @@ -25,12 +27,10 @@ require Test::Builder; my $TB = Test::Builder->create; $TB->plan(tests => 4); - require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); local $ENV{HARNESS_ACTIVE} = 0; - package main; require Test::More; diff --git a/cpan/Test-Simple/t/Legacy/fail-more.t b/cpan/Test-Simple/t/Legacy/fail-more.t index 5cb373edef..3d28fbb52d 100644 --- a/cpan/Test-Simple/t/Legacy/fail-more.t +++ b/cpan/Test-Simple/t/Legacy/fail-more.t @@ -1,4 +1,6 @@ #!perl -w +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/cpan/Test-Simple/t/Legacy/fail.t b/cpan/Test-Simple/t/Legacy/fail.t index ccf0c74893..ee8f1b6866 100644 --- a/cpan/Test-Simple/t/Legacy/fail.t +++ b/cpan/Test-Simple/t/Legacy/fail.t @@ -20,19 +20,24 @@ local $ENV{HARNESS_ACTIVE} = 0; use Test::Builder; use Test::Builder::NoOutput; +# TB methods expect to be wrapped +my $ok = sub { shift->ok(@_) }; +my $plan = sub { shift->plan(@_) }; +my $done_testing = sub { shift->done_testing(@_) }; + my $Test = Test::Builder->new; # Set up a builder to record some failing tests. { my $tb = Test::Builder::NoOutput->create; - $tb->plan( tests => 5 ); + $tb->$plan( tests => 5 ); #line 28 - $tb->ok( 1, 'passing' ); - $tb->ok( 2, 'passing still' ); - $tb->ok( 3, 'still passing' ); - $tb->ok( 0, 'oh no!' ); - $tb->ok( 0, 'damnit' ); + $tb->$ok( 1, 'passing' ); + $tb->$ok( 2, 'passing still' ); + $tb->$ok( 3, 'still passing' ); + $tb->$ok( 0, 'oh no!' ); + $tb->$ok( 0, 'damnit' ); $tb->_ending; $Test->is_eq($tb->read('out'), <<OUT); @@ -52,5 +57,5 @@ OUT # Looks like you failed 2 tests of 5. ERR - $Test->done_testing(2); + $Test->$done_testing(2); } diff --git a/cpan/Test-Simple/t/Legacy/fail_one.t b/cpan/Test-Simple/t/Legacy/fail_one.t index 61d7c081ff..ddab4fbe0a 100644 --- a/cpan/Test-Simple/t/Legacy/fail_one.t +++ b/cpan/Test-Simple/t/Legacy/fail_one.t @@ -18,15 +18,20 @@ local $ENV{HARNESS_ACTIVE} = 0; use Test::Builder; use Test::Builder::NoOutput; +# TB methods expect to be wrapped +my $ok = sub { shift->ok(@_) }; +my $plan = sub { shift->plan(@_) }; +my $done_testing = sub { shift->done_testing(@_) }; + my $Test = Test::Builder->new; { my $tb = Test::Builder::NoOutput->create; - $tb->plan( tests => 1 ); + $tb->$plan( tests => 1 ); #line 28 - $tb->ok(0); + $tb->$ok(0); $tb->_ending; $Test->is_eq($tb->read('out'), <<OUT); @@ -39,5 +44,5 @@ OUT # Looks like you failed 1 test of 1. ERR - $Test->done_testing(2); + $Test->$done_testing(2); } diff --git a/cpan/Test-Simple/t/Legacy/missing.t b/cpan/Test-Simple/t/Legacy/missing.t index 3b8f1fa9b4..a48533c8cb 100644 --- a/cpan/Test-Simple/t/Legacy/missing.t +++ b/cpan/Test-Simple/t/Legacy/missing.t @@ -1,4 +1,6 @@ +# HARNESS-NO-STREAM # HARNESS-NO-PRELOAD + BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; diff --git a/cpan/Test-Simple/t/Legacy/no_log_results.t b/cpan/Test-Simple/t/Legacy/no_log_results.t new file mode 100644 index 0000000000..859e120dd2 --- /dev/null +++ b/cpan/Test-Simple/t/Legacy/no_log_results.t @@ -0,0 +1,19 @@ +use strict; +use warnings; + +use Test::More; + +sub it { + my $tb = Test::Builder->new; + $tb->no_log_results; + + ok(1, "sample"); + ok(2, "sample"); + + is_deeply([$tb->details], [], "no details were logged"); +} + +it(); +subtest it => \⁢ + +done_testing; diff --git a/cpan/Test-Simple/t/Legacy/no_plan.t b/cpan/Test-Simple/t/Legacy/no_plan.t index 5f392e40e1..559dcfa60c 100644 --- a/cpan/Test-Simple/t/Legacy/no_plan.t +++ b/cpan/Test-Simple/t/Legacy/no_plan.t @@ -14,12 +14,17 @@ use Test::More tests => 7; my $tb = Test::Builder->create; +# TB methods expect to be wrapped +my $ok = sub { shift->ok(@_) }; +my $plan = sub { shift->plan(@_) }; +my $done_testing = sub { shift->done_testing(@_) }; + #line 20 -ok !eval { $tb->plan(tests => undef) }; +ok !eval { $tb->$plan(tests => undef) }; is($@, "Got an undefined number of tests at $0 line 20.\n"); #line 24 -ok !eval { $tb->plan(tests => 0) }; +ok !eval { $tb->$plan(tests => 0) }; is($@, "You said to run 0 tests at $0 line 24.\n"); { @@ -27,7 +32,7 @@ is($@, "You said to run 0 tests at $0 line 24.\n"); local $SIG{__WARN__} = sub { $warning .= join '', @_ }; #line 31 - ok $tb->plan(no_plan => 1); + ok $tb->$plan(no_plan => 1); is( $warning, "no_plan takes no arguments at $0 line 31.\n" ); is $tb->has_plan, 'no_plan'; } diff --git a/cpan/Test-Simple/t/Legacy/no_tests.t b/cpan/Test-Simple/t/Legacy/no_tests.t index 997add59b2..12c37c6885 100644 --- a/cpan/Test-Simple/t/Legacy/no_tests.t +++ b/cpan/Test-Simple/t/Legacy/no_tests.t @@ -1,4 +1,6 @@ #!perl -w +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/cpan/Test-Simple/t/Legacy/skip.t b/cpan/Test-Simple/t/Legacy/skip.t index f2ea9fbf20..9d37c3b39c 100644 --- a/cpan/Test-Simple/t/Legacy/skip.t +++ b/cpan/Test-Simple/t/Legacy/skip.t @@ -1,4 +1,5 @@ #!perl -w +# HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { @@ -42,7 +43,6 @@ SKIP: { is( $line || '', '', ' or line' ); } - SKIP: { skip $Why, 2 if 1; diff --git a/cpan/Test-Simple/t/Legacy/subtest/bail_out.t b/cpan/Test-Simple/t/Legacy/subtest/bail_out.t index bc77325f16..86a50cbbef 100644 --- a/cpan/Test-Simple/t/Legacy/subtest/bail_out.t +++ b/cpan/Test-Simple/t/Legacy/subtest/bail_out.t @@ -1,4 +1,6 @@ #!/usr/bin/perl -w +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { @@ -10,14 +12,20 @@ BEGIN { } } +my $goto = 0; my $Exit_Code; BEGIN { - *CORE::GLOBAL::exit = sub { $Exit_Code = shift; goto XXX}; + *CORE::GLOBAL::exit = sub { $Exit_Code = shift; goto XXX if $goto; CORE::exit($Exit_Code)}; } use Test::Builder; use Test::More; +my $skip = ref(Test::Builder->new->{Stack}->top->format) ne 'Test::Builder::Formatter'; +plan skip_all => "This test cannot be run with the current formatter" + if $skip; + +$goto = 1; my $output; my $TB = Test::More->builder; $TB->output(\$output); diff --git a/cpan/Test-Simple/t/Legacy/subtest/basic.t b/cpan/Test-Simple/t/Legacy/subtest/basic.t index 485057110b..44d370e956 100644 --- a/cpan/Test-Simple/t/Legacy/subtest/basic.t +++ b/cpan/Test-Simple/t/Legacy/subtest/basic.t @@ -17,27 +17,33 @@ use Test::Builder::NoOutput; use Test::More tests => 12; +# TB Methods expect to be wrapped. +my $ok = sub { shift->ok(@_) }; +my $plan = sub { shift->plan(@_) }; +my $diag = sub { shift->diag(@_) }; +my $finalize = sub { shift->finalize(@_) }; + # Formatting may change if we're running under Test::Harness. $ENV{HARNESS_ACTIVE} = 0; { my $tb = Test::Builder::NoOutput->create; - $tb->plan( tests => 7 ); + $tb->$plan( tests => 7 ); for( 1 .. 3 ) { - $tb->ok( $_, "We're on $_" ); - $tb->diag("We ran $_"); + $tb->$ok( $_, "We're on $_" ); + $tb->$diag("We ran $_"); } { my $indented = $tb->child; - $indented->plan('no_plan'); - $indented->ok( 1, "We're on 1" ); - $indented->ok( 1, "We're on 2" ); - $indented->ok( 1, "We're on 3" ); - $indented->finalize; + $indented->$plan('no_plan'); + $indented->$ok( 1, "We're on 1" ); + $indented->$ok( 1, "We're on 2" ); + $indented->$ok( 1, "We're on 3" ); + $indented->$finalize; } for( 7, 8, 9 ) { - $tb->ok( $_, "We're on $_" ); + $tb->$ok( $_, "We're on $_" ); } is $tb->read, <<"END", 'Output should nest properly'; @@ -61,27 +67,27 @@ END { my $tb = Test::Builder::NoOutput->create; - $tb->plan('no_plan'); + $tb->$plan('no_plan'); for( 1 .. 1 ) { - $tb->ok( $_, "We're on $_" ); - $tb->diag("We ran $_"); + $tb->$ok( $_, "We're on $_" ); + $tb->$diag("We ran $_"); } { my $indented = $tb->child; - $indented->plan('no_plan'); - $indented->ok( 1, "We're on 1" ); + $indented->$plan('no_plan'); + $indented->$ok( 1, "We're on 1" ); { my $indented2 = $indented->child('with name'); - $indented2->plan( tests => 2 ); - $indented2->ok( 1, "We're on 2.1" ); - $indented2->ok( 1, "We're on 2.1" ); - $indented2->finalize; + $indented2->$plan( tests => 2 ); + $indented2->$ok( 1, "We're on 2.1" ); + $indented2->$ok( 1, "We're on 2.1" ); + $indented2->$finalize; } - $indented->ok( 1, 'after child' ); - $indented->finalize; + $indented->$ok( 1, 'after child' ); + $indented->$finalize; } for(7) { - $tb->ok( $_, "We're on $_" ); + $tb->$ok( $_, "We're on $_" ); } $tb->_ending; @@ -107,20 +113,20 @@ END { my $child = $tb->child('expected to fail'); - $child->plan( tests => 3 ); - $child->ok(1); - $child->ok(0); - $child->ok(3); - $child->finalize; + $child->$plan( tests => 3 ); + $child->$ok(1); + $child->$ok(0); + $child->$ok(3); + $child->$finalize; } { my $child = $tb->child('expected to pass'); - $child->plan( tests => 3 ); - $child->ok(1); - $child->ok(2); - $child->ok(3); - $child->finalize; + $child->$plan( tests => 3 ); + $child->$ok(1); + $child->$ok(2); + $child->$ok(3); + $child->$finalize; } is $tb->read, <<"END", 'Previous child failures should not force subsequent failures'; 1..3 @@ -144,7 +150,7 @@ END my $child = $tb->child('one'); is $child->{$_}, $tb->{$_}, "The child should copy the ($_) filehandle" foreach qw{Out_FH Todo_FH Fail_FH}; - $child->finalize; + $child->$finalize; } { my $tb = Test::Builder::NoOutput->create; @@ -153,9 +159,9 @@ END can_ok $tb, 'name'; is $child->name, 'one', '... but child names should be whatever we set them to'; - $child->finalize; + $child->$finalize; $child = $tb->child; - $child->finalize; + $child->$finalize; } # Skip all subtests { @@ -163,7 +169,7 @@ END { my $child = $tb->child('skippy says he loves you'); - eval { $child->plan( skip_all => 'cuz I said so' ) }; + eval { $child->$plan( skip_all => 'cuz I said so' ) }; } subtest 'skip all', sub { plan skip_all => 'subtest with skip_all'; @@ -175,13 +181,13 @@ END { #line 204 my $tb = Test::Builder::NoOutput->create; - $tb->plan( tests => 1 ); + $tb->$plan( tests => 1 ); my $child = $tb->child; - $child->plan( tests => 1 ); + $child->$plan( tests => 1 ); $child->todo_start( 'message' ); - $child->ok( 0 ); + $child->$ok( 0 ); $child->todo_end; - $child->finalize; + $child->$finalize; $tb->_ending; is $tb->read, <<"END", 'TODO tests should not make the parent test fail'; 1..1 @@ -193,9 +199,9 @@ END } { my $tb = Test::Builder::NoOutput->create; - $tb->plan( tests => 1 ); + $tb->$plan( tests => 1 ); my $child = $tb->child; - $child->finalize; + $child->$finalize; $tb->_ending; my $expected = <<"END"; 1..1 diff --git a/cpan/Test-Simple/t/Legacy/subtest/do.t b/cpan/Test-Simple/t/Legacy/subtest/do.t index b034893f63..c9efdac892 100644 --- a/cpan/Test-Simple/t/Legacy/subtest/do.t +++ b/cpan/Test-Simple/t/Legacy/subtest/do.t @@ -7,7 +7,7 @@ use Test::More; pass("First"); -my $file = "t/Legacy/subtest/for_do_t.test"; +my $file = "./t/Legacy/subtest/for_do_t.test"; ok -e $file, "subtest test file exists"; subtest $file => sub { do $file }; diff --git a/cpan/Test-Simple/t/Legacy/subtest/events.t b/cpan/Test-Simple/t/Legacy/subtest/events.t index 0fad76dde8..d8470d4683 100644 --- a/cpan/Test-Simple/t/Legacy/subtest/events.t +++ b/cpan/Test-Simple/t/Legacy/subtest/events.t @@ -14,7 +14,7 @@ my $st = $events->[-1]; isa_ok($st, 'Test2::Event::Subtest'); ok(my $id = $st->subtest_id, "got an id"); for my $se (@{$st->subevents}) { - is($se->in_subtest, $id, "set subtest_id on child event"); + is($se->trace->hid, $id, "set subtest_id on child event"); } done_testing; diff --git a/cpan/Test-Simple/t/Legacy/subtest/fork.t b/cpan/Test-Simple/t/Legacy/subtest/fork.t index aaa6cab877..33a8c27187 100644 --- a/cpan/Test-Simple/t/Legacy/subtest/fork.t +++ b/cpan/Test-Simple/t/Legacy/subtest/fork.t @@ -1,6 +1,8 @@ #!/usr/bin/perl -w use strict; use warnings; +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD use Test2::Util qw/CAN_FORK/; BEGIN { @@ -14,6 +16,9 @@ use IO::Pipe; use Test::Builder; use Test::More; +plan 'skip_all' => "This test cannot be run with the current formatter" + unless Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter'); + plan 'tests' => 1; subtest 'fork within subtest' => sub { diff --git a/cpan/Test-Simple/t/Legacy/undef.t b/cpan/Test-Simple/t/Legacy/undef.t index 2c8cace491..c697664b9a 100644 --- a/cpan/Test-Simple/t/Legacy/undef.t +++ b/cpan/Test-Simple/t/Legacy/undef.t @@ -78,13 +78,18 @@ warnings_like(qr/Use of uninitialized value.* at \(eval in cmp_ok\) $Filename li my $tb = Test::More->builder; -my $err = ''; -$tb->failure_output(\$err); -diag(undef); -$tb->reset_outputs; +SKIP: { + skip("Test cannot be run with this formatter", 2) + unless $tb->{Stack}->top->format->isa('Test::Builder::Formatter'); -is( $err, "# undef\n" ); -no_warnings; + my $err = ''; + $tb->failure_output(\$err); + diag(undef); + $tb->reset_outputs; + + is( $err, "# undef\n" ); + no_warnings; +} $tb->maybe_regex(undef); diff --git a/cpan/Test-Simple/t/Legacy/utf8.t b/cpan/Test-Simple/t/Legacy/utf8.t index 2930226e3e..97e4cf4c4a 100644 --- a/cpan/Test-Simple/t/Legacy/utf8.t +++ b/cpan/Test-Simple/t/Legacy/utf8.t @@ -1,4 +1,6 @@ #!/usr/bin/perl -w +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD BEGIN { if( $ENV{PERL_CORE} ) { @@ -23,6 +25,9 @@ BEGIN { } use Test::More; +unless (Test::Builder->new->{Stack}->top->format->isa('Test::Builder::Formatter')) { + plan skip_all => 'Test cannot be run using this formatter'; +} if( !$have_perlio ) { plan skip_all => "Don't have PerlIO"; diff --git a/cpan/Test-Simple/t/Legacy/versions.t b/cpan/Test-Simple/t/Legacy/versions.t index cb83599364..3c46ee76c1 100644 --- a/cpan/Test-Simple/t/Legacy/versions.t +++ b/cpan/Test-Simple/t/Legacy/versions.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +# HARNESS-NO-PRELOAD # Make sure all the modules have the same version # diff --git a/cpan/Test-Simple/t/Legacy_And_Test2/builder_loaded_late.t b/cpan/Test-Simple/t/Legacy_And_Test2/builder_loaded_late.t index 21c712b5e4..1ddb70c9ba 100644 --- a/cpan/Test-Simple/t/Legacy_And_Test2/builder_loaded_late.t +++ b/cpan/Test-Simple/t/Legacy_And_Test2/builder_loaded_late.t @@ -1,10 +1,11 @@ use strict; use warnings; +# HARNESS-NO-PRELOAD use Test2::Tools::Tiny; -use Test2::API qw/intercept/; +use Test2::API qw/intercept test2_stack/; -plan 4; +plan 3; my @warnings; { @@ -12,7 +13,7 @@ my @warnings; require Test::Builder; }; -is(@warnings, 3, "got 3 warnings"); +is(@warnings, 2, "got warnings"); like( $warnings[0], @@ -25,11 +26,3 @@ like( qr/Formatter Test::Builder::Formatter loaded too late to be used as the global formatter/, "Got the formatter warning" ); - -like( - $warnings[2], - qr/The current formatter does not support 'no_header'/, - "Formatter does not support no_header", -); - - diff --git a/cpan/Test-Simple/t/Legacy_And_Test2/preload_diag_note.t b/cpan/Test-Simple/t/Legacy_And_Test2/preload_diag_note.t new file mode 100644 index 0000000000..b557230fdb --- /dev/null +++ b/cpan/Test-Simple/t/Legacy_And_Test2/preload_diag_note.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +BEGIN { + require Test2::API; + Test2::API::test2_start_preload(); +} + +use Test::More; + +my ($stdout, $stderr) = ('', ''); +{ + local *STDOUT; + open(STDOUT, '>', \$stdout) or die "Could not open temp STDOUT"; + + local *STDERR; + open(STDERR, '>', \$stderr) or die "Could not open temp STDOUT"; + + diag("test\n", "diag\nfoo"); + note("test\n", "note\nbar"); +} + +Test2::API::test2_stop_preload(); + +is($stdout, <<EOT, "Got stdout"); +# test +# note +# bar +EOT + +is($stderr, <<EOT, "Got stderr"); +# test +# diag +# foo +EOT + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/behavior/Subtest_events.t b/cpan/Test-Simple/t/Test2/behavior/Subtest_events.t index 2d1dade0a6..03b285fd15 100644 --- a/cpan/Test-Simple/t/Test2/behavior/Subtest_events.t +++ b/cpan/Test-Simple/t/Test2/behavior/Subtest_events.t @@ -10,8 +10,8 @@ my $events = intercept { run_subtest('blah', $code, 'buffered'); }; -ok(!$events->[0]->in_subtest, "main event is not inside a subtest"); +ok(!$events->[0]->trace->nested, "main event is not inside a subtest"); ok($events->[0]->subtest_id, "Got subtest id"); -ok($events->[0]->subevents->[0]->in_subtest, "nested events are in the subtest"); +is($events->[0]->subevents->[0]->trace->hid, $events->[0]->subtest_id, "nested events are in the subtest"); done_testing; diff --git a/cpan/Test-Simple/t/Test2/behavior/Subtest_todo.t b/cpan/Test-Simple/t/Test2/behavior/Subtest_todo.t index cafc712c62..4f3f45dfef 100644 --- a/cpan/Test-Simple/t/Test2/behavior/Subtest_todo.t +++ b/cpan/Test-Simple/t/Test2/behavior/Subtest_todo.t @@ -6,24 +6,28 @@ use Test2::Tools::Tiny; use Test2::API qw/run_subtest intercept/; my $events = intercept { - todo 'testing todo', sub { - run_subtest( - 'fails in todo', - sub { - ok(1, 'first passes'); - ok(0, 'second fails'); - }); - }; + todo 'testing todo', sub { + run_subtest( + 'fails in todo', + sub { + ok(1, 'first passes'); + ok(0, 'second fails'); + } + ); + }; }; ok($events->[1], 'Test2::Event::Subtest', 'subtest ran'); ok($events->[1]->effective_pass, 'Test2::Event::Subtest', 'subtest effective_pass is true'); ok($events->[1]->todo, 'testing todo', 'subtest todo is set to expected value'); -my @oks = grep { $_->isa('Test2::Event::Ok') } @{$events->[1]->subevents}; -is(scalar @oks, 2, 'got 2 Ok events in the subtest'); -ok($oks[0]->pass, 'first event passed'); -ok($oks[0]->effective_pass, 'first event effective_pass is true'); -ok(!$oks[1]->pass, 'second event failed'); -ok($oks[1]->effective_pass, 'second event effective_pass is true'); + +my $subevents = $events->[1]->subevents; + +is(scalar @$subevents, 3, 'got subevents in the subtest'); + +ok($subevents->[0]->facets->{assert}->pass, 'first event passed'); + +ok(!$subevents->[1]->facets->{assert}->pass, 'second event failed'); +ok(!$subevents->[1]->causes_fail, 'second event does not cause failure'); done_testing; diff --git a/cpan/Test-Simple/t/Test2/behavior/intercept.t b/cpan/Test-Simple/t/Test2/behavior/intercept.t new file mode 100644 index 0000000000..0d709c8b0f --- /dev/null +++ b/cpan/Test-Simple/t/Test2/behavior/intercept.t @@ -0,0 +1,40 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use Test2::API qw/intercept intercept_deep context run_subtest/; + +sub streamed { + my $name = shift; + my $code = shift; + + my $ctx = context(); + my $pass = run_subtest("Subtest: $name", $code, {buffered => 0}, @_); + $ctx->release; + return $pass; +} + +sub buffered { + my $name = shift; + my $code = shift; + + my $ctx = context(); + my $pass = run_subtest($name, $code, {buffered => 1}, @_); + $ctx->release; + return $pass; +} + +my $subtest = sub { ok(1, "pass") }; + +my $buffered_shallow = intercept { buffered 'buffered shallow' => $subtest }; +my $streamed_shallow = intercept { streamed 'streamed shallow' => $subtest }; +my $buffered_deep = intercept_deep { buffered 'buffered shallow' => $subtest }; +my $streamed_deep = intercept_deep { streamed 'streamed shallow' => $subtest }; + +is(@$buffered_shallow, 1, "Just got the subtest event"); +is(@$streamed_shallow, 2, "Got note, and subtest events"); +is(@$buffered_deep, 3, "Got ok, plan, and subtest events"); +is(@$streamed_deep, 4, "Got note, ok, plan, and subtest events"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/behavior/ipc_wait_timeout.t b/cpan/Test-Simple/t/Test2/behavior/ipc_wait_timeout.t new file mode 100644 index 0000000000..09c9a83e52 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/behavior/ipc_wait_timeout.t @@ -0,0 +1,73 @@ +use strict; +use warnings; + +BEGIN { + eval { require threads; }; +} +use Test2::Tools::Tiny; +use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK/; +use Test2::IPC; +use Test2::API qw/test2_ipc_set_timeout test2_ipc_get_timeout/; + +is(test2_ipc_get_timeout(), 30, "got default timeout"); +test2_ipc_set_timeout(10); +is(test2_ipc_get_timeout(), 10, "hanged the timeout"); + +if (CAN_REALLY_FORK) { + note "Testing process waiting"; + my ($ppiper, $ppipew); + pipe($ppiper, $ppipew) or die "Could not create pipe for fork"; + + my $proc = fork(); + die "Could not fork!" unless defined $proc; + + unless ($proc) { + local $SIG{ALRM} = sub { die "PROCESS TIMEOUT" }; + alarm 15; + my $ignore = <$ppiper>; + exit 0; + } + + my $exit; + my $warnings = warnings { + $exit = Test2::API::Instance::_ipc_wait(1); + }; + is($exit, 255, "Exited 255"); + like($warnings->[0], qr/Timeout waiting on child processes/, "Warned about timeout"); + print $ppipew "end\n"; + + close($ppiper); + close($ppipew); +} + +if (CAN_THREAD) { + note "Testing thread waiting"; + my ($tpiper, $tpipew); + pipe($tpiper, $tpipew) or die "Could not create pipe for threads"; + + my $thread = threads->create( + sub { + local $SIG{ALRM} = sub { die "THREAD TIMEOUT" }; + alarm 15; + my $ignore = <$tpiper>; + } + ); + + if ($thread->can('is_joinable')) { + my $exit; + my $warnings = warnings { + $exit = Test2::API::Instance::_ipc_wait(1); + }; + is($exit, 255, "Exited 255"); + like($warnings->[0], qr/Timeout waiting on child thread/, "Warned about timeout"); + } + else { + note "threads.pm is too old for a thread joining timeout :-("; + } + print $tpipew "end\n"; + + close($tpiper); + close($tpipew); +} + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/behavior/no_load_api.t b/cpan/Test-Simple/t/Test2/behavior/no_load_api.t index 8e01e409ea..2caf67d36f 100644 --- a/cpan/Test-Simple/t/Test2/behavior/no_load_api.t +++ b/cpan/Test-Simple/t/Test2/behavior/no_load_api.t @@ -1,7 +1,8 @@ -# HARNESS-NO-PRELOAD use strict; use warnings; use Data::Dumper; +# HARNESS-NO-STREAM +# HARNESS-NO-PRELOAD ############################################################################### # # @@ -28,7 +29,7 @@ require Test2::Event::Waiting; require Test2::Util; require Test2::Util::ExternalMeta; require Test2::Util::HashBase; -require Test2::Util::Trace; +require Test2::EventFacet::Trace; require Test2::Hub; require Test2::Hub::Interceptor; @@ -45,6 +46,6 @@ my @loaded = grep { $INC{$_} } qw{ require Test2::Tools::Tiny; Test2::Tools::Tiny::ok(!@loaded, "Test2::API was not loaded") - || diag("Loaded: " . Dumper(\@loaded)); + || Test2::Tools::Tiny::diag("Loaded: " . Dumper(\@loaded)); Test2::Tools::Tiny::done_testing(); diff --git a/cpan/Test-Simple/t/Test2/behavior/run_subtest_inherit.t b/cpan/Test-Simple/t/Test2/behavior/run_subtest_inherit.t index 5a79ee412d..3284c9d29e 100644 --- a/cpan/Test-Simple/t/Test2/behavior/run_subtest_inherit.t +++ b/cpan/Test-Simple/t/Test2/behavior/run_subtest_inherit.t @@ -17,9 +17,9 @@ is($e->trace->line, $line, "subtest is at correct line"); my $plan = pop @{$e->subevents}; ok($plan->isa('Test2::Event::Plan'), "Removed plan"); for my $se (@{$e->subevents}) { - is($se->trace->file, $file, "subtest event ($se->{name}) is at correct file"); - is($se->trace->line, $line, "subtest event ($se->{name}) is at correct line"); - ok($se->pass, "subtest event ($se->{name}) passed"); + is($se->trace->file, $file, "subtest event is at correct file"); + is($se->trace->line, $line, "subtest event is at correct line"); + ok($se->facets->{assert}->pass, "subtest event passed"); } @@ -37,9 +37,9 @@ is($e->trace->line, $line, "subtest is at correct line"); $plan = pop @{$e->subevents}; ok($plan->isa('Test2::Event::Plan'), "Removed plan"); for my $se (@{$e->subevents}) { - ok($se->trace->file ne $file, "subtest event ($se->{name}) is not in our file"); - ok($se->trace->line ne $line, "subtest event ($se->{name}) is not on our line"); - ok($se->pass, "subtest event ($se->{name}) passed"); + ok($se->trace->file ne $file, "subtest event is not in our file"); + ok($se->trace->line ne $line, "subtest event is not on our line"); + ok($se->facets->{assert}->{pass}, "subtest event passed"); } done_testing; diff --git a/cpan/Test-Simple/t/Test2/behavior/special_names.t b/cpan/Test-Simple/t/Test2/behavior/special_names.t index 4cf10e5f96..98122051ad 100644 --- a/cpan/Test-Simple/t/Test2/behavior/special_names.t +++ b/cpan/Test-Simple/t/Test2/behavior/special_names.t @@ -16,6 +16,8 @@ use Test2::API qw/test2_stack/; test2_stack->top; my $temp_hub = test2_stack->new_hub(); +require Test2::Formatter::TAP; +$temp_hub->format(Test2::Formatter::TAP->new); my $ok = capture { ok(1); diff --git a/cpan/Test-Simple/t/Test2/behavior/subtest_bailout.t b/cpan/Test-Simple/t/Test2/behavior/subtest_bailout.t new file mode 100644 index 0000000000..71a3aaa6c0 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/behavior/subtest_bailout.t @@ -0,0 +1,39 @@ +use Test2::Tools::Tiny; +use strict; +use warnings; + +use Test2::API qw/context run_subtest intercept/; + +sub subtest { + my ($name, $code) = @_; + my $ctx = context(); + my $pass = run_subtest($name, $code, {buffered => 1}, @_); + $ctx->release; + return $pass; +} + +sub bail { + my $ctx = context(); + $ctx->bail(@_); + $ctx->release; +} + +my $events = intercept { + subtest outer => sub { + subtest inner => sub { + bail("bye!"); + }; + }; +}; + +ok($events->[0]->isa('Test2::Event::Subtest'), "Got a subtest event when bail-out issued in a buffered subtest"); +ok($events->[-1]->isa('Test2::Event::Bail'), "Bail-Out propogated"); +ok(!$events->[-1]->facet_data->{trace}->{buffered}, "Final Bail-Out is not buffered"); + +ok($events->[0]->subevents->[-2]->isa('Test2::Event::Bail'), "Got bail out inside outer subtest"); +ok($events->[0]->subevents->[-2]->facet_data->{trace}->{buffered}, "Bail-Out is buffered"); + +ok($events->[0]->subevents->[0]->subevents->[-2]->isa('Test2::Event::Bail'), "Got bail out inside inner subtest"); +ok($events->[0]->subevents->[0]->subevents->[-2]->facet_data->{trace}->{buffered}, "Bail-Out is buffered"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/behavior/trace_signature.t b/cpan/Test-Simple/t/Test2/behavior/trace_signature.t new file mode 100644 index 0000000000..bb3dbf9ead --- /dev/null +++ b/cpan/Test-Simple/t/Test2/behavior/trace_signature.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::API qw/intercept context/; +use Test2::Util qw/get_tid/; + +my $line; +my $events = intercept { + $line = __LINE__ + 1; + ok(1, "pass"); + sub { + my $ctx = context; + $ctx->pass; + $ctx->pass; + $ctx->release; + }->(); +}; + +my $sigpass = $events->[0]->trace->signature; +my $sigfail = $events->[1]->trace->signature; + +ok($sigpass ne $sigfail, "Each tool got a new signature"); + +is($events->[$_]->trace->signature, $sigfail, "Diags share failed ok's signature") for 2 .. $#$events; + +like($sigpass, qr/^C\d+:$$:\Q${ \get_tid() }:${ \__FILE__ }:$line\E$/, "signature is sane"); + +my $trace = Test2::EventFacet::Trace->new(frame => ['main', 'foo.t', 42, 'xxx']); +is($trace->signature, undef, "No signature without a cid"); + +is($events->[0]->related($events->[1]), 0, "event 0 is not related to event 1"); +is($events->[1]->related($events->[2]), 1, "event 1 is related to event 2"); + +my $e = Test2::Event::Ok->new(pass => 1); +is($e->related($events->[0]), undef, "Cannot check relation, invalid trace"); + +$e = Test2::Event::Ok->new(pass => 1, trace => Test2::EventFacet::Trace->new(frame => ['', '', '', ''])); +is($e->related($events->[0]), undef, "Cannot check relation, incomplete trace"); + +$e = Test2::Event::Ok->new(pass => 1, trace => Test2::EventFacet::Trace->new(frame => [])); +is($e->related($events->[0]), undef, "Cannot check relation, incomplete trace"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/legacy/TAP.t b/cpan/Test-Simple/t/Test2/legacy/TAP.t index e58a5ff1fb..bff3134681 100644 --- a/cpan/Test-Simple/t/Test2/legacy/TAP.t +++ b/cpan/Test-Simple/t/Test2/legacy/TAP.t @@ -12,7 +12,6 @@ use Test2::Tools::Tiny; ######################### use Test2::API qw/test2_stack context/; -use Test::Builder::Formatter; # The tools in Test2::Tools::Tiny have some intentional differences from the # Test::More versions, these behave more like Test::More which is important for @@ -53,6 +52,9 @@ sub tm_note { test2_stack->top; my $temp_hub = test2_stack->new_hub(); +require Test::Builder::Formatter; +$temp_hub->format(Test::Builder::Formatter->new); + my $diag = capture { tm_diag(undef); tm_diag(""); diff --git a/cpan/Test-Simple/t/Test2/modules/API/Context.t b/cpan/Test-Simple/t/Test2/modules/API/Context.t index c0dbfc93ea..abb86b64a9 100644 --- a/cpan/Test-Simple/t/Test2/modules/API/Context.t +++ b/cpan/Test-Simple/t/Test2/modules/API/Context.t @@ -91,7 +91,7 @@ my $events = bless [], 'My::Formatter'; my $hub = Test2::Hub->new( formatter => $events, ); -my $trace = Test2::Util::Trace->new( +my $trace = Test2::EventFacet::Trace->new( frame => [ 'Foo::Bar', 'foo_bar.t', 42, 'Foo::Bar::baz' ], ); my $ctx = Test2::API::Context->new( @@ -232,7 +232,7 @@ is_deeply( my $ctx = context(level => -1); my $one = Test2::API::Context->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'blah']), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'blah']), hub => test2_stack()->top, ); is($one->_depth, 0, "default depth"); @@ -257,7 +257,7 @@ is_deeply( { like(exception { Test2::API::Context->new() }, qr/The 'trace' attribute is required/, "need to have trace"); - my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); + my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); like(exception { Test2::API::Context->new(trace => $trace) }, qr/The 'hub' attribute is required/, "need to have hub"); my $hub = test2_stack()->top; @@ -336,15 +336,10 @@ sub { }->(); { - { - package An::Info::Thingy; - sub render { 'zzz' } - } - my ($e1, $e2); my $events = intercept { my $ctx = context(); - $e1 = $ctx->ok(0, 'foo', ['xxx', sub { 'yyy' }, bless({}, 'An::Info::Thingy')]); + $e1 = $ctx->ok(0, 'foo', ['xxx']); $e2 = $ctx->ok(0, 'foo'); $ctx->release; }; @@ -353,19 +348,12 @@ sub { ok($e2->isa('Test2::Event::Ok'), "returned ok event"); is($events->[0], $e1, "got ok event 1"); + is($events->[3], $e2, "got ok event 2"); is($events->[2]->message, 'xxx', "event 1 diag 2"); ok($events->[2]->isa('Test2::Event::Diag'), "event 1 diag 2 is diag"); - is($events->[3]->summary, 'yyy', "event 1 info 1"); - is($events->[3]->diagnostics, 1, "event 1 info 1 is diagnostics"); - ok($events->[3]->isa('Test2::Event::Info'), "event 1 info 1 is an info"); - - is($events->[4]->summary, 'zzz', "event 1 info 2"); - is($events->[4]->diagnostics, 1, "event 1 info 2 is diagnostics"); - ok($events->[4]->isa('Test2::Event::Info'), "event 2 info 1 is an info"); - - is($events->[5], $e2, "got ok event 2"); + is($events->[3], $e2, "got ok event 2"); } sub { diff --git a/cpan/Test-Simple/t/Test2/modules/API/Instance.t b/cpan/Test-Simple/t/Test2/modules/API/Instance.t index 9e3e4ccd4d..124ae6e3a4 100644 --- a/cpan/Test-Simple/t/Test2/modules/API/Instance.t +++ b/cpan/Test-Simple/t/Test2/modules/API/Instance.t @@ -5,6 +5,11 @@ use Test2::IPC; use Test2::Tools::Tiny; use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK USE_THREADS get_tid/; +ok(1, "Just to get things initialized."); + +# This test relies on TAP being the default formatter for non-canon instances +$ENV{T2_FORMATTER} = 'TAP'; + my $CLASS = 'Test2::API::Instance'; my $one = $CLASS->new; @@ -19,6 +24,7 @@ is_deeply( ipc_polling => undef, ipc_drivers => [], + ipc_timeout => 30, formatters => [], @@ -47,6 +53,7 @@ is_deeply( ipc_polling => undef, ipc_drivers => [], + ipc_timeout => 30, formatters => [], @@ -153,7 +160,7 @@ if (CAN_REALLY_FORK) { die "Failed to fork!" unless defined $pid; unless($pid) { exit 0 } - is($one->_ipc_wait, 0, "No errors"); + is(Test2::API::Instance::_ipc_wait, 0, "No errors"); $pid = fork; die "Failed to fork!" unless defined $pid; @@ -161,7 +168,7 @@ if (CAN_REALLY_FORK) { my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; - is($one->_ipc_wait, 255, "Process exited badly"); + is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly"); } like($warnings[0], qr/Process .* did not exit cleanly \(status: 255\)/, "Warn about exit"); } @@ -171,7 +178,7 @@ if (CAN_THREAD && $] ge '5.010') { $one->reset; threads->new(sub { 1 }); - is($one->_ipc_wait, 0, "No errors"); + is(Test2::API::Instance::_ipc_wait, 0, "No errors"); if (threads->can('error')) { threads->new(sub { @@ -182,7 +189,7 @@ if (CAN_THREAD && $] ge '5.010') { my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; - is($one->_ipc_wait, 255, "Thread exited badly"); + is(Test2::API::Instance::_ipc_wait, 255, "Thread exited badly"); } like($warnings[0], qr/Thread .* did not end cleanly: xxx/, "Warn about exit"); } @@ -351,7 +358,7 @@ if (CAN_REALLY_FORK) { { my $ctx = bless { - trace => Test2::Util::Trace->new(frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'xxx']), + trace => Test2::EventFacet::Trace->new(frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'xxx']), hub => Test2::Hub->new(), }, 'Test2::API::Context'; $one->contexts->{1234} = $ctx; diff --git a/cpan/Test-Simple/t/Test2/modules/Event.t b/cpan/Test-Simple/t/Test2/modules/Event.t index 467e724984..8eef5fc70c 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event.t +++ b/cpan/Test-Simple/t/Test2/modules/Event.t @@ -3,38 +3,637 @@ use warnings; use Test2::Tools::Tiny; use Test2::Event(); +use Test2::EventFacet::Trace(); +use Test2::Event::Generic; +use Scalar::Util qw/reftype/; -{ - package My::MockEvent; +tests old_api => sub { + { + package My::MockEvent; - use base 'Test2::Event'; - use Test2::Util::HashBase qw/foo bar baz/; -} + use base 'Test2::Event'; + use Test2::Util::HashBase qw/foo bar baz/; + } -ok(My::MockEvent->can($_), "Added $_ accessor") for qw/foo bar baz/; + ok(My::MockEvent->can($_), "Added $_ accessor") for qw/foo bar baz/; -my $one = My::MockEvent->new(trace => 'fake'); + my $one = My::MockEvent->new(trace => 'fake'); -ok(!$one->causes_fail, "Events do not cause failures by default"); + ok(!$one->causes_fail, "Events do not cause failures by default"); -ok(!$one->$_, "$_ is false by default") for qw/increments_count terminate global/; + ok(!$one->$_, "$_ is false by default") for qw/increments_count terminate global/; -ok(!$one->get_meta('xxx'), "no meta-data associated for key 'xxx'"); + ok(!$one->get_meta('xxx'), "no meta-data associated for key 'xxx'"); -$one->set_meta('xxx', '123'); + $one->set_meta('xxx', '123'); -is($one->meta('xxx'), '123', "got meta-data"); + is($one->meta('xxx'), '123', "got meta-data"); -is($one->meta('xxx', '321'), '123', "did not use default"); + is($one->meta('xxx', '321'), '123', "did not use default"); -is($one->meta('yyy', '1221'), '1221', "got the default"); + is($one->meta('yyy', '1221'), '1221', "got the default"); -is($one->meta('yyy'), '1221', "last call set the value to the default for future use"); + is($one->meta('yyy'), '1221', "last call set the value to the default for future use"); -is($one->summary, 'My::MockEvent', "Default summary is event package"); + is($one->summary, 'My::MockEvent', "Default summary is event package"); -is($one->diagnostics, 0, "Not diagnostics by default"); + is($one->diagnostics, 0, "Not diagnostics by default"); +}; -ok(!$one->in_subtest, "no subtest_id by default"); +tests deprecated => sub { + my $e = Test2::Event->new(trace => Test2::EventFacet::Trace->new(frame => ['foo', 'foo.pl', 42], nested => 2, hid => 'maybe')); + + my $warnings = warnings { + local $ENV{AUTHOR_TESTING} = 1; + is($e->nested, 2, "Got nested from the trace"); + is($e->in_subtest, 'maybe', "got hid from trace"); + + $e->trace->{nested} = 0; + + local $ENV{AUTHOR_TESTING} = 0; + is($e->nested, 0, "Not nested"); + is($e->in_subtest, undef, "Did not get hid"); + }; + + is(@$warnings, 2, "got warnings once each"); + like($warnings->[0], qr/Use of Test2::Event->nested\(\) is deprecated/, "Warned about deprecation"); + like($warnings->[1], qr/Use of Test2::Event->in_subtest\(\) is deprecated/, "Warned about deprecation"); +}; + +tests facet_data => sub { + my $e = Test2::Event::Generic->new( + causes_fail => 0, + increments_count => 0, + diagnostics => 0, + no_display => 0, + callback => undef, + terminate => undef, + global => undef, + sets_plan => undef, + summary => undef, + facet_data => undef, + ); + + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 0, + terminate => undef, + global => 0 + }, + }, + "Facet data has control with onyl false values, and an about" + ); + + $e->set_trace(Test2::EventFacet::Trace->new(frame => ['foo', 'foo.t', 42])); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 0, + terminate => undef, + global => 0 + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + }, + "Got a trace now" + ); + + $e->set_causes_fail(1); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 0, + terminate => undef, + global => 0 + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + errors => [ + { + tag => 'FAIL', + details => 'Test2::Event::Generic', + fail => 1, + } + ], + }, + "Got an error" + ); + + $e->set_increments_count(1); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 0, + terminate => undef, + global => 0 + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + assert => { + no_debug => 1, + pass => 0, + details => 'Test2::Event::Generic', + }, + }, + "Got an assert now" + ); + + $e->set_causes_fail(0); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 0, + terminate => undef, + global => 0 + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + assert => { + no_debug => 1, + pass => 1, + details => 'Test2::Event::Generic', + }, + }, + "Got a passing assert now" + ); + + $e->set_global(1); + $e->set_terminate(255); + $e->set_callback(sub {1}); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 1, + terminate => 255, + global => 1, + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + assert => { + no_debug => 1, + pass => 1, + details => 'Test2::Event::Generic', + }, + }, + "control fields were altered" + ); + + my $data; + { + no warnings 'once'; + local *Test2::Event::Generic::subtest_id = sub { 123 }; + $data = $e->facet_data; + } + is_deeply( + $data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 1, + terminate => 255, + global => 1, + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + assert => { + no_debug => 1, + pass => 1, + details => 'Test2::Event::Generic', + }, + parent => {hid => 123}, + }, + "Added parent" + ); + + $e->set_meta('foo', {a => 1}); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 1, + terminate => 255, + global => 1, + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + assert => { + no_debug => 1, + pass => 1, + details => 'Test2::Event::Generic', + }, + meta => {foo => {a => 1}}, + }, + "Grabbed meta" + ); + + + $e->set_sets_plan([5]); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 1, + terminate => 255, + global => 1, + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + assert => { + no_debug => 1, + pass => 1, + details => 'Test2::Event::Generic', + }, + meta => {foo => {a => 1}}, + plan => { count => 5 }, + }, + "Plan facet added" + ); + + $e->set_terminate(undef); + $e->set_sets_plan([0, SKIP => 'because']); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 1, + terminate => 0, + global => 1, + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + assert => { + no_debug => 1, + pass => 1, + details => 'Test2::Event::Generic', + }, + meta => {foo => {a => 1}}, + plan => { count => 0, skip => 1, details => 'because' }, + }, + "Plan set terminate, skip, and details" + ); + + $e->set_sets_plan([0, 'NO PLAN' => 'because']); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 1, + terminate => undef, + global => 1, + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + assert => { + no_debug => 1, + pass => 1, + details => 'Test2::Event::Generic', + }, + meta => {foo => {a => 1}}, + plan => { count => 0, none => 1, details => 'because' }, + }, + "Plan does not set terminate, but sets 'none' and 'details'" + ); + + $e->add_amnesty({tag => 'foo', details => 'bar'}); + $e->add_amnesty({tag => 'baz', details => 'bat'}); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 1, + terminate => undef, + global => 1, + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + assert => { + no_debug => 1, + pass => 1, + details => 'Test2::Event::Generic', + }, + meta => {foo => {a => 1}}, + plan => { count => 0, none => 1, details => 'because' }, + amnesty => [ + { tag => 'foo', details => 'bar' }, + { tag => 'baz', details => 'bat' }, + ], + }, + "Amnesty added" + ); + + $e = Test2::Event::Generic->new(); + $e->set_diagnostics(1); + $e->set_no_display(1); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => 1, + }, + control => { + has_callback => 0, + terminate => undef, + global => 0, + }, + }, + "No Info" + ); + + $e->set_no_display(0); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef, + }, + control => { + has_callback => 0, + terminate => undef, + global => 0, + }, + info => [{ + details => 'Test2::Event::Generic', + tag => 'DIAG', + debug => 1, + }], + }, + "Got debug Info" + ); + + $e->set_summary("foo bar baz"); + is_deeply( + $e->facet_data, + { + about => { + package => 'Test2::Event::Generic', + details => 'foo bar baz', + no_display => undef, + }, + control => { + has_callback => 0, + terminate => undef, + global => 0, + }, + info => [{ + details => 'foo bar baz', + tag => 'DIAG', + debug => 1, + }], + }, + "Got debug Info with summary change" + ); +}; + +tests facets => sub { + my $data = { + about => { + package => 'Test2::Event::Generic', + details => 'Test2::Event::Generic', + no_display => undef + }, + control => { + has_callback => 1, + terminate => undef, + global => 1, + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + assert => { + no_debug => 1, + pass => 1, + details => 'Test2::Event::Generic', + }, + meta => {foo => {a => 1}}, + plan => {count => 0, none => 1, details => 'because'}, + parent => {hid => 123, children => []}, + amnesty => [ + {tag => 'foo', details => 'bar'}, + {tag => 'baz', details => 'bat'}, + ], + info => [ + { + details => 'foo bar baz', + tag => 'DIAG', + debug => 1, + } + ], + errors => [{ + tag => 'FAIL', + details => 'Test2::Event::Generic', + fail => 1, + }], + }; + + my $e = Test2::Event::Generic->new(facet_data => $data); + is_deeply( + $e->facet_data, + $e->facets, + "Facets and facet_data have the same structure" + ); + + my $facets = $e->facets; + + for my $key (sort keys %$facets) { + my $type = "Test2::EventFacet::" . ucfirst($key); + $type =~ s/s$//; + my $val = $facets->{$key}; + if ($type->is_list) { + for my $f (@$val) { + ok($f->isa('Test2::EventFacet'), "'$key' has a blessed facet"); + ok($f->isa("$type"), "'$key' is a '$type'") or diag("$f"); + } + } + else { + ok($val->isa('Test2::EventFacet'), "'$key' has a blessed facet"); + ok($val->isa($type), "'$key' is a '$type'"); + } + } +}; + +tests common_facet_data => sub { + my $e = Test2::Event::Generic->new( + causes_fail => 0, + increments_count => 0, + diagnostics => 0, + no_display => 0, + callback => undef, + terminate => undef, + global => undef, + sets_plan => undef, + summary => undef, + facet_data => undef, + ); + + is_deeply( + $e->common_facet_data, + { + about => { + package => 'Test2::Event::Generic', + }, + }, + "Facet data has an about" + ); + + $e->set_trace(Test2::EventFacet::Trace->new(frame => ['foo', 'foo.t', 42])); + is_deeply( + $e->common_facet_data, + { + about => { + package => 'Test2::Event::Generic', + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + }, + "Got a trace now" + ); + + $e->set_meta('foo', {a => 1}); + is_deeply( + $e->common_facet_data, + { + about => { + package => 'Test2::Event::Generic', + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + meta => {foo => {a => 1}}, + }, + "Grabbed meta" + ); + + $e->add_amnesty({tag => 'foo', details => 'bar'}); + $e->add_amnesty({tag => 'baz', details => 'bat'}); + is_deeply( + $e->common_facet_data, + { + about => { + package => 'Test2::Event::Generic', + }, + trace => { + frame => ['foo', 'foo.t', 42], + pid => $$, + tid => 0, + }, + meta => {foo => {a => 1}}, + amnesty => [ + {tag => 'foo', details => 'bar'}, + {tag => 'baz', details => 'bat'}, + ], + }, + "Amnesty added" + ); +}; done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Bail.t b/cpan/Test-Simple/t/Test2/modules/Event/Bail.t index d323bd9d97..360179361b 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event/Bail.t +++ b/cpan/Test-Simple/t/Test2/modules/Event/Bail.t @@ -2,9 +2,10 @@ use strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Bail; +use Test2::EventFacet::Trace; my $bail = Test2::Event::Bail->new( - trace => 'fake', + trace => Test2::EventFacet::Trace->new(frame => ['foo', 'foo.t', 42]), reason => 'evil', ); @@ -13,17 +14,61 @@ ok($bail->causes_fail, "bailout always causes fail."); is($bail->terminate, 255, "Bail will cause the test to exit."); is($bail->global, 1, "Bail is global, everything should bail"); -my $hub = Test2::Hub->new; -ok($hub->is_passing, "passing"); -ok(!$hub->failed, "no failures"); - -$bail->callback($hub); -is($hub->bailed_out, $bail, "set bailed out"); - is($bail->summary, "Bail out! evil", "Summary includes reason"); $bail->set_reason(""); is($bail->summary, "Bail out!", "Summary has no reason"); ok($bail->diagnostics, "Bail events are counted as diagnostics"); +is_deeply( + $bail->facet_data, + { + about => { + package => 'Test2::Event::Bail', + }, + control => { + global => 1, + terminate => 255, + details => '', + halt => 1 + }, + trace => { + frame => [ + 'foo', + 'foo.t', + '42', + ], + pid => $$, + tid => 0 + }, + }, + "Got facet data", +); + +$bail->set_reason('uhg'); +is_deeply( + $bail->facet_data, + { + about => { + package => 'Test2::Event::Bail', + }, + control => { + global => 1, + terminate => 255, + details => 'uhg', + halt => 1 + }, + trace => { + frame => [ + 'foo', + 'foo.t', + '42', + ], + pid => $$, + tid => 0 + }, + }, + "Got facet data with reason", +); + done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Diag.t b/cpan/Test-Simple/t/Test2/modules/Event/Diag.t index 9094c0af18..885ee085c0 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event/Diag.t +++ b/cpan/Test-Simple/t/Test2/modules/Event/Diag.t @@ -2,17 +2,17 @@ use strict; use warnings; use Test2::Tools::Tiny; use Test2::Event::Diag; -use Test2::Util::Trace; +use Test2::EventFacet::Trace; my $diag = Test2::Event::Diag->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => 'foo', ); is($diag->summary, 'foo', "summary is just message"); $diag = Test2::Event::Diag->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => undef, ); @@ -20,7 +20,7 @@ is($diag->message, 'undef', "set undef message to undef"); is($diag->summary, 'undef', "summary is just message even when undef"); $diag = Test2::Event::Diag->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => {}, ); @@ -28,4 +28,23 @@ like($diag->message, qr/^HASH\(.*\)$/, "stringified the input value"); ok($diag->diagnostics, "Diag events are counted as diagnostics"); +$diag = Test2::Event::Diag->new( + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + message => "Hi there", +); + +my $facet_data = $diag->facet_data; +ok($facet_data->{about}, "Got 'about' from common"); +ok($facet_data->{trace}, "Got 'trace' from common"); + +is_deeply( + $facet_data->{info}, + [{ + tag => 'DIAG', + debug => 1, + details => 'Hi there', + }], + "Got info facet" +); + done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Encoding.t b/cpan/Test-Simple/t/Test2/modules/Event/Encoding.t new file mode 100644 index 0000000000..9ac6baf72c --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/Event/Encoding.t @@ -0,0 +1,28 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::Event::Encoding'; +my $CLASS = 'Test2::Event::Encoding'; + +like( + exception { $CLASS->new() }, + qr/'encoding' is a required attribute/, + "Must specify the encoding" +); + +my $one = $CLASS->new(encoding => 'utf8'); +is($one->encoding, 'utf8', "Got encoding"); +is($one->summary, "Encoding set to utf8", "Got summary"); + +is_deeply( + $one->facet_data, + { + about => { package => $CLASS, details => "Encoding set to utf8" }, + control => { encoding => 'utf8' }, + }, + "Got facet data" +); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Exception.t b/cpan/Test-Simple/t/Test2/modules/Event/Exception.t index b2bcb6f2db..78c175878a 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event/Exception.t +++ b/cpan/Test-Simple/t/Test2/modules/Event/Exception.t @@ -4,7 +4,7 @@ use Test2::Tools::Tiny; use Test2::Event::Exception; my $exception = Test2::Event::Exception->new( - trace => 'fake', + trace => {frame => []}, error => "evil at lake_of_fire.t line 6\n", ); @@ -14,4 +14,17 @@ is($exception->summary, "Exception: evil at lake_of_fire.t line 6", "Got summary ok($exception->diagnostics, "Exception events are counted as diagnostics"); +my $facet_data = $exception->facet_data; +ok($facet_data->{about}, "Got common facet data"); + +is_deeply( + $facet_data->{errors}, + [{ + tag => 'ERROR', + fail => 1, + details => "evil at lake_of_fire.t line 6\n", + }], + "Got error facet", +); + done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Fail.t b/cpan/Test-Simple/t/Test2/modules/Event/Fail.t new file mode 100644 index 0000000000..80d27f6068 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/Event/Fail.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::API qw/intercept context/; + +use ok 'Test2::Event::Fail'; +my $CLASS = 'Test2::Event::Fail'; + +my $one = $CLASS->new(name => 'no soup for you'); + +is($one->summary, "fail", 'summary'); +is($one->increments_count, 1, 'increments_count'); +is($one->diagnostics, 0, 'diagnostics'); +is($one->no_display, 0, 'no_display'); +is($one->subtest_id, undef, 'subtest_id'); +is($one->terminate, undef, 'terminate'); +is($one->global, undef, 'global'); +is($one->sets_plan, undef, 'sets_plan'); +is($one->causes_fail, 1, 'causes_fail'); + +$one->add_amnesty({tag => 'blah', details => 'blah'}); +is($one->causes_fail, 0, 'causes_fail is off with amnesty'); + +$one->add_info({tag => 'xxx', details => 'yyy'}); + +is_deeply( + $one->facet_data, + { + about => {package => $CLASS, details => 'fail'}, + assert => {pass => 0, details => 'no soup for you'}, + amnesty => [{tag => 'blah', details => 'blah'}], + info => [{tag => 'xxx', details => 'yyy'}], + }, + "Got facet data" +); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Generic.t b/cpan/Test-Simple/t/Test2/modules/Event/Generic.t index 5598bee0ba..a5ba4cb376 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event/Generic.t +++ b/cpan/Test-Simple/t/Test2/modules/Event/Generic.t @@ -2,7 +2,7 @@ use strict; use warnings; use Test2::Tools::Tiny; -use Test2::Util::Trace; +use Test2::EventFacet::Trace; use Test2::API qw/context intercept/; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Info.t b/cpan/Test-Simple/t/Test2/modules/Event/Info.t deleted file mode 100644 index d908547b01..0000000000 --- a/cpan/Test-Simple/t/Test2/modules/Event/Info.t +++ /dev/null @@ -1,51 +0,0 @@ -use strict; -use warnings; - -use Test2::Tools::Tiny; - -use Test2::Event::Info; -use Test2::Util::Trace; -use Test2::API qw/intercept/; - -my @got; - -my $info = Test2::Event::Info->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), - renderer => sub { @got = @_; 'foo' }, -); - -is($info->summary, 'foo', "summary is just rendering"); -is_deeply(\@got, ['text'], "got text"); - -is($info->summary('blah'), 'foo', "summary is just rendering (arg)"); -is_deeply(\@got, ['blah'], "got arg"); - -{ - package An::Info::Thingy; - sub render { shift; @got = @_; 'foo' } -} - -$info = Test2::Event::Info->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), - renderer => bless({}, 'An::Info::Thingy'), -); - -is($info->summary, 'foo', "summary is just rendering"); -is_deeply(\@got, ['text'], "got text"); - -is($info->summary('blah'), 'foo', "summary is just rendering (arg)"); -is_deeply(\@got, ['blah'], "got arg"); - -eval { Test2::Event::Info->new(trace => Test2::Util::Trace->new(frame => ['Foo', 'foo.pl', 42])) }; -like( - $@, - qr/'renderer' is a required attribute at foo\.pl line 42/, - "Got expected error" -); - -# For #727 -$info = intercept { ok(0, 'xxx', sub { 'xxx-yyy' }); }->[-1]; -ok($info->isa('Test2::Event::Info'), "Got an Info event"); -is($info->render, 'xxx-yyy', "Got rendered info"); - -done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Note.t b/cpan/Test-Simple/t/Test2/modules/Event/Note.t index 0292986aab..5ad7e69d97 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event/Note.t +++ b/cpan/Test-Simple/t/Test2/modules/Event/Note.t @@ -3,17 +3,17 @@ use warnings; use Test2::Tools::Tiny; use Test2::Event::Note; -use Test2::Util::Trace; +use Test2::EventFacet::Trace; my $note = Test2::Event::Note->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => 'foo', ); is($note->summary, 'foo', "summary is just message"); $note = Test2::Event::Note->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => undef, ); @@ -21,10 +21,30 @@ is($note->message, 'undef', "set undef message to undef"); is($note->summary, 'undef', "summary is just message even when undef"); $note = Test2::Event::Note->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => {}, ); like($note->message, qr/^HASH\(.*\)$/, "stringified the input value"); +$note = Test2::Event::Note->new( + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + message => 'Hi there', +); + +my $facet_data = $note->facet_data; +ok($facet_data->{about}, "Got 'about' from common"); +ok($facet_data->{trace}, "Got 'trace' from common"); + +is_deeply( + $facet_data->{info}, + [{ + tag => 'NOTE', + debug => 0, + details => 'Hi there', + }], + "Got info facet" +); + + done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Ok.t b/cpan/Test-Simple/t/Test2/modules/Event/Ok.t index 01c255cb1b..fa11217965 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event/Ok.t +++ b/cpan/Test-Simple/t/Test2/modules/Event/Ok.t @@ -2,7 +2,7 @@ use strict; use warnings; use Test2::Tools::Tiny; -use Test2::Util::Trace; +use Test2::EventFacet::Trace; use Test2::Event::Ok; use Test2::Event::Diag; @@ -11,7 +11,7 @@ use Test2::API qw/context/; my $trace; sub before_each { # Make sure there is a fresh trace object for each group - $trace = Test2::Util::Trace->new( + $trace = Test2::EventFacet::Trace->new( frame => ['main_foo', 'foo.t', 42, 'main_foo::flubnarb'], ); } @@ -29,6 +29,20 @@ tests Passing => sub { is($ok->effective_pass, 1, "effective pass"); is($ok->summary, "the_test", "Summary is just the name of the test"); + my $facet_data = $ok->facet_data; + ok($facet_data->{about}, "got common facet data"); + ok(!$facet_data->{amnesty}, "No amnesty by default"); + is_deeply( + $facet_data->{assert}, + { + no_debug => 1, + pass => 1, + details => 'the_test', + }, + "Got assert facet", + ); + + $ok = Test2::Event::Ok->new( trace => $trace, pass => 1, @@ -36,6 +50,18 @@ tests Passing => sub { ); is($ok->summary, "Nameless Assertion", "Nameless test"); + $facet_data = $ok->facet_data; + ok($facet_data->{about}, "got common facet data"); + ok(!$facet_data->{amnesty}, "No amnesty by default"); + is_deeply( + $facet_data->{assert}, + { + no_debug => 1, + pass => 1, + details => '', + }, + "Got assert facet", + ); }; tests Failing => sub { @@ -52,6 +78,19 @@ tests Failing => sub { is($ok->name, 'the_test', "got name"); is($ok->effective_pass, 0, "effective pass"); is($ok->summary, "the_test", "Summary is just the name of the test"); + + my $facet_data = $ok->facet_data; + ok($facet_data->{about}, "got common facet data"); + ok(!$facet_data->{amnesty}, "No amnesty by default"); + is_deeply( + $facet_data->{assert}, + { + no_debug => 1, + pass => 0, + details => 'the_test', + }, + "Got assert facet", + ); }; tests "Failing TODO" => sub { @@ -69,6 +108,27 @@ tests "Failing TODO" => sub { is($ok->effective_pass, 1, "effective pass is true from todo"); is($ok->summary, "the_test (TODO: A Todo)", "Summary is just the name of the test + todo"); + my $facet_data = $ok->facet_data; + ok($facet_data->{about}, "got common facet data"); + is_deeply( + $facet_data->{assert}, + { + no_debug => 1, + pass => 0, + details => 'the_test', + }, + "Got assert facet", + ); + is_deeply( + $facet_data->{amnesty}, + [{ + tag => 'TODO', + details => 'A Todo', + }], + "Got amnesty facet", + ); + + $ok = Test2::Event::Ok->new( trace => $trace, pass => 0, @@ -77,6 +137,27 @@ tests "Failing TODO" => sub { ); ok($ok->effective_pass, "empty string todo is still a todo"); is($ok->summary, "the_test2 (TODO)", "Summary is just the name of the test + todo"); + + $facet_data = $ok->facet_data; + ok($facet_data->{about}, "got common facet data"); + is_deeply( + $facet_data->{assert}, + { + no_debug => 1, + pass => 0, + details => 'the_test2', + }, + "Got assert facet", + ); + is_deeply( + $facet_data->{amnesty}, + [{ + tag => 'TODO', + details => '', + }], + "Got amnesty facet", + ); + }; tests init => sub { diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Pass.t b/cpan/Test-Simple/t/Test2/modules/Event/Pass.t new file mode 100644 index 0000000000..52c71ea507 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/Event/Pass.t @@ -0,0 +1,37 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; +use Test2::API qw/intercept context/; + +use ok 'Test2::Event::Pass'; +my $CLASS = 'Test2::Event::Pass'; + +my $one = $CLASS->new(name => 'soup for you', trace => {frame => ['foo', 'foo.pl', 42]}); + +is($one->summary, "pass", 'summary'); +is($one->increments_count, 1, 'increments_count'); +is($one->diagnostics, 0, 'diagnostics'); +is($one->no_display, 0, 'no_display'); +is($one->subtest_id, undef, 'subtest_id'); +is($one->terminate, undef, 'terminate'); +is($one->global, undef, 'global'); +is($one->sets_plan, undef, 'sets_plan'); +is($one->causes_fail, 0, 'causes_fail is false'); + +$one->add_amnesty({tag => 'blah', details => 'blah'}); +$one->add_info({tag => 'xxx', details => 'yyy'}); + +is_deeply( + $one->facet_data, + { + trace => {frame => ['foo', 'foo.pl', 42]}, + about => {package => $CLASS, details => 'pass'}, + assert => {pass => 1, details => 'soup for you'}, + amnesty => [{tag => 'blah', details => 'blah'}], + info => [{tag => 'xxx', details => 'yyy'}], + }, + "Got facet data" +); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Plan.t b/cpan/Test-Simple/t/Test2/modules/Event/Plan.t index 25db4a57bf..4b81476fbf 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event/Plan.t +++ b/cpan/Test-Simple/t/Test2/modules/Event/Plan.t @@ -3,10 +3,10 @@ use warnings; use Test2::Tools::Tiny; use Test2::Event::Plan; -use Test2::Util::Trace; +use Test2::EventFacet::Trace; my $plan = Test2::Event::Plan->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 100, ); @@ -14,17 +14,11 @@ is($plan->summary, "Plan is 100 assertions", "simple summary"); is_deeply( [$plan->sets_plan], [100, '', undef], "Got plan details"); ok(!$plan->global, "regular plan is not a global event"); -my $state = Test2::Hub->new; -$plan->callback($state); -is($state->plan, 100, "set plan in state"); is($plan->terminate, undef, "No terminate for normal plan"); $plan->set_max(0); $plan->set_directive('SKIP'); $plan->set_reason('foo'); -$state = Test2::Hub->new; -$plan->callback($state); -is($state->plan, 'SKIP', "set plan in state"); is($plan->terminate, 0, "Terminate 0 on skip_all"); is($plan->summary, "Plan is 'SKIP', foo", "skip summary"); @@ -35,24 +29,19 @@ $plan->set_directive('NO PLAN'); $plan->set_reason(undef); is($plan->summary, "Plan is 'NO PLAN'", "NO PLAN summary"); is_deeply( [$plan->sets_plan], [0, 'NO PLAN', undef], "Got 'NO PLAN' details"); -$state = Test2::Hub->new; -$plan->callback($state); -is($state->plan, 'NO PLAN', "set plan in state"); is($plan->terminate, undef, "No terminate for no_plan"); $plan->set_max(100); $plan->set_directive(undef); -$plan->callback($state); -is($state->plan, '100', "Update plan in state if it is 'NO PLAN'"); $plan = Test2::Event::Plan->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'skip_all', ); is($plan->directive, 'SKIP', "Change skip_all to SKIP"); $plan = Test2::Event::Plan->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'no_plan', ); @@ -62,7 +51,7 @@ ok(!$plan->global, "NO PLAN is not global"); like( exception { $plan = Test2::Event::Plan->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'foo', ); @@ -74,7 +63,7 @@ like( like( exception { $plan = Test2::Event::Plan->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, reason => 'foo', ); @@ -86,7 +75,7 @@ like( like( exception { $plan = Test2::Event::Plan->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), ); }, qr/No number of tests specified/, @@ -96,7 +85,7 @@ like( like( exception { $plan = Test2::Event::Plan->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 'skip', ); }, @@ -104,4 +93,64 @@ like( "Max must be an integer" ); +$plan = Test2::Event::Plan->new( + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + max => 100, +); + +my $facet_data = $plan->facet_data; +ok($facet_data->{about}, "Got common facet data"); +is($facet_data->{control}->{terminate}, undef, "no termination defined"); +is_deeply( + $facet_data->{plan}, + {count => 100}, + "Set the count" +); + +$plan = Test2::Event::Plan->new( + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + max => 0, + directive => 'NO PLAN', +); + +$facet_data = $plan->facet_data; +ok($facet_data->{about}, "Got common facet data"); +is($facet_data->{control}->{terminate}, undef, "no termination defined"); +is_deeply( + $facet_data->{plan}, + {count => 0, none => 1}, + "No plan" +); + +$plan = Test2::Event::Plan->new( + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + max => 0, + directive => 'SKIP', +); + +$facet_data = $plan->facet_data; +ok($facet_data->{about}, "Got common facet data"); +is($facet_data->{control}->{terminate}, 0, "terminate with 0"); +is_deeply( + $facet_data->{plan}, + {count => 0, skip => 1}, + "Skip, no reason" +); + +$plan = Test2::Event::Plan->new( + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + max => 0, + directive => 'SKIP', + reason => 'because', +); + +$facet_data = $plan->facet_data; +ok($facet_data->{about}, "Got common facet data"); +is($facet_data->{control}->{terminate}, 0, "terminate with 0"); +is_deeply( + $facet_data->{plan}, + {count => 0, skip => 1, details => 'because'}, + "Skip, no reason" +); + done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Skip.t b/cpan/Test-Simple/t/Test2/modules/Event/Skip.t index 89018794ee..5910fb6dfe 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event/Skip.t +++ b/cpan/Test-Simple/t/Test2/modules/Event/Skip.t @@ -3,14 +3,28 @@ use strict; use warnings; use Test2::Event::Skip; -use Test2::Util::Trace; +use Test2::EventFacet::Trace; my $skip = Test2::Event::Skip->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), name => 'skip me', reason => 'foo', ); +my $facet_data = $skip->facet_data; +ok($facet_data->{about}, "Got basic data"); +is_deeply( + $facet_data->{amnesty}, + [ + { + tag => 'skip', + details => 'foo', + inherited => 0, + } + ], + "Added some amnesty for the skip", +); + is($skip->name, 'skip me', "set name"); is($skip->reason, 'foo', "got skip reason"); ok(!$skip->pass, "no default for pass"); diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Subtest.t b/cpan/Test-Simple/t/Test2/modules/Event/Subtest.t index 56e1184079..209c48ec64 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event/Subtest.t +++ b/cpan/Test-Simple/t/Test2/modules/Event/Subtest.t @@ -5,7 +5,7 @@ use Test2::Tools::Tiny; use Test2::Event::Subtest; my $st = 'Test2::Event::Subtest'; -my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']); +my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']); my $one = $st->new( trace => $trace, pass => 1, @@ -27,4 +27,31 @@ $one->set_todo(undef); $one->set_name(''); is($one->summary, "Nameless Subtest", "unnamed summary"); +require Test2::Event::Pass; +push @{$one->subevents} => Test2::Event::Pass->new(name => 'xxx'); + +my $facet_data = $one->facet_data; +ok($facet_data->{about}, "got parent facet data"); + +is_deeply( + $facet_data->{parent}, + { + hid => "1-1-1", + buffered => 1, + children => [ + { + about => { + details => 'pass', + package => 'Test2::Event::Pass' + }, + assert => { + details => 'xxx', + pass => 1 + }, + } + ], + }, + "Got facet data" +); + done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/TAP/Version.t b/cpan/Test-Simple/t/Test2/modules/Event/TAP/Version.t new file mode 100644 index 0000000000..a1fd6b900c --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/Event/TAP/Version.t @@ -0,0 +1,28 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::Event::TAP::Version'; +my $CLASS = 'Test2::Event::TAP::Version'; + +like( + exception { $CLASS->new() }, + qr/'version' is a required attribute/, + "Must specify the version" +); + +my $one = $CLASS->new(version => 13); +is($one->version, 13, "Got version"); +is($one->summary, "TAP version 13", "Got summary"); + +is_deeply( + $one->facet_data, + { + about => { package => $CLASS, details => "TAP version 13"}, + info => [{tag => 'INFO', debug => 0, details => "TAP version 13"}], + }, + "Got facet data" +); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Event/Waiting.t b/cpan/Test-Simple/t/Test2/modules/Event/Waiting.t index 26b7fbb41f..be278b5937 100644 --- a/cpan/Test-Simple/t/Test2/modules/Event/Waiting.t +++ b/cpan/Test-Simple/t/Test2/modules/Event/Waiting.t @@ -5,7 +5,7 @@ use Test2::Tools::Tiny; use Test2::Event::Waiting; my $waiting = Test2::Event::Waiting->new( - trace => 'fake', + trace => {}, ); ok($waiting, "Created event"); @@ -13,4 +13,19 @@ ok($waiting->global, "waiting is global"); is($waiting->summary, "IPC is waiting for children to finish...", "Got summary"); +my $facet_data = $waiting->facet_data; +ok($facet_data->{about}, "Got common facet data"); + +is_deeply( + $facet_data->{info}, + [ + { + tag => 'INFO', + debug => 0, + details => "IPC is waiting for children to finish...", + }, + ], + "Got added info facet" +); + done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet.t b/cpan/Test-Simple/t/Test2/modules/EventFacet.t new file mode 100644 index 0000000000..44698320c6 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet.t @@ -0,0 +1,24 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::EventFacet'; +my $CLASS = 'Test2::EventFacet'; + +my $one = $CLASS->new(details => 'foo'); + +is($one->details, "foo", "Got details"); + +is_deeply($one->clone, $one, "Cloning."); + +isnt($one->clone, $one, "Clone is a new ref"); + +my $two = $one->clone(details => 'bar'); +is($one->details, 'foo', "Original details unchanged"); +is($two->details, 'bar', "Clone details changed"); + +ok(!$CLASS->is_list, "Not a list by default"); +ok(!$CLASS->facet_key, "No key for base class"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet/About.t b/cpan/Test-Simple/t/Test2/modules/EventFacet/About.t new file mode 100644 index 0000000000..55e33763f6 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet/About.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::EventFacet::About'; +my $CLASS = 'Test2::EventFacet::About'; + +my $one = $CLASS->new(details => 'foo', package => 'bar', no_display => 0); + +is($one->details, "foo", "Got details"); +is($one->package, "bar", "Got package"); +is($one->no_display, 0, "Got no_display value"); + +is_deeply($one->clone, $one, "Cloning."); +isnt($one->clone, $one, "Clone is a new ref"); + +ok(!$CLASS->is_list, "Not a list"); +is($CLASS->facet_key, 'about', "Got key"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet/Amnesty.t b/cpan/Test-Simple/t/Test2/modules/EventFacet/Amnesty.t new file mode 100644 index 0000000000..ae6a24f9a4 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet/Amnesty.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::EventFacet::Amnesty'; +my $CLASS = 'Test2::EventFacet::Amnesty'; + +my $one = $CLASS->new(details => 'foo', tag => 'bar', inherited => 0); + +is($one->details, "foo", "Got details"); +is($one->tag, "bar", "Got tag"); +is($one->inherited, 0, "Got 'inherited' value"); + +is_deeply($one->clone, $one, "Cloning."); +isnt($one->clone, $one, "Clone is a new ref"); + +ok($CLASS->is_list, "is a list"); +is($CLASS->facet_key, 'amnesty', "Got key"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet/Assert.t b/cpan/Test-Simple/t/Test2/modules/EventFacet/Assert.t new file mode 100644 index 0000000000..c7252e5f4b --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet/Assert.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::EventFacet::Assert'; +my $CLASS = 'Test2::EventFacet::Assert'; + +my $one = $CLASS->new(details => 'foo', pass => 1, no_debug => 1); + +is($one->details, "foo", "Got details"); +is($one->pass, 1, "Got 'pass' value"); +is($one->no_debug, 1, "Got 'no_debug' value"); + +is_deeply($one->clone, $one, "Cloning."); +isnt($one->clone, $one, "Clone is a new ref"); + +ok(!$CLASS->is_list, "is not a list"); +is($CLASS->facet_key, 'assert', "Got key"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet/Control.t b/cpan/Test-Simple/t/Test2/modules/EventFacet/Control.t new file mode 100644 index 0000000000..4249a9e988 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet/Control.t @@ -0,0 +1,24 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::EventFacet::Control'; +my $CLASS = 'Test2::EventFacet::Control'; + +my $one = $CLASS->new(details => 'foo', global => 0, terminate => undef, halt => 0, has_callback => 1, encoding => 'utf8'); + +is($one->details, "foo", "Got details"); +is($one->global, 0, "Got 'global' value"); +is($one->terminate, undef, "Got 'terminate' value"); +is($one->halt, 0, "Got 'halt' value"); +is($one->has_callback, 1, "Got 'has_callback' value"); +is($one->encoding, 'utf8', "Got 'utf8' value"); + +is_deeply($one->clone, $one, "Cloning."); +isnt($one->clone, $one, "Clone is a new ref"); + +ok(!$CLASS->is_list, "is not a list"); +is($CLASS->facet_key, 'control', "Got key"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet/Error.t b/cpan/Test-Simple/t/Test2/modules/EventFacet/Error.t new file mode 100644 index 0000000000..0bd874b1c9 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet/Error.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::EventFacet::Error'; +my $CLASS = 'Test2::EventFacet::Error'; + +my $one = $CLASS->new(details => 'foo', tag => 'uhg', fail => 1); + +is($one->details, "foo", "Got details"); +is($one->tag, 'uhg', "Got 'tag' value"); +is($one->fail, 1, "Got 'fail' value"); + +is_deeply($one->clone, $one, "Cloning."); +isnt($one->clone, $one, "Clone is a new ref"); + +ok($CLASS->is_list, "is a list"); +is($CLASS->facet_key, 'errors', "Got key"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet/Info.t b/cpan/Test-Simple/t/Test2/modules/EventFacet/Info.t new file mode 100644 index 0000000000..080f3d2fba --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet/Info.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::EventFacet::Info'; +my $CLASS = 'Test2::EventFacet::Info'; + +my $one = $CLASS->new(details => 'foo', tag => 'bar', debug => 0); + +is($one->details, "foo", "Got details"); +is($one->tag, "bar", "Got tag"); +is($one->debug, 0, "Got 'debug' value"); + +is_deeply($one->clone, $one, "Cloning."); +isnt($one->clone, $one, "Clone is a new ref"); + +ok($CLASS->is_list, "is a list"); +is($CLASS->facet_key, 'info', "Got key"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet/Meta.t b/cpan/Test-Simple/t/Test2/modules/EventFacet/Meta.t new file mode 100644 index 0000000000..5a51fecf00 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet/Meta.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::EventFacet::Meta'; +my $CLASS = 'Test2::EventFacet::Meta'; + +my $one = $CLASS->new(details => 'foo', a => 1, b => 'bar', x => undef, set_details => 'xxx'); + +is($one->details, "foo", "Got details"); +is($one->set_details, "xxx", "set_details is a regular field, not a writer"); + +is($one->a, 1, "Got 'a'"); +is($one->b, 'bar', "Got 'b'"); +is($one->x, undef, "Got 'x'"); +is($one->blah, undef, "Vivified 'blah'"); + +is_deeply($one->clone, $one, "Cloning."); +isnt($one->clone, $one, "Clone is a new ref"); + +ok(!$CLASS->is_list, "is not a list"); +is($CLASS->facet_key, 'meta', "Got key"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet/Parent.t b/cpan/Test-Simple/t/Test2/modules/EventFacet/Parent.t new file mode 100644 index 0000000000..8667f0b81d --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet/Parent.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::EventFacet::Parent'; +my $CLASS = 'Test2::EventFacet::Parent'; + +my $one = $CLASS->new(details => 'foo', hid => 'abc', children => [], buffered => 1); + +is($one->details, "foo", "Got details"); +is($one->hid, 'abc', "Got 'hid' value"); +is($one->buffered, 1, "Got 'buffered' value"); +is_deeply($one->children, [], "Got 'children' value"); + +is_deeply($one->clone, $one, "Cloning."); +isnt($one->clone, $one, "Clone is a new ref"); + +ok(!$CLASS->is_list, "is not a list"); +is($CLASS->facet_key, 'parent', "Got key"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet/Plan.t b/cpan/Test-Simple/t/Test2/modules/EventFacet/Plan.t new file mode 100644 index 0000000000..efb28c3522 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet/Plan.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Test2::Tools::Tiny; + +use ok 'Test2::EventFacet::Plan'; +my $CLASS = 'Test2::EventFacet::Plan'; + +my $one = $CLASS->new(details => 'foo', count => 100, skip => 1, none => 0); + +is($one->details, "foo", "Got details"); +is($one->count, 100, "Got 'count' value"); +is($one->skip, 1, "Got 'skip' value"); +is($one->none, 0, "Got 'none' value"); + +is_deeply($one->clone, $one, "Cloning."); +isnt($one->clone, $one, "Clone is a new ref"); + +ok(!$CLASS->is_list, "is not a list"); +is($CLASS->facet_key, 'plan', "Got key"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/EventFacet/Trace.t b/cpan/Test-Simple/t/Test2/modules/EventFacet/Trace.t new file mode 100644 index 0000000000..7736cf9ffb --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/EventFacet/Trace.t @@ -0,0 +1,46 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; +use Test2::EventFacet::Trace; + +my $CLASS = 'Test2::EventFacet::Trace'; + +like( + exception { $CLASS->new() }, + qr/The 'frame' attribute is required/, + "got error" +); + +my $one = $CLASS->new(frame => ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo']); +is_deeply($one->frame, ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got frame"); +is_deeply([$one->call], ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got call"); +is($one->package, 'Foo::Bar', "Got package"); +is($one->file, 'foo.t', "Got file"); +is($one->line, 5, "Got line"); +is($one->subname, 'Foo::Bar::foo', "got subname"); + +is($one->debug, "at foo.t line 5", "got trace"); +$one->set_detail("yo momma"); +is($one->debug, "yo momma", "got detail for trace"); +$one->set_detail(undef); + +is( + exception { $one->throw('I died') }, + "I died at foo.t line 5.\n", + "got exception" +); + +is_deeply( + warnings { $one->alert('I cried') }, + [ "I cried at foo.t line 5.\n" ], + "alter() warns" +); + +my $snap = $one->snapshot; +is_deeply($snap, $one, "identical"); +ok($snap != $one, "Not the same instance"); + +ok(!$CLASS->is_list, "is not a list"); +is($CLASS->facet_key, 'trace', "Got key"); + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Formatter/TAP.t b/cpan/Test-Simple/t/Test2/modules/Formatter/TAP.t index 2cf92b8270..69641520fe 100644 --- a/cpan/Test-Simple/t/Test2/modules/Formatter/TAP.t +++ b/cpan/Test-Simple/t/Test2/modules/Formatter/TAP.t @@ -1,550 +1,1010 @@ use strict; use warnings; -use Test2::Formatter::TAP; -use Test2::API qw/context/; -use PerlIO; +# HARNESS-NO-PRELOAD -use Test2::Tools::Tiny; +my $CLASS; +my %BEFORE_LOAD; BEGIN { - *OUT_STD = Test2::Formatter::TAP->can('OUT_STD') or die; - *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR') or die; + my $old = select STDOUT; + $BEFORE_LOAD{STDOUT} = $|; + select STDERR; + $BEFORE_LOAD{STDERR} = $|; + select $old; + + require Test2::Formatter::TAP; + $CLASS = 'Test2::Formatter::TAP'; + *OUT_STD = $CLASS->can('OUT_STD') or die "Could not get OUT_STD constant"; + *OUT_ERR = $CLASS->can('OUT_ERR') or die "Could not get OUT_ERR constant"; } -use Test2::API; -Test2::API::test2_add_callback_context_release(sub { - my $ctx = shift; - return if $ctx->hub->is_passing; - $ctx->throw("(Die On Fail)"); -}); - -ok(my $one = Test2::Formatter::TAP->new, "Created a new instance"); -my $handles = $one->handles; -is(@$handles, 2, "Got 2 handles"); -ok($handles->[0] != $handles->[1], "First and second handles are not the same"); -my $layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) }; - -if (${^UNICODE} & 2) { # 2 means STDIN - ok($layers->{utf8}, "'S' is set in PERL_UNICODE, or in -C, honor it, utf8 should be on") -} -else { - ok(!$layers->{utf8}, "Not utf8 by default") +use Test2::Tools::Tiny; +use Test2::API qw/context/; +use PerlIO; + +sub grabber { + my ($std, $err); + open( my $stdh, '>', \$std ) || die "Ooops"; + open( my $errh, '>', \$err ) || die "Ooops"; + + my $it = $CLASS->new( + handles => [$stdh, $errh, $stdh], + ); + + return ($it, \$std, \$err); } -$one->encoding('utf8'); -is($one->encoding, 'utf8', "Got encoding"); -$handles = $one->handles; -is(@$handles, 2, "Got 2 handles"); -$layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) }; -ok($layers->{utf8}, "Now utf8"); +tests "IO handle stuff" => sub { + ok($CLASS->can($_), "$CLASS has the '$_' method") for qw/no_numbers handles/; + ok($CLASS->isa('Test2::Formatter'), "$CLASS isa Test2::Formatter"); + + ok(!$BEFORE_LOAD{STDOUT}, "AUTOFLUSH was not on for STDOUT before load"); + ok(!$BEFORE_LOAD{STDERR}, "AUTOFLUSH was not on for STDERR before load"); + my $old = select STDOUT; + ok($|, "AUTOFLUSH was turned on for STDOUT"); + select STDERR; + ok($|, "AUTOFLUSH was turned on for STDERR"); + select $old; + + ok(my $one = $CLASS->new, "Created a new instance"); + my $handles = $one->handles; + is(@$handles, 2, "Got 2 handles"); + ok($handles->[0] != $handles->[1], "First and second handles are not the same"); + my $layers = {map { $_ => 1 } PerlIO::get_layers($handles->[0])}; + + if (${^UNICODE} & 2) { # 2 means STDIN + ok($layers->{utf8}, "'S' is set in PERL_UNICODE, or in -C, honor it, utf8 should be on"); + } + else { + ok(!$layers->{utf8}, "Not utf8 by default"); + } -my $two = Test2::Formatter::TAP->new(encoding => 'utf8'); -$handles = $two->handles; -is(@$handles, 2, "Got 2 handles"); -$layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) }; -ok($layers->{utf8}, "Now utf8"); + $one->encoding('utf8'); + is($one->encoding, 'utf8', "Got encoding"); + $handles = $one->handles; + is(@$handles, 2, "Got 2 handles"); + $layers = {map { $_ => 1 } PerlIO::get_layers($handles->[OUT_STD])}; + ok($layers->{utf8}, "Now utf8"); + + my $two = $CLASS->new(encoding => 'utf8'); + $handles = $two->handles; + is(@$handles, 2, "Got 2 handles"); + $layers = {map { $_ => 1 } PerlIO::get_layers($handles->[OUT_STD])}; + ok($layers->{utf8}, "Now utf8"); + + $old = select $handles->[OUT_STD]; + ok($|, "AUTOFLUSH was turned on for copy-STDOUT"); + select select $handles->[OUT_ERR]; + ok($|, "AUTOFLUSH was turned on for copy-STDERR"); + select $old; + + ok($CLASS->hide_buffered, "TAP will hide buffered events"); + ok(!$CLASS->no_subtest_space, "Default formatter does not have subtest space"); +}; +tests optimal_pass => sub { + my ($it, $out, $err) = grabber(); -{ - package My::Event; + my $fail = Test2::Event::Fail->new; + ok(!$it->print_optimal_pass($fail, 1), "Not gonna print a non-pass"); - use base 'Test2::Event'; - use Test2::Util::HashBase qw{pass name diag note}; + $fail = Test2::Event::Ok->new(pass => 0); + ok(!$it->print_optimal_pass($fail, 1), "Not gonna print a non-pass"); - Test2::Formatter::TAP->register_event( - __PACKAGE__, - sub { - my $self = shift; - my ($e, $num) = @_; - return ( - [main::OUT_STD, "ok $num - " . $e->name . "\n"], - [main::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"], - [main::OUT_STD, "# " . $e->name . " " . $e->note . "\n"], - ); - } - ); -} + my $pass = Test2::Event::Pass->new(); + $pass->add_amnesty({tag => 'foo', details => 'foo'}); + ok(!$it->print_optimal_pass($pass, 1), "Not gonna print amnesty"); -my ($std, $err); -open( my $stdh, '>', \$std ) || die "Ooops"; -open( my $errh, '>', \$err ) || die "Ooops"; - -my $it = Test2::Formatter::TAP->new( - handles => [$stdh, $errh, $stdh], -); - -$it->write( - My::Event->new( - pass => 1, - name => 'foo', - diag => 'diag', - note => 'note', - trace => 'fake', - ), - 55, -); - -$it->write( - My::Event->new( - pass => 1, - name => 'bar', - diag => 'diag', - note => 'note', - trace => 'fake', - nested => 1, - ), - 1, -); - -is($std, <<EOT, "Got expected TAP output to std"); -ok 55 - foo -# foo note - ok 1 - bar - # bar note -EOT - -is($err, <<EOT, "Got expected TAP output to err"); -# foo diag - # bar diag -EOT - -$it = undef; -close($stdh); -close($errh); - -my ($trace, $ok, $diag, $plan, $bail); - -my $fmt = Test2::Formatter::TAP->new; -sub before_each { - # Make sure there is a fresh trace object for each group - $trace = Test2::Util::Trace->new( - frame => ['main_foo', 'foo.t', 42, 'main_foo::flubnarb'], - ); -} + $pass = Test2::Event::Ok->new(pass => 1, todo => ''); + ok(!$it->print_optimal_pass($pass, 1), "Not gonna print todo (even empty todo)"); -tests bail => sub { - my $bail = Test2::Event::Bail->new( - trace => $trace, - reason => 'evil', - ); + $pass = Test2::Event::Ok->new(pass => 1, name => "foo # bar"); + ok(!$it->print_optimal_pass($pass, 1), "Not gonna pritn a name with a hash"); - is_deeply( - [$fmt->event_tap($bail, 1)], - [[OUT_STD, "Bail out! evil\n" ]], - "Got tap" - ); + $pass = Test2::Event::Ok->new(pass => 1, name => "foo \n bar"); + ok(!$it->print_optimal_pass($pass, 1), "Not gonna pritn a name with a newline"); + + ok(!$$out, "No std output yet"); + ok(!$$err, "No err output yet"); + + $pass = Test2::Event::Pass->new(); + ok($it->print_optimal_pass($pass, 1), "Printed a simple pass without a name"); + + $pass = Test2::Event::Pass->new(name => 'xxx'); + ok($it->print_optimal_pass($pass, 1), "Printed a simple pass with a name"); + + $pass = Test2::Event::Ok->new(pass => 1, name => 'xxx'); + ok($it->print_optimal_pass($pass, 1), "Printed an 'Ok' pass with a name"); + + $pass = Test2::Event::Pass->new(name => 'xxx', trace => { nested => 1 }); + ok($it->print_optimal_pass($pass, 1), "Printed a nested pass"); + $pass = Test2::Event::Pass->new(name => 'xxx', trace => { nested => 3 }); + ok($it->print_optimal_pass($pass, 1), "Printed a deeply nested pass"); + + $pass = Test2::Event::Pass->new(name => 'xxx'); + $it->{no_numbers} = 1; + ok($it->print_optimal_pass($pass, 1), "Printed a simple pass with a name"); + + is($$out, <<" EOT", "Got expected TAP output"); +ok 1 +ok 1 - xxx +ok 1 - xxx + ok 1 - xxx + ok 1 - xxx +ok - xxx + EOT + + is($it->{_last_fh}, $it->handles->[OUT_STD], "Set the last filehandle"); + + ok(!$$err, "No err output"); }; -tests diag => sub { - my $diag = Test2::Event::Diag->new( - trace => $trace, - message => 'foo', - ); +tests plan_tap => sub { + my ($it, $out, $err) = grabber(); - is_deeply( - [$fmt->event_tap($diag, 1)], - [[OUT_ERR, "# foo\n"]], - "Got tap" - ); + is_deeply([$it->plan_tap({})], [], "Nothing with no plan facet"); - $diag->set_message("foo\n"); is_deeply( - [$fmt->event_tap($diag, 1)], - [[OUT_ERR, "# foo\n"]], - "Only 1 newline" + [$it->plan_tap({plan => { none => 1 }})], + [], + "no-plan has no output" ); - $diag->set_message("foo\nbar\nbaz"); is_deeply( - [$fmt->event_tap($diag, 1)], - [[OUT_ERR, "# foo\n# bar\n# baz\n"]], - "All lines have proper prefix" + [$it->plan_tap({plan => { count => 20 }})], + [[OUT_STD, "1..20\n"]], + "Wrote the plan from, count" ); -}; -tests exception => sub { - my $exception = Test2::Event::Exception->new( - trace => $trace, - error => "evil at lake_of_fire.t line 6\n", + is_deeply( + [$it->plan_tap({plan => { count => 'anything', skip => 1 }})], + [[OUT_STD, "1..0 # SKIP\n"]], + "Skip, no reason" ); is_deeply( - [$fmt->event_tap($exception, 1)], - [[OUT_ERR, "evil at lake_of_fire.t line 6\n" ]], - "Got tap" + [$it->plan_tap({plan => { count => 'anything', skip => 1, details => 'I said so' }})], + [[OUT_STD, "1..0 # SKIP I said so\n"]], + "Skip with reason" ); + + ok(!$$out, "No std output yet"); + ok(!$$err, "No err output yet"); }; -tests note => sub { - my $note = Test2::Event::Note->new( - trace => $trace, - message => 'foo', - ); +tests assert_tap => sub { + my ($it, $out, $err) = grabber(); is_deeply( - [$fmt->event_tap($note, 1)], - [[OUT_STD, "# foo\n"]], - "Got tap" + [$it->assert_tap({assert => {pass => 1}}, 1)], + [[OUT_STD, "ok 1\n"]], + "Pass", ); - $note->set_message("foo\n"); is_deeply( - [$fmt->event_tap($note, 1)], - [[OUT_STD, "# foo\n"]], - "Only 1 newline" + [$it->assert_tap({assert => {pass => 0}}, 1)], + [[OUT_STD, "not ok 1\n"]], + "Fail", ); - $note->set_message("foo\nbar\nbaz"); - is_deeply( - [$fmt->event_tap($note, 1)], - [[OUT_STD, "# foo\n# bar\n# baz\n"]], - "All lines have proper prefix" - ); -}; + tests amnesty => sub { + tests pass_no_name => sub { + is_deeply( + [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], + [[OUT_STD, "ok 1 # skip xxx\n"]], + "Pass with skip (with details)", + ); -tests special_characters => sub { - my $ok = Test2::Event::Ok->new( - trace => $trace, - name => 'nothing special', - pass => 1, - ); + is_deeply( + [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'skip'}]}, 1)], + [[OUT_STD, "ok 1 # skip\n"]], + "Pass with skip (without details)", + ); - is_deeply( - [$fmt->event_tap($ok, 1)], - [[OUT_STD, "ok 1 - nothing special\n"]], - "Got regular ok" - ); + is_deeply( + [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], + [[OUT_STD, "ok 1 # TODO xxx\n"]], + "Pass with TODO (with details)", + ); - $ok = Test2::Event::Ok->new( - trace => $trace, - name => 'just a \\ slash', - pass => 1, - ); + is_deeply( + [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'TODO'}]}, 1)], + [[OUT_STD, "ok 1 # TODO\n"]], + "Pass with TODO (without details)", + ); - is_deeply( - [$fmt->event_tap($ok, 1)], - [[OUT_STD, "ok 1 - just a \\ slash\n"]], - "Do not escape slashes without a '#'" - ); + is_deeply( + [ + $it->assert_tap( + { + assert => {pass => 1}, + amnesty => [ + {tag => 'TODO', details => 'xxx'}, + {tag => 'skip', details => 'yyy'}, + ] + }, + 1 + ) + ], + [[OUT_STD, "ok 1 # TODO & SKIP yyy\n"]], + "Pass with skip and TODO", + ); - $ok = Test2::Event::Ok->new( - trace => $trace, - name => 'a \\ slash and a # hash', - pass => 1, - ); + is_deeply( + [$it->assert_tap({assert => {pass => 1}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], + [[OUT_STD, "ok 1 # foo xxx\n"]], + "Pass with other amnesty", + ); + }; - is_deeply( - [$fmt->event_tap($ok, 1)], - [[OUT_STD, "ok 1 - a \\\\ slash and a \\# hash\n"]], - "Escape # and any slashes already present" - ); + tests pass_with_name => sub { + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], + [[OUT_STD, "ok 1 - bob # skip xxx\n"]], + "Pass with skip (with details)", + ); - $ok = Test2::Event::Ok->new( - trace => $trace, - name => "a \\ slash and a # hash\nand \\ some # newlines\nlike this # \\", - pass => 1, - ); + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'skip'}]}, 1)], + [[OUT_STD, "ok 1 - bob # skip\n"]], + "Pass with skip (without details)", + ); - is_deeply( - [$fmt->event_tap($ok, 1)], - [ - [OUT_STD, "ok 1 - a \\\\ slash and a \\# hash\n"], - [OUT_STD, "# and \\ some # newlines\n"], - [OUT_STD, "# like this # \\\n"], - ], - "Escape # and any slashes already present, and split newlines, do not escape the newlines" - ); + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], + [[OUT_STD, "ok 1 - bob # TODO xxx\n"]], + "Pass with TODO (with details)", + ); - $ok = Test2::Event::Ok->new( - trace => $trace, - name => "Nothing special until the end \\\nfoo \\ bar", - pass => 1, - ); + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'TODO'}]}, 1)], + [[OUT_STD, "ok 1 - bob # TODO\n"]], + "Pass with TODO (without details)", + ); - is_deeply( - [$fmt->event_tap($ok, 1)], - [ - [OUT_STD, "ok 1 - Nothing special until the end \\\\\n"], - [OUT_STD, "# foo \\ bar\n"], - ], - "Special case, escape things if last character of the first line is a \\" - ); + is_deeply( + [ + $it->assert_tap( + { + assert => {pass => 1, details => 'bob'}, + amnesty => [ + {tag => 'TODO', details => 'xxx'}, + {tag => 'skip', details => 'yyy'}, + ] + }, + 1 + ) + ], + [[OUT_STD, "ok 1 - bob # TODO & SKIP yyy\n"]], + "Pass with skip and TODO", + ); -}; + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => 'bob'}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], + [[OUT_STD, "ok 1 - bob # foo xxx\n"]], + "Pass with other amnesty", + ); + }; -for my $pass (1, 0) { - local $ENV{HARNESS_IS_VERBOSE} = 1; - tests name_and_number => sub { - my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass, name => 'foo'); - my @tap = $fmt->event_tap($ok, 7); - is_deeply( - \@tap, - [ - [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 - foo\n"], - ], - "Got expected output" - ); + tests fail_no_name => sub { + is_deeply( + [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], + [[OUT_STD, "not ok 1 # skip xxx\n"]], + "Pass with skip (with details)", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'skip'}]}, 1)], + [[OUT_STD, "not ok 1 # skip\n"]], + "Pass with skip (without details)", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], + [[OUT_STD, "not ok 1 # TODO xxx\n"]], + "Pass with TODO (with details)", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'TODO'}]}, 1)], + [[OUT_STD, "not ok 1 # TODO\n"]], + "Pass with TODO (without details)", + ); + + is_deeply( + [ + $it->assert_tap( + { + assert => {pass => 0}, + amnesty => [ + {tag => 'TODO', details => 'xxx'}, + {tag => 'skip', details => 'yyy'}, + ] + }, + 1 + ) + ], + [[OUT_STD, "not ok 1 # TODO & SKIP yyy\n"]], + "Pass with skip and TODO", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], + [[OUT_STD, "not ok 1 # foo xxx\n"]], + "Pass with other amnesty", + ); + }; + + tests fail_with_name => sub { + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'skip', details => 'xxx'}]}, 1)], + [[OUT_STD, "not ok 1 - bob # skip xxx\n"]], + "Pass with skip (with details)", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'skip'}]}, 1)], + [[OUT_STD, "not ok 1 - bob # skip\n"]], + "Pass with skip (without details)", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'TODO', details => 'xxx'}]}, 1)], + [[OUT_STD, "not ok 1 - bob # TODO xxx\n"]], + "Pass with TODO (with details)", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'TODO'}]}, 1)], + [[OUT_STD, "not ok 1 - bob # TODO\n"]], + "Pass with TODO (without details)", + ); + + is_deeply( + [ + $it->assert_tap( + { + assert => {pass => 0, details => 'bob'}, + amnesty => [ + {tag => 'TODO', details => 'xxx'}, + {tag => 'skip', details => 'yyy'}, + ] + }, + 1 + ) + ], + [[OUT_STD, "not ok 1 - bob # TODO & SKIP yyy\n"]], + "Pass with skip and TODO", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => 'bob'}, amnesty => [{tag => 'foo', details => 'xxx'}]}, 1)], + [[OUT_STD, "not ok 1 - bob # foo xxx\n"]], + "Pass with other amnesty", + ); + }; }; - tests no_number => sub { - my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass, name => 'foo'); - my @tap = $fmt->event_tap($ok, ); - is_deeply( - \@tap, - [ - [OUT_STD, ($pass ? 'ok' : 'not ok') . " - foo\n"], - ], - "Got expected output" - ); + tests newline_and_hash => sub { + tests pass => sub { + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => "foo\nbar"}}, 1)], + [ + [OUT_STD, "ok 1 - foo\n"], + [OUT_STD, "# bar\n"], + ], + "Pass with newline", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => "foo\nbar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], + [ + [OUT_STD, "ok 1 - foo # baz bat\n"], + [OUT_STD, "# bar\n"], + ], + "Pass with newline and amnesty", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => "foo#bar"}}, 1)], + [[OUT_STD, "ok 1 - foo\\#bar\n"]], + "Pass with hash", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => "foo#bar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], + [[OUT_STD, "ok 1 - foo\\#bar # baz bat\n"]], + "Pass with hash and amnesty", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => "foo#x\nbar#boo"}}, 1)], + [ + [OUT_STD, "ok 1 - foo\\#x\n"], + [OUT_STD, "# bar#boo\n"], + ], + "Pass with newline and hash", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 1, details => "foo#x\nbar#boo"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], + [ + [OUT_STD, "ok 1 - foo\\#x # baz bat\n"], + [OUT_STD, "# bar#boo\n"], + ], + "Pass with newline and hash and amnesty", + ); + }; + + tests fail => sub { + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => "foo\nbar"}}, 1)], + [ + [OUT_STD, "not ok 1 - foo\n"], + [OUT_STD, "# bar\n"], + ], + "Pass with newline", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => "foo\nbar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], + [ + [OUT_STD, "not ok 1 - foo # baz bat\n"], + [OUT_STD, "# bar\n"], + ], + "Pass with newline and amnesty", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => "foo#bar"}}, 1)], + [[OUT_STD, "not ok 1 - foo\\#bar\n"]], + "Pass with hash", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => "foo#bar"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], + [[OUT_STD, "not ok 1 - foo\\#bar # baz bat\n"]], + "Pass with hash and amnesty", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => "foo#x\nbar#boo"}}, 1)], + [ + [OUT_STD, "not ok 1 - foo\\#x\n"], + [OUT_STD, "# bar#boo\n"], + ], + "Pass with newline and hash", + ); + + is_deeply( + [$it->assert_tap({assert => {pass => 0, details => "foo#x\nbar#boo"}, amnesty => [{tag => 'baz', details => 'bat'}]}, 1)], + [ + [OUT_STD, "not ok 1 - foo\\#x # baz bat\n"], + [OUT_STD, "# bar#boo\n"], + ], + "Pass with newline and hash and amnesty", + ); + }; }; - tests no_name => sub { - my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass); - my @tap = $fmt->event_tap($ok, 7); + tests parent => sub { is_deeply( - \@tap, [ - [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7\n"], + $it->assert_tap( + { + assert => {pass => 1, details => 'bob'}, + parent => {hid => 1, buffered => 1, children => [{assert => {pass => 1, details => 'bob2'}}]}, + }, + 1 + ) ], - "Got expected output" - ); - }; - - tests todo => sub { - my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass); - $ok->set_todo('b'); - my @tap = $fmt->event_tap($ok, 7); - is_deeply( - \@tap, [ - [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 # TODO b\n"], + [OUT_STD, "ok 1 - bob {\n"], + [OUT_STD, " ok 1 - bob2\n"], + [OUT_STD, "}\n"], ], - "Got expected output" + "Parent (buffered)", ); - $ok->set_todo(""); - - @tap = $fmt->event_tap($ok, 7); is_deeply( - \@tap, [ - [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 # TODO\n"], + $it->assert_tap( + { + assert => {pass => 1, details => 'bob'}, + parent => {hid => 1, buffered => 0, children => [{assert => {pass => 1, details => 'bob2'}}]}, + }, + 1 + ) ], - "Got expected output" + [[OUT_STD, "ok 1 - bob\n"]], + "Parent (un-buffered)", ); }; + + ok(!$$out, "No std output yet"); + ok(!$$err, "No err output yet"); }; -tests plan => sub { - my $plan = Test2::Event::Plan->new( - trace => $trace, - max => 100, +tests debug_tap => sub { + my ($it, $out, $err) = grabber(); + + is_deeply( + [ + $it->debug_tap( + { + assert => {pass => 0}, + trace => {frame => ['foo', 'foo.t', 42]}, + }, + 1 + ) + ], + [ + [OUT_ERR, "# Failed test at foo.t line 42.\n"], + ], + "debug tap, nameless test" ); is_deeply( - [$fmt->event_tap($plan, 1)], - [[OUT_STD, "1..100\n"]], - "Got tap" + [ + $it->debug_tap( + { + assert => {details => 'foo bar', pass => 0}, + trace => {frame => ['foo', 'foo.t', 42]}, + }, + 1 + ) + ], + [ + [OUT_ERR, "# Failed test 'foo bar'\n# at foo.t line 42.\n"], + ], + "Debug tap, named test" ); - $plan->set_max(0); - $plan->set_directive('SKIP'); - $plan->set_reason('foo'); is_deeply( - [$fmt->event_tap($plan, 1)], - [[OUT_STD, "1..0 # SKIP foo\n"]], - "Got tap for skip_all" + [ + $it->debug_tap( + { + assert => {details => 'foo bar', pass => 0}, + trace => {frame => ['foo', 'foo.t', 42], details => 'I say hi!'}, + }, + 1 + ) + ], + [ + [OUT_ERR, "# Failed test 'foo bar'\n# I say hi!\n"], + ], + "Debug tap with details" ); - $plan = Test2::Event::Plan->new( - trace => $trace, - max => 0, - directive => 'skip_all', + is_deeply( + [ + $it->debug_tap( + { + assert => {details => 'foo bar', pass => 0}, + }, + 1 + ) + ], + [ + [OUT_ERR, "# Failed test 'foo bar'\n# [No trace info available]\n"], + ], + "Debug tap no trace" ); + is_deeply( - [$fmt->event_tap($plan)], - [[OUT_STD, "1..0 # SKIP\n"]], - "SKIP without reason" + [ + $it->debug_tap( + { + assert => {details => 'foo bar', pass => 0}, + trace => {frame => ['foo', 'foo.t', 42]}, + amnesty => [], + }, + 1 + ) + ], + [ + [OUT_ERR, "# Failed test 'foo bar'\n# at foo.t line 42.\n"], + ], + "Debug empty amnesty" ); - $plan = Test2::Event::Plan->new( - trace => $trace, - max => 0, - directive => 'no_plan', + is_deeply( + [ + $it->debug_tap( + { + assert => {details => 'foo bar', pass => 0}, + trace => {frame => ['foo', 'foo.t', 42]}, + amnesty => [{tag => 'TODO', details => 'xxx'}], + }, + 1 + ) + ], + [ + [OUT_STD, "# Failed test (with amnesty) 'foo bar'\n# at foo.t line 42.\n"], + ], + "Debug empty amnesty" ); + + + ok(!$$out, "No std output yet"); + ok(!$$err, "No err output yet"); + + my $event = Test2::Event::Fail->new(trace => {frame => ['foo', 'foo.pl', 42]}); + + { + local $ENV{HARNESS_ACTIVE} = 0; + local $ENV{HARNESS_IS_VERBOSE} = 0; + + $event->{name} = 'no harness'; + $it->write($event, 1); + + $ENV{HARNESS_ACTIVE} = 0; + $ENV{HARNESS_IS_VERBOSE} = 1; + + $event->{name} = 'no harness, but strangely verbose'; + $it->write($event, 1); + + $ENV{HARNESS_ACTIVE} = 1; + $ENV{HARNESS_IS_VERBOSE} = 0; + + $event->{name} = 'harness, but not verbose'; + $it->write($event, 1); + + $ENV{HARNESS_ACTIVE} = 1; + $ENV{HARNESS_IS_VERBOSE} = 1; + + $event->{name} = 'harness that is verbose'; + $it->write($event, 1); + } + + is($$out, <<" EOT", "Got 4 failures to STDERR"); +not ok 1 - no harness +not ok 1 - no harness, but strangely verbose +not ok 1 - harness, but not verbose +not ok 1 - harness that is verbose + EOT + + is($$err, <<" EOT", "Got expected diag to STDERR, newline for non-verbose harness"); +# Failed test 'no harness' +# at foo.pl line 42. +# Failed test 'no harness, but strangely verbose' +# at foo.pl line 42. + +# Failed test 'harness, but not verbose' +# at foo.pl line 42. +# Failed test 'harness that is verbose' +# at foo.pl line 42. + EOT +}; + +tests halt_tap => sub { + my ($it, $out, $err) = grabber(); + is_deeply( - [$fmt->event_tap($plan)], + [$it->halt_tap({trace => {nested => 1},})], [], - "NO PLAN" + "No output when nested" ); - $plan = Test2::Event::Plan->new( - trace => $trace, - max => 0, - directive => 'skip_all', - reason => "Foo\nBar\nBaz", + is_deeply( + [$it->halt_tap({trace => {nested => 1, buffered => 1}})], + [[OUT_STD, "Bail out!\n" ]], + "Got tap for nested buffered bail" ); + is_deeply( - [$fmt->event_tap($plan)], - [ - [OUT_STD, "1..0 # SKIP Foo\n# Bar\n# Baz\n"], - ], - "Multi-line reason for skip" + [$it->halt_tap({control => {details => ''}})], + [[OUT_STD, "Bail out!\n"]], + "Empty details" ); + + is_deeply( + [$it->halt_tap({control => {details => undef}})], + [[OUT_STD, "Bail out!\n"]], + "undef details" + ); + + is_deeply( + [$it->halt_tap({control => {details => 0}})], + [[OUT_STD, "Bail out! 0\n"]], + "falsy details" + ); + + is_deeply( + [$it->halt_tap({control => {details => 'foo bar baz'}})], + [[OUT_STD, "Bail out! foo bar baz\n"]], + "full details" + ); + + ok(!$$out, "No std output yet"); + ok(!$$err, "No err output yet"); }; -tests subtest => sub { - my $st = 'Test2::Event::Subtest'; +tests summary_tap => sub { + my ($it, $out, $err) = grabber(); - my $one = $st->new( - trace => $trace, - pass => 1, - buffered => 1, - name => 'foo', - subtest_id => '1-1-1', + is_deeply( + [$it->summary_tap({about => { no_display => 1, details => "Should not see me"}})], + [], + "no display" ); is_deeply( - [$fmt->event_tap($one, 5)], + [$it->summary_tap({about => { no_display => 0, details => ""}})], + [], + "no summary" + ); + + is_deeply( + [$it->summary_tap({about => { no_display => 0, details => "foo bar"}})], + [[OUT_STD, "# foo bar\n"]], + "summary" + ); + + ok(!$$out, "No std output yet"); + ok(!$$err, "No err output yet"); +}; + +tests info_tap => sub { + my ($it, $out, $err) = grabber(); + + is_deeply( + [ + $it->info_tap( + { + info => [ + {debug => 0, details => "foo"}, + {debug => 1, details => "foo"}, + {debug => 0, details => "foo\nbar\nbaz"}, + {debug => 1, details => "foo\nbar\nbaz"}, + ] + } + ) + ], [ - [OUT_STD, "ok 5 - foo {\n"], - [OUT_STD, "}\n"], + [OUT_STD, "# foo\n"], + [OUT_ERR, "# foo\n"], + [OUT_STD, "# foo\n# bar\n# baz\n"], + [OUT_ERR, "# foo\n# bar\n# baz\n"], ], - "Got Buffered TAP output" + "Got all infos" + ); + + my @TAP = $it->info_tap( + { + info => [ + {debug => 0, details => {structure => 'yes'}}, + {debug => 1, details => {structure => 'yes'}}, + ] + } ); - $one->set_buffered(0); + is($TAP[0]->[0], OUT_STD, "First went to STDOUT"); + is($TAP[1]->[0], OUT_ERR, "Second went to STDOUT"); + + like($TAP[0]->[1], qr/structure.*=>.*yes/, "We see the structure in some form"); + like($TAP[1]->[1], qr/structure.*=>.*yes/, "We see the structure in some form"); + + ok(!$$out, "No std output yet"); + ok(!$$err, "No err output yet"); +}; + +tests error_tap => sub { + my ($it, $out, $err) = grabber(); + + # Data::Dumper behavior can change from version to version, specifically + # the Data::Dumper in 5.8.9 produces different whitespace from other + # versions. + require Data::Dumper; + my $dumper = Data::Dumper->new([{structure => 'yes'}])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); + chomp(my $struct = $dumper->Dump); + is_deeply( - [$fmt->event_tap($one, 5)], [ - [OUT_STD, "ok 5 - foo\n"], + $it->error_tap( + { + errors => [ + {details => "foo"}, + {details => "foo\nbar\nbaz"}, + {details => {structure => 'yes'}}, + ] + } + ) + ], + [ + [OUT_ERR, "# foo\n"], + [OUT_ERR, "# foo\n# bar\n# baz\n"], + [OUT_ERR, "$struct\n"], ], - "Got Unbuffered TAP output" + "Got all errors" ); - $one = $st->new( - trace => $trace, - pass => 0, - buffered => 1, - name => 'bar', - subtest_id => '1-1-1', - subevents => [ - Test2::Event::Ok->new(trace => $trace, name => 'first', pass => 1), - Test2::Event::Ok->new(trace => $trace, name => 'second', pass => 0), - Test2::Event::Ok->new(trace => $trace, name => 'third', pass => 1), + ok(!$$out, "No std output yet"); + ok(!$$err, "No err output yet"); +}; + - Test2::Event::Diag->new(trace => $trace, message => 'blah blah'), +tests event_tap => sub { + my ($it, $out, $err) = grabber(); - Test2::Event::Plan->new(trace => $trace, max => 3), + is_deeply( + [$it->event_tap({plan => {count => 5}, assert => {pass => 1}}, 1)], + [ + [OUT_STD, "1..5\n"], + [OUT_STD, "ok 1\n"], ], + "Plan then assertion for first assertion" ); - { - local $ENV{HARNESS_IS_VERBOSE}; - is_deeply( - [$fmt->event_tap($one, 5)], - [ - [OUT_STD, "not ok 5 - bar {\n"], - [OUT_STD, " ok 1 - first\n"], - [OUT_STD, " not ok 2 - second\n"], - [OUT_STD, " ok 3 - third\n"], - [OUT_ERR, " # blah blah\n"], - [OUT_STD, " 1..3\n"], - [OUT_STD, "}\n"], - ], - "Got Buffered TAP output (non-verbose)" - ); - } + $it->{made_assertion} = 1; - { - local $ENV{HARNESS_IS_VERBOSE} = 1; - is_deeply( - [$fmt->event_tap($one, 5)], - [ - [OUT_STD, "not ok 5 - bar {\n"], - [OUT_STD, " ok 1 - first\n"], - [OUT_STD, " not ok 2 - second\n"], - [OUT_STD, " ok 3 - third\n"], - [OUT_ERR, " # blah blah\n"], - [OUT_STD, " 1..3\n"], - [OUT_STD, "}\n"], - ], - "Got Buffered TAP output (verbose)" - ); - } + is_deeply( + [$it->event_tap({plan => {count => 5}, assert => {pass => 1}}, 2)], + [ + [OUT_STD, "ok 2\n"], + [OUT_STD, "1..5\n"], + ], + "Assertion then plan for additional assertions" + ); - { - local $ENV{HARNESS_IS_VERBOSE}; - $one->set_buffered(0); - is_deeply( - [$fmt->event_tap($one, 5)], - [ - # In unbuffered TAP the subevents are rendered outside of this. - [OUT_STD, "not ok 5 - bar\n"], - ], - "Got Unbuffered TAP output (non-verbose)" - ); - } + $it->{made_assertion} = 0; + is_deeply( + [ + $it->event_tap( + { + plan => {count => 5}, + assert => {pass => 0}, + errors => [{details => "foo"}], + info => [ + {tag => 'DIAG', debug => 1, details => 'xxx'}, + {tag => 'NOTE', debug => 0, details => 'yyy'}, + ], + control => {halt => 1, details => 'blah'}, + about => {details => 'xyz'}, + }, + 1 + ) + ], + [ + [OUT_STD, "1..5\n"], + [OUT_STD, "not ok 1\n"], + [OUT_ERR, "# Failed test [No trace info available]\n"], + [OUT_ERR, "# foo\n"], + [OUT_ERR, "# xxx\n"], + [OUT_STD, "# yyy\n"], + [OUT_STD, "Bail out! blah\n"], + ], + "All facets displayed" + ); - { - local $ENV{HARNESS_IS_VERBOSE} = 1; - $one->set_buffered(0); - is_deeply( - [$fmt->event_tap($one, 5)], - [ - # In unbuffered TAP the subevents are rendered outside of this. - [OUT_STD, "not ok 5 - bar\n"], - ], - "Got Unbuffered TAP output (verbose)" - ); - } -}; + is_deeply( + [ + $it->event_tap( + { + plan => {count => 5}, + about => {details => 'xyz'}, + }, + 1 + ) + ], + [[OUT_STD, "1..5\n"]], + "Plan blocks details" + ); -tests skip => sub { - my $skip = Test2::Event::Skip->new(trace => $trace, pass => 1, name => 'foo', reason => 'xxx'); - my @tap = $fmt->event_tap($skip, 7); is_deeply( - \@tap, [ - [OUT_STD, "ok 7 - foo # skip xxx\n"], + $it->event_tap( + { + assert => {pass => 0, no_debug => 1}, + about => {details => 'xyz'}, + }, + 1 + ) ], - "Passing Skip" + [[OUT_STD, "not ok 1\n"]], + "Assert blocks details" ); - $skip->set_pass(0); - @tap = $fmt->event_tap($skip, 7); is_deeply( - \@tap, [ - [OUT_STD, "not ok 7 - foo # skip xxx\n"], + $it->event_tap( + { + errors => [{details => "foo"}], + about => {details => 'xyz'}, + }, + 1 + ) ], - "Failling Skip" + [[OUT_ERR, "# foo\n"]], + "Error blocks details" ); - $skip->set_todo("xxx"); - @tap = $fmt->event_tap($skip, 7); is_deeply( - \@tap, [ - [OUT_STD, "not ok 7 - foo # TODO & SKIP xxx\n"], + $it->event_tap( + { + info => [ + {tag => 'DIAG', debug => 1, details => 'xxx'}, + {tag => 'NOTE', debug => 0, details => 'yyy'}, + ], + about => {details => 'xyz'}, + }, + 1 + ) ], - "Todo Skip" + [ + [OUT_ERR, "# xxx\n"], + [OUT_STD, "# yyy\n"], + ], + "Info blocks details" ); -}; -tests version => sub { - require Test2::Event::TAP::Version; - my $ver = Test2::Event::TAP::Version->new( - trace => $trace, - version => '2', + is_deeply( + [ + $it->event_tap( + { + control => {halt => 1, details => 'blah'}, + about => {details => 'xyz'}, + }, + 1 + ) + ], + [[OUT_STD, "Bail out! blah\n"]], + "Halt blocks details" ); is_deeply( - [$fmt->event_tap($ver, 1)], - [[OUT_STD, "TAP version 2\n"]], - "Got tap" + [$it->event_tap({about => {details => 'xyz'}}, 1)], + [[OUT_STD, "# xyz\n"]], + "Fallback to summary" ); + + ok(!$$out, "No std output yet"); + ok(!$$err, "No err output yet"); }; +tests write => sub { + my ($it, $out, $err) = grabber(); + + local $ENV{HARNESS_ACTIVE} = 0; + local $ENV{HARNESS_IS_VERBOSE} = 0; + + { + local $\ = 'oops1'; + local $, = 'oops2'; + $it->write( + undef, 1, + { + plan => {count => 5}, + assert => {pass => 0}, + errors => [{details => "foo"}], + info => [ + {tag => 'DIAG', debug => 1, details => 'xxx'}, + {tag => 'NOTE', debug => 0, details => 'yyy'}, + ], + control => {halt => 1, details => 'blah'}, + about => {details => 'xyz'}, + }, + ); + + $it->write(undef, 2, {assert => {pass => 1}, trace => {nested => 1}}); + } + + is($it->{_last_fh}, $it->handles->[OUT_STD], "Set last handle"); + + is($$out, <<" EOT", "STDOUT is as expected"); +1..5 +not ok 1 +# yyy +Bail out! blah + ok 2 + EOT + + is($$err, <<" EOT", "STDERR is as expected"); +# Failed test [No trace info available] +# foo +# xxx + EOT +}; done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Hub.t b/cpan/Test-Simple/t/Test2/modules/Hub.t index 1d31a6097f..46bbd54c61 100644 --- a/cpan/Test-Simple/t/Test2/modules/Hub.t +++ b/cpan/Test-Simple/t/Test2/modules/Hub.t @@ -33,7 +33,7 @@ tests basic => sub { my $send_event = sub { my ($msg) = @_; - my $e = My::Event->new(msg => $msg, trace => 'fake'); + my $e = My::Event->new(msg => $msg, trace => Test2::EventFacet::Trace->new(frame => ['fake', 'fake.t', 1])); $hub->send($e); }; @@ -55,7 +55,7 @@ tests follow_ups => sub { my $hub = Test2::Hub->new; $hub->set_count(1); - my $trace = Test2::Util::Trace->new( + my $trace = Test2::EventFacet::Trace->new( frame => [__PACKAGE__, __FILE__, __LINE__], ); @@ -102,7 +102,7 @@ tests IPC => sub { my $build_event = sub { my ($msg) = @_; - return My::Event->new(msg => $msg, trace => 'fake'); + return My::Event->new(msg => $msg, trace => Test2::EventFacet::Trace->new(frame => ['fake', 'fake.t', 1])); }; my $e1 = $build_event->('foo'); @@ -175,7 +175,7 @@ tests listen => sub { my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', - trace => Test2::Util::Trace->new( + trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); @@ -183,7 +183,7 @@ tests listen => sub { my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', - trace => Test2::Util::Trace->new( + trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); @@ -191,7 +191,7 @@ tests listen => sub { my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', - trace => Test2::Util::Trace->new( + trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); @@ -272,7 +272,7 @@ tests filter => sub { my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', - trace => Test2::Util::Trace->new( + trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); @@ -280,7 +280,7 @@ tests filter => sub { my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', - trace => Test2::Util::Trace->new( + trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); @@ -288,7 +288,7 @@ tests filter => sub { my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', - trace => Test2::Util::Trace->new( + trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); @@ -342,7 +342,7 @@ tests pre_filter => sub { my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', - trace => Test2::Util::Trace->new( + trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); @@ -350,7 +350,7 @@ tests pre_filter => sub { my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', - trace => Test2::Util::Trace->new( + trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); @@ -358,7 +358,7 @@ tests pre_filter => sub { my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', - trace => Test2::Util::Trace->new( + trace => Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); @@ -449,7 +449,7 @@ tests state => sub { ok(!eval { $hub->plan(5); 1 }, "Cannot change plan"); like($@, qr/You cannot change the plan/, "Got error"); - my $trace = Test2::Util::Trace->new(frame => ['Foo::Bar', 'foo.t', 42, 'blah']); + my $trace = Test2::EventFacet::Trace->new(frame => ['Foo::Bar', 'foo.t', 42, 'blah']); $hub->finalize($trace); my $ok = eval { $hub->finalize($trace) }; my $err = $@; diff --git a/cpan/Test-Simple/t/Test2/modules/Hub/Subtest.t b/cpan/Test-Simple/t/Test2/modules/Hub/Subtest.t index b0bf9f029f..1f440ad3f6 100644 --- a/cpan/Test-Simple/t/Test2/modules/Hub/Subtest.t +++ b/cpan/Test-Simple/t/Test2/modules/Hub/Subtest.t @@ -53,13 +53,12 @@ ok($one->isa('Test2::Hub'), "inheritence"); my $ok = Test2::Event::Ok->new( pass => 1, name => 'blah', - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), ); def is => ($one->process($ok), 'P!', "processed"); def is => ($ran, 1, "ran the mocked process"); def is => ($event, $ok, "got our event"); - def is => ($event->nested, 3, "nested was set"); def is => ($one->bailed_out, undef, "did not bail"); $ran = 0; @@ -67,20 +66,18 @@ ok($one->isa('Test2::Hub'), "inheritence"); my $bail = Test2::Event::Bail->new( message => 'blah', - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), ); def is => ($one->process($bail), 'P!', "processed"); def is => ($ran, 1, "ran the mocked process"); def is => ($event, $bail, "got our event"); - def is => ($event->nested, 3, "nested was set"); - def is => ($one->bailed_out, $event, "bailed"); } do_def; my $skip = Test2::Event::Plan->new( - trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__], pid => $$, tid => get_tid), + trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__], pid => $$, tid => get_tid), directive => 'SKIP', reason => 'foo', ); diff --git a/cpan/Test-Simple/t/Test2/modules/IPC/Driver/Files.t b/cpan/Test-Simple/t/Test2/modules/IPC/Driver/Files.t index 367d0ef6a0..a29023aa78 100644 --- a/cpan/Test-Simple/t/Test2/modules/IPC/Driver/Files.t +++ b/cpan/Test-Simple/t/Test2/modules/IPC/Driver/Files.t @@ -181,7 +181,7 @@ ok(!-d $tmpdir, "cleaned up temp dir"); $out = simple_capture { my $ipc = Test2::IPC::Driver::Files->new(); $ipc->add_hub($hid); - my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); + my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); my $e = eval { $ipc->send($hid, bless({glob => \*ok, trace => $trace}, 'Foo')); 1 }; print STDERR $@ unless $e || $@ =~ m/^255/; $ipc->drop_hub($hid); diff --git a/cpan/Test-Simple/t/Test2/modules/Tools/Tiny.t b/cpan/Test-Simple/t/Test2/modules/Tools/Tiny.t index bdd941db17..08f87edb6e 100644 --- a/cpan/Test-Simple/t/Test2/modules/Tools/Tiny.t +++ b/cpan/Test-Simple/t/Test2/modules/Tools/Tiny.t @@ -82,23 +82,23 @@ my ($diag, $note) = @$other_events; ok($plan->isa('Test2::Event::Plan'), "got plan"); is($plan->max, 8, "planned for 8 oks"); -ok($ok->isa('Test2::Event::Ok'), "got 'ok' result"); -is($ok->pass, 0, "'ok' test failed"); +ok($ok->isa('Test2::Event::Fail'), "got 'ok' result"); +is($ok->facets->{assert}->pass, 0, "'ok' test failed"); -ok($is->isa('Test2::Event::Ok'), "got 'is' result"); -is($is->pass, 0, "'is' test failed"); +ok($is->isa('Test2::Event::Fail'), "got 'is' result"); +is($ok->facets->{assert}->pass, 0, "test failed"); -ok($isnt->isa('Test2::Event::Ok'), "got 'isnt' result"); -is($isnt->pass, 0, "'isnt' test failed"); +ok($isnt->isa('Test2::Event::Fail'), "got 'isnt' result"); +is($ok->facets->{assert}->pass, 0, "test failed"); -ok($like->isa('Test2::Event::Ok'), "got 'like' result"); -is($like->pass, 0, "'like' test failed"); +ok($like->isa('Test2::Event::Fail'), "got 'like' result"); +is($ok->facets->{assert}->pass, 0, "test failed"); -ok($unlike->isa('Test2::Event::Ok'), "got 'unlike' result"); -is($unlike->pass, 0, "'unlike' test failed"); +ok($unlike->isa('Test2::Event::Fail'), "got 'unlike' result"); +is($ok->facets->{assert}->pass, 0, "test failed"); -ok($is_deeply->isa('Test2::Event::Ok'), "got 'is_deeply' result"); -is($is_deeply->pass, 0, "'is_deeply' test failed"); +ok($is_deeply->isa('Test2::Event::Fail'), "got 'is_deeply' result"); +is($ok->facets->{assert}->pass, 0, "test failed"); ok($diag->isa('Test2::Event::Diag'), "got 'diag' result"); is($diag->message, "Testing Diag", "got diag message"); @@ -129,7 +129,7 @@ $events = intercept { @$events = grep {!$_->isa('Test2::Event::Diag')} @$events; is(@$events, 5, "5 events"); -ok(!$_->pass, "undef test - should not pass") for @$events; +ok(!$_->facets->{assert}->pass, "undef test - should not pass") for @$events; sub tool { context() }; @@ -142,7 +142,7 @@ $events = intercept { $ictx = tool(); $ictx->ok(1, 'pass'); $ictx->ok(0, 'fail'); - my $trace = Test2::Util::Trace->new( + my $trace = Test2::EventFacet::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__], ); $ictx->hub->finalize($trace, 1); @@ -194,7 +194,7 @@ $events = intercept { }; is(@$events, 2, "2 events"); -ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); +ok($events->[0]->isa('Test2::Event::Pass'), "got a pass"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called"); $events = intercept { @@ -204,7 +204,7 @@ $events = intercept { }; is(@$events, 2, "2 events"); -ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); +ok($events->[0]->isa('Test2::Event::Pass'), "got a pass"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called (only 1 plan)"); done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Util.t b/cpan/Test-Simple/t/Test2/modules/Util.t index 2bca8e300c..f47f3f30e4 100644 --- a/cpan/Test-Simple/t/Test2/modules/Util.t +++ b/cpan/Test-Simple/t/Test2/modules/Util.t @@ -1,6 +1,8 @@ use strict; use warnings; +use Config qw/%Config/; + use Test2::Tools::Tiny; use Test2::Util qw/ try @@ -13,6 +15,8 @@ use Test2::Util qw/ CAN_THREAD CAN_REALLY_FORK + CAN_SIGSYS + IS_WIN32 /; @@ -39,4 +43,19 @@ IS_WIN32(); is(IS_WIN32(), ($^O eq 'MSWin32') ? 1 : 0, "IS_WIN32 is correct ($^O)"); +my %sigs = map {$_ => 1} split /\s+/, $Config{sig_name}; +if ($sigs{SYS}) { + ok(CAN_SIGSYS, "System has SIGSYS"); +} +else { + ok(!CAN_SIGSYS, "System lacks SIGSYS"); +} + +my $check_for_sig_sys = Test2::Util->can('_check_for_sig_sys'); +ok($check_for_sig_sys->("FOO SYS BAR"), "Found SIGSYS in the middle"); +ok($check_for_sig_sys->("SYS FOO BAR"), "Found SIGSYS at start"); +ok($check_for_sig_sys->("FOO BAR SYS"), "Found SIGSYS at end"); +ok(!$check_for_sig_sys->("FOO SYSX BAR"), "SYSX is not SYS"); +ok(!$check_for_sig_sys->("FOO XSYS BAR"), "XSYS is not SYS"); + done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Util/Facets2Legacy.t b/cpan/Test-Simple/t/Test2/modules/Util/Facets2Legacy.t new file mode 100644 index 0000000000..98eaac60e2 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/modules/Util/Facets2Legacy.t @@ -0,0 +1,144 @@ +use strict; +use warnings; +use Test2::Tools::Tiny; + +use Test2::Util::Facets2Legacy ':ALL'; + +my $CLASS; +BEGIN { + $CLASS = 'Test2::Util::Facets2Legacy'; + + # This private function is not exported, but we want to test it anyway + *_get_facet_data = $CLASS->can('_get_facet_data'); +} + +tests _get_facet_data => sub { + my $pass = Test2::Event::Pass->new(name => 'xxx'); + is_deeply( + _get_facet_data($pass), + { + about => {package => 'Test2::Event::Pass', details => 'pass'}, + assert => {pass => 1, details => 'xxx'}, + }, + "Got facet data from event" + ); + + is_deeply( + _get_facet_data({assert => {pass => 1}}), + {assert => {pass => 1}}, + "Facet data gets passed through" + ); + + my $file = __FILE__; + my $line; + like( + exception { $line = __LINE__; _get_facet_data([]) }, + qr/'ARRAY\(.*\)' Does not appear to be either a Test::Event or an EventFacet hashref at \Q$file\E line $line/, + "Must provide sane input data" + ); + + { + package Fake::Event; + use base 'Test2::Event'; + use Test2::Util::Facets2Legacy qw/causes_fail/; + } + + my $e = Fake::Event->new(); + like( + exception { $line = __LINE__; $e->causes_fail }, + qr/Cycle between Facets2Legacy and Fake::Event=HASH\(.*\)->facet_data\(\) \(Did you forget to override the facet_data\(\) method\?\)/, + "Cannot depend on legacy facet_data and Facets2Legacy" + ); +}; + +tests causes_fail => sub { + is(causes_fail({errors => [{fail => 1}]}), 1, "Fatal errors cause failure"); + + is(causes_fail({control => {terminate => 0}}), 0, "defined but 0 termination does not cause failure"); + is(causes_fail({control => {terminate => 1}}), 1, "non-zero defined termination causes failure"); + is(causes_fail({control => {halt => 1}}), 1, "A halt causes failure"); + is(causes_fail({assert => {pass => 0}}), 1, "non-passign assert causes failure"); + + is(causes_fail({assert => {pass => 0}, amnesty => [{}]}), 0, "amnesty prevents assertion failure"); + + is(causes_fail({}), 0, "Default is no failure"); +}; + +tests diagnostics => sub { + is(diagnostics({}), 0, "Default is no"); + + is(diagnostics({errors => [{}]}), 1, "Errors mean diagnostics"); + is(diagnostics({info => [{}]}), 0, "Info alone does not make diagnostics"); + + is(diagnostics({info => [{debug => 1}]}), 1, "Debug flag makes info diagnostics"); +}; + +tests global => sub { + is(global({}), 0, "not global by default"); + is(global({control => {global => 0}}), 0, "global not set"); + is(global({control => {global => 1}}), 1, "global is set"); +}; + +tests increments_count => sub { + is(increments_count({}), 0, "No count bump without an assertion"); + is(increments_count({assert => {}}), 1, "count bump with assertion"); +}; + +tests no_display => sub { + is(no_display({}), 0, "default is no"); + is(no_display({about => {no_display => 0}}), 0, "set to off"); + is(no_display({about => {no_display => 1}}), 1, "set to on"); +}; + +tests subtest_id => sub { + is(subtest_id({}), undef, "none by default"); + is(subtest_id({parent => {hid => 123}}), 123, "use parent hid when present"); +}; + +tests summary => sub { + is(summary({}), '', "no summary without about->details"); + is(summary({about => {details => 'foo'}}), 'foo', "got about->details"); +}; + +tests terminate => sub { + is(terminate({}), undef, "undef by default"); + is(terminate({control => {terminate => undef}}), undef, "undef by choice"); + is(terminate({control => {terminate => 100}}), 100, "got the terminate value"); + is(terminate({control => {terminate => 0}}), 0, "0 is passed through"); +}; + +tests sets_plan => sub { + is_deeply( [sets_plan({})], [], "No plan by default"); + + is_deeply( + [sets_plan({plan => {}})], + [0], + "Empty plan means count of 0, nothing extra" + ); + + is_deeply( + [sets_plan({plan => {count => 100}})], + [100], + "Got simple count" + ); + + is_deeply( + [sets_plan({plan => {count => 0, none => 1}})], + [0, 'NO PLAN'], + "No Plan" + ); + + is_deeply( + [sets_plan({plan => {count => 0, skip => 1}})], + [0, 'SKIP'], + "Skip" + ); + + is_deeply( + [sets_plan({plan => {count => 0, skip => 1, details => 'foo bar'}})], + [0, 'SKIP', 'foo bar'], + "Skip with reason" + ); +}; + +done_testing; diff --git a/cpan/Test-Simple/t/Test2/modules/Util/Trace.t b/cpan/Test-Simple/t/Test2/modules/Util/Trace.t index 1f87033a4c..35b4859bc9 100644 --- a/cpan/Test-Simple/t/Test2/modules/Util/Trace.t +++ b/cpan/Test-Simple/t/Test2/modules/Util/Trace.t @@ -1,15 +1,15 @@ use strict; use warnings; use Test2::Tools::Tiny; -use Test2::Util::Trace; +use Test2::EventFacet::Trace; like( - exception { 'Test2::Util::Trace'->new() }, + exception { 'Test2::EventFacet::Trace'->new() }, qr/The 'frame' attribute is required/, "got error" ); -my $one = 'Test2::Util::Trace'->new(frame => ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo']); +my $one = 'Test2::EventFacet::Trace'->new(frame => ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo']); is_deeply($one->frame, ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got frame"); is_deeply([$one->call], ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got call"); is($one->package, 'Foo::Bar', "Got package"); diff --git a/cpan/Test-Simple/t/Test2/regression/746-forking-subtest.t b/cpan/Test-Simple/t/Test2/regression/746-forking-subtest.t new file mode 100644 index 0000000000..b87247d757 --- /dev/null +++ b/cpan/Test-Simple/t/Test2/regression/746-forking-subtest.t @@ -0,0 +1,37 @@ +use strict; +use warnings; +use Test2::IPC; +use Test2::Tools::Tiny; +use Test2::API qw/context intercept test2_stack/; +use Test2::Util qw/CAN_FORK/; + +BEGIN { + skip_all "System cannot fork" unless CAN_FORK; +} + +my $events = intercept { + Test2::API::run_subtest("this subtest forks" => sub { + if (fork) { + wait; + isnt($?, 0, "subprocess died"); + } else { + # Prevent the exception from being rendered to STDERR, people have + # complained about STDERR noise in tests before. + close STDERR; + die "# Expected warning from subtest"; + }; + }, {no_fork => 1}); +}; + +my @subtests = grep {; $_->isa('Test2::Event::Subtest') } @$events; + +if (is(@subtests, 1, "only one subtest run, effectively")) { + my @subokay = grep {; $_->facets->{assert} } + @{ $subtests[0]->subevents }; + is(@subokay, 1, "we got one test result inside the subtest"); + ok(! $subokay[0]->causes_fail, "...and it passed"); +} else { + # give up, we're already clearly broken +} + +done_testing; diff --git a/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm b/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm index bbdf73268f..62c97ecb0f 100644 --- a/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm +++ b/cpan/Test-Simple/t/lib/Test/Builder/NoOutput.pm @@ -53,6 +53,9 @@ sub create { my $class = shift; my $self = $class->SUPER::create(@_); + require Test::Builder::Formatter; + $self->{Stack}->top->format(Test::Builder::Formatter->new); + my %outputs = ( all => '', out => '', diff --git a/cpan/Test-Simple/t/lib/Test/Simple/Catch.pm b/cpan/Test-Simple/t/lib/Test/Simple/Catch.pm index 9a2efb192d..2a6548fa34 100644 --- a/cpan/Test-Simple/t/lib/Test/Simple/Catch.pm +++ b/cpan/Test-Simple/t/lib/Test/Simple/Catch.pm @@ -10,7 +10,9 @@ my $out = tie *$out_fh, 'TieOut'; my $err = tie *$err_fh, 'TieOut'; use Test::Builder; +require Test::Builder::Formatter; my $t = Test::Builder->new; +$t->{Stack}->top->format(Test::Builder::Formatter->new); $t->output($out_fh); $t->failure_output($err_fh); $t->todo_output($err_fh); diff --git a/cpan/Test-Simple/t/regression/696-intercept_skip_all.t b/cpan/Test-Simple/t/regression/696-intercept_skip_all.t index 1362e1046f..faa84a206d 100644 --- a/cpan/Test-Simple/t/regression/696-intercept_skip_all.t +++ b/cpan/Test-Simple/t/regression/696-intercept_skip_all.t @@ -29,7 +29,7 @@ tests no_eval => sub { tests in_require => sub { my $events = intercept { - require 't/lib/SkipAll.pm'; + require './t/lib/SkipAll.pm'; die "Should not see this: $@"; }; diff --git a/cpan/Test-Simple/t/regression/721-nested-streamed-subtest.t b/cpan/Test-Simple/t/regression/721-nested-streamed-subtest.t index b97e0e6a03..a8a8287059 100644 --- a/cpan/Test-Simple/t/regression/721-nested-streamed-subtest.t +++ b/cpan/Test-Simple/t/regression/721-nested-streamed-subtest.t @@ -5,92 +5,95 @@ use Test2::Tools::Tiny; # This module's exports interfere with the ones in t/tools.pl use Test::More (); +use Test::Builder::Formatter(); use Test2::API qw/run_subtest test2_stack/; { - test2_stack->top; - my $temp_hub = test2_stack->new_hub(); + test2_stack->top; + my $temp_hub = test2_stack->new_hub(); + $temp_hub->format(Test::Builder::Formatter->new()); - my $output = capture { - run_subtest( - 'parent', - sub { - run_subtest( - 'buffered', - sub { - ok(1, 'b1'); - ok(1, 'b2'); - }, - {buffered => 1}, - ); - run_subtest( - 'streamed', - sub { - ok(1, 's1'); - ok(1, 's2'); - }, - {buffered => 0}, - ); - }, - {buffered => 1}, - ); - }; + my $output = capture { + run_subtest( + 'parent', + sub { + run_subtest( + 'buffered', + sub { + ok(1, 'b1'); + ok(1, 'b2'); + }, + {buffered => 1}, + ); + run_subtest( + 'streamed', + sub { + ok(1, 's1'); + ok(1, 's2'); + }, + {buffered => 0}, + ); + }, + {buffered => 1}, + ); + }; - test2_stack->pop($temp_hub); + test2_stack->pop($temp_hub); - Test::More::subtest( - 'Test2::API::run_subtest', - sub { - is($output->{STDERR}, q{}, 'no output on stderr'); - like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest'); - like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest'); - like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest'); - like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest'); - } - ); + Test::More::subtest( + 'Test2::API::run_subtest', + sub { + is($output->{STDERR}, q{}, 'no output on stderr'); + like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest'); + like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest'); + like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest'); + like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest'); + } + ); } { - test2_stack->top; - my $temp_hub = test2_stack->new_hub(); + test2_stack->top; + my $temp_hub = test2_stack->new_hub(); + $temp_hub->format(Test::Builder::Formatter->new()); - my $output = capture { - run_subtest( - 'parent', - sub { - run_subtest( - 'buffered', - sub { - ok(1, 'b1'); - ok(1, 'b2'); - }, - {buffered => 1}, - ); - Test::More::subtest( - 'streamed', - sub { - ok(1, 's1'); - ok(1, 's2'); - }, - {buffered => 0}, - ); - }, - {buffered => 1}, - ); - }; + my $output = capture { + run_subtest( + 'parent', + sub { + run_subtest( + 'buffered', + sub { + ok(1, 'b1'); + ok(1, 'b2'); + }, + {buffered => 1}, + ); + Test::More::subtest( + 'streamed', + sub { + ok(1, 's1'); + ok(1, 's2'); + }, + {buffered => 0}, + ); + }, + {buffered => 1}, + ); + }; - test2_stack->pop($temp_hub); + test2_stack->pop($temp_hub); - Test::More::subtest( - 'Test::More::subtest and Test2::API::run_subtest', - sub { - is($output->{STDERR}, q{}, 'no output on stderr'); - like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest'); - like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest'); - like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest'); - like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest'); - } - ); + Test::More::subtest( + 'Test::More::subtest and Test2::API::run_subtest', + sub { + is($output->{STDERR}, q{}, 'no output on stderr'); + like($output->{STDOUT}, qr/ +ok 1 - b1/, 'got ok output for tests in buffered subtest'); + like($output->{STDOUT}, qr/ +ok 2 - b2/, 'got ok output for tests in buffered subtest'); + like($output->{STDOUT}, qr/ +ok 1 - s1/, 'got ok output for tests in streamed subtest'); + like($output->{STDOUT}, qr/ +ok 2 - s2/, 'got ok output for tests in streamed subtest'); + } + ); } done_testing; diff --git a/cpan/Test-Simple/t/regression/757-reset_in_subtest.t b/cpan/Test-Simple/t/regression/757-reset_in_subtest.t new file mode 100644 index 0000000000..846a34d835 --- /dev/null +++ b/cpan/Test-Simple/t/regression/757-reset_in_subtest.t @@ -0,0 +1,20 @@ +use strict; +use warnings; + +use Test::More; + +subtest 'subtest' => sub { + Test::Builder->new->reset; + ok 1; +}; + +subtest 'subtest' => sub { + Test::Builder->new->reset; + subtest 'subtest' => sub { + Test::Builder->new->reset; + ok 1; + }; + ok 1; +}; + +done_testing; diff --git a/cpan/Test-Simple/t/regression/buffered_subtest_plan_buffered.t b/cpan/Test-Simple/t/regression/buffered_subtest_plan_buffered.t new file mode 100644 index 0000000000..e46697a23c --- /dev/null +++ b/cpan/Test-Simple/t/regression/buffered_subtest_plan_buffered.t @@ -0,0 +1,39 @@ +use Test2::Tools::Tiny; +use strict; +use warnings; + +use Test2::API qw/intercept test2_stack/; +use Data::Dumper; + +sub hide_buffered { 0 } + +sub write { + my $self = shift; + my ($e) = @_; + + push @{$self->{events}} => $e; +} + +sub finalize { } + +my $events; +intercept { + my $hub = test2_stack()->top; + my $formatter = bless({}, __PACKAGE__); + $hub->format($formatter); + tests xxx => sub { + ok(1, "pass"); + }; + + $events = $formatter->{events}; +}; + +pop @$events; + + +for my $e (@$events) { + ok($e->trace->buffered, "Buffered events are all listed as buffered") || diag(Dumper($e)); +} + +done_testing; + diff --git a/cpan/Test-Simple/t/regression/builder_does_not_init.t b/cpan/Test-Simple/t/regression/builder_does_not_init.t new file mode 100644 index 0000000000..1f24ef2957 --- /dev/null +++ b/cpan/Test-Simple/t/regression/builder_does_not_init.t @@ -0,0 +1,18 @@ +use strict; +use warnings; + +use Carp qw/confess/; +use Test2::API::Instance; + +BEGIN { + no warnings 'redefine'; + local *Test2::API::Instance::_finalize = sub { confess "_finalize called\n" }; + local *Test2::API::Instance::load = sub { confess "load called\n" }; + + require Test::Builder; +} + +use Test2::Tools::Tiny; + +ok(1, "Did not die"); +done_testing(); |