diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test2/API')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Test2/API/Breakage.pm | 4 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Test2/API/Context.pm | 40 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Test2/API/Instance.pm | 132 | ||||
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Test2/API/Stack.pm | 4 |
4 files changed, 57 insertions, 123 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test2/API/Breakage.pm b/Master/tlpkg/tlperl/lib/Test2/API/Breakage.pm index 08aee9dcb1a..ffcf1be582f 100755 --- a/Master/tlpkg/tlperl/lib/Test2/API/Breakage.pm +++ b/Master/tlpkg/tlperl/lib/Test2/API/Breakage.pm @@ -2,7 +2,7 @@ package Test2::API::Breakage; use strict; use warnings; -our $VERSION = '1.302133'; +our $VERSION = '1.302162'; use Test2::Util qw/pkg_to_file/; @@ -168,7 +168,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2019 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/Master/tlpkg/tlperl/lib/Test2/API/Context.pm b/Master/tlpkg/tlperl/lib/Test2/API/Context.pm index 6141a43ff8e..9cb1cfca723 100755 --- a/Master/tlpkg/tlperl/lib/Test2/API/Context.pm +++ b/Master/tlpkg/tlperl/lib/Test2/API/Context.pm @@ -2,7 +2,7 @@ package Test2::API::Context; use strict; use warnings; -our $VERSION = '1.302133'; +our $VERSION = '1.302162'; use Carp qw/confess croak/; @@ -325,7 +325,15 @@ sub fail { "Test2::Event::Fail" ); - $e->add_info({tag => 'DIAG', debug => 1, details => $_}) for @diag; + for my $msg (@diag) { + if (ref($msg) eq 'Test2::EventFacet::Info::Table') { + $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args}); + } + else { + $e->add_info({tag => 'DIAG', debug => 1, details => $msg}); + } + } + $self->{+HUB}->send($e); return $e; } @@ -342,7 +350,15 @@ sub fail_and_release { "Test2::Event::Fail" ); - $e->add_info({tag => 'DIAG', debug => 1, details => $_}) for @diag; + for my $msg (@diag) { + if (ref($msg) eq 'Test2::EventFacet::Info::Table') { + $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args}); + } + else { + $e->add_info({tag => 'DIAG', debug => 1, details => $msg}); + } + } + $self->{+HUB}->send($e); $self->release; return 0; @@ -490,7 +506,14 @@ should always use C<context()> which is exported by the L<Test2::API> module. sub my_ok { my ($bool, $name) = @_; my $ctx = context(); - $ctx->ok($bool, $name); + + if ($bool) { + $ctx->pass($name); + } + else { + $ctx->fail($name); + } + $ctx->release; # You MUST do this! return $bool; } @@ -715,6 +738,10 @@ write more clear and compact code. This lets you send an L<Test2::Event::Fail> event. You may optionally provide a C<$name> and C<@diagnostics> messages. +Diagnostics messages can be simple strings, data structures, or instances of +L<Test2::EventFacet::Info::Table> (which are converted inline into the +L<Test2::EventFacet::Info> structure). + =item my $false = $ctx->fail_and_release() =item my $false = $ctx->fail_and_release($name) @@ -760,7 +787,8 @@ 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. +the event of a test failure. Unlike with C<fail()> these diagnostics must be +plain strings, data structures are not supported. =item $event = $ctx->note($message) @@ -975,7 +1003,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2019 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/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm b/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm index 0522dd77aa4..1cf224cf063 100755 --- a/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm +++ b/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm @@ -2,8 +2,7 @@ package Test2::API::Instance; use strict; use warnings; -our $VERSION = '1.302133'; - +our $VERSION = '1.302162'; our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; use Carp qw/confess carp/; @@ -26,9 +25,6 @@ use Test2::Util::HashBase qw{ -preload ipc_disabled - ipc_shm_size - ipc_shm_last - ipc_shm_id ipc_polling ipc_drivers ipc_timeout @@ -216,7 +212,6 @@ sub _finalize { for my $driver (@{$self->{+IPC_DRIVERS}}) { next unless $driver->can('is_viable') && $driver->is_viable; $self->{+IPC} = $driver->new or next; - $self->ipc_enable_shm if $self->{+IPC}->use_shm; return; } @@ -366,91 +361,36 @@ sub enable_ipc_polling { # $_[0] is a context object sub { return unless $self->{+IPC_POLLING}; - return $_[0]->{hub}->cull unless $self->{+IPC_SHM_ID}; - - my $val; - if(shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE})) { - return if $val eq $self->{+IPC_SHM_LAST}; - $self->{+IPC_SHM_LAST} = $val; - } - else { - warn "SHM Read error: $!\n"; - } - - $_[0]->{hub}->cull; + return unless $self->{+IPC}; + return unless $self->{+IPC}->pending(); + return $_[0]->{hub}->cull; } ) unless defined $self->ipc_polling; $self->set_ipc_polling(1); } -sub ipc_enable_shm { +sub get_ipc_pending { my $self = shift; - - return 1 if defined $self->{+IPC_SHM_ID}; - - $self->{+_PID} = $$ unless defined $self->{+_PID}; - $self->{+_TID} = get_tid() unless defined $self->{+_TID}; - - my ($ok, $err) = try { - # SysV IPC can be available but not enabled. - # - # 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' if CAN_SIGSYS; - - require IPC::SysV; - - my $ipc_key = IPC::SysV::IPC_PRIVATE(); - my $shm_size = $self->{+IPC}->can('shm_size') ? $self->{+IPC}->shm_size : 64; - my $shm_id = shmget($ipc_key, $shm_size, 0666) or die "Could not get shm: $!"; - - my $initial = 'a' x $shm_size; - shmwrite($shm_id, $initial, 0, $shm_size) or die "Could not write to shm: $!"; - my $val; - shmread($shm_id, $val, 0, $shm_size) or die "Could not read from shm: $!"; - die "Read SHM value does not match the initial value ('$val' vs '$initial')" - unless $val eq $initial; - - $self->{+IPC_SHM_SIZE} = $shm_size; - $self->{+IPC_SHM_ID} = $shm_id; - $self->{+IPC_SHM_LAST} = $initial; - }; - - return $ok; + return -1 unless $self->{+IPC}; + $self->{+IPC}->pending(); } -sub ipc_free_shm { +sub _check_pid { my $self = shift; - - my $id = delete $self->{+IPC_SHM_ID}; - return unless defined $id; - - shmctl($id, IPC::SysV::IPC_RMID(), 0); -} - -sub get_ipc_pending { - my $self = shift; - return -1 unless defined $self->{+IPC_SHM_ID}; - my $val; - shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return -1; - return 0 if $val eq $self->{+IPC_SHM_LAST}; - $self->{+IPC_SHM_LAST} = $val; - return 1; + my ($pid) = @_; + return kill(0, $pid); } sub set_ipc_pending { my $self = shift; - - return undef unless defined $self->{+IPC_SHM_ID}; - + return unless $self->{+IPC}; my ($val) = @_; confess "value is required for set_ipc_pending" unless $val; - shmwrite($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}); + $self->{+IPC}->set_pending($val); } sub disable_ipc_polling { @@ -517,18 +457,6 @@ sub _ipc_wait { 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(); - - shmctl($self->{+IPC_SHM_ID}, IPC::SysV::IPC_RMID(), 0) - if defined $self->{+IPC_SHM_ID}; -} - sub set_exit { my $self = shift; @@ -740,42 +668,20 @@ This is intended to be called in an C<END { ... }> block. This will look at test state and set $?. This will also call any end callbacks, and wait on child processes/threads. -=item $obj->ipc_enable_shm() - -Turn on SHM for IPC (if possible) - -=item $shm_id = $obj->ipc_shm_id() - -If SHM is enabled for IPC this will be the shm_id for it. - -=item $shm_size = $obj->ipc_shm_size() - -If SHM is enabled for IPC this will be the size of it. - -=item $shm_last_val = $obj->ipc_shm_last() - -If SHM is enabled for IPC this will return the last SHM value seen. - =item $obj->set_ipc_pending($val) -use the IPC SHM to tell other processes and threads there is a pending event. -C<$val> should be a unique value no other thread/process will generate. +Tell other processes and threads there is a pending event. C<$val> should be a +unique value no other thread/process will generate. -B<Note:> This will also make the current process see a pending event. It does -not set C<ipc_shm_last()>, this is important because doing so could hide a -previous change. +B<Note:> This will also make the current process see a pending event. =item $pending = $obj->get_ipc_pending() -This returns -1 if SHM is not enabled for IPC. - -This returns 0 if the SHM value matches the last known value, which means there -are no pending events. +This returns -1 if it is not possible to know. -This returns 1 if the SHM value has changed, which means there are probably -pending events. +This returns 0 if there are no pending events. -When 1 is returned this will set C<< $obj->ipc_shm_last() >>. +This returns 1 if there are pending events. =item $timeout = $obj->ipc_timeout; @@ -906,7 +812,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2019 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/Master/tlpkg/tlperl/lib/Test2/API/Stack.pm b/Master/tlpkg/tlperl/lib/Test2/API/Stack.pm index 8007e1a6540..ffa4ed57f01 100755 --- a/Master/tlpkg/tlperl/lib/Test2/API/Stack.pm +++ b/Master/tlpkg/tlperl/lib/Test2/API/Stack.pm @@ -2,7 +2,7 @@ package Test2::API::Stack; use strict; use warnings; -our $VERSION = '1.302133'; +our $VERSION = '1.302162'; use Test2::Hub(); @@ -210,7 +210,7 @@ F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT -Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2019 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. |