cpan/Test-Simple/t/Legacy/subtest/args.t
cpan/Test-Simple/t/Legacy/subtest/bail_out.t
cpan/Test-Simple/t/Legacy/subtest/basic.t
+cpan/Test-Simple/t/Legacy/subtest/callback.t
cpan/Test-Simple/t/Legacy/subtest/die.t
cpan/Test-Simple/t/Legacy/subtest/do.t
cpan/Test-Simple/t/Legacy/subtest/events.t
cpan/Test-Simple/t/Test2/behavior/special_names.t
cpan/Test-Simple/t/Test2/behavior/subtest_bailout.t
cpan/Test-Simple/t/Test2/behavior/Subtest_buffer_formatter.t
+cpan/Test-Simple/t/Test2/behavior/Subtest_callback.t
cpan/Test-Simple/t/Test2/behavior/Subtest_events.t
cpan/Test-Simple/t/Test2/behavior/Subtest_plan.t
cpan/Test-Simple/t/Test2/behavior/Subtest_todo.t
},
'Test::Simple' => {
- 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302113.tar.gz',
+ 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302120.tar.gz',
'FILES' => q[cpan/Test-Simple],
'EXCLUDED' => [
qr{^examples/},
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN {
if( $] < 5.008 ) {
$name ||= "Child of " . $self->name;
+
+ $_->($name,$code,@args)
+ for Test2::API::test2_list_pre_subtest_callbacks();
+
$ctx->note("Subtest: $name");
my $child = $self->child($name);
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) }
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
=head1 NAME
package Test::Builder::Tester;
use strict;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test::Builder;
use Symbol;
package Test::Builder::Tester::Color;
use strict;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
require Test::Builder::Tester;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) }
return warn @_, " at $file line $line\n";
}
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
use strict;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
use vars qw( @ISA @EXPORT );
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
@ISA = qw( Exporter );
package Test::Tester::Capture;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test::Builder;
package Test::Tester::CaptureRunner;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test::Tester::Capture;
package Test::Tester::Delegate;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Scalar::Util();
package Test::use::ok;
use 5.005;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
__END__
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
1;
$ENV{TEST2_ACTIVE} = 1;
}
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
my $INST;
test2_tid
test2_stack
test2_no_wait
+ test2_ipc_wait_enable
+ test2_ipc_wait_disable
+ test2_ipc_wait_enabled
test2_add_callback_context_aquire
test2_add_callback_context_acquire
test2_add_callback_context_release
test2_add_callback_exit
test2_add_callback_post_load
+ test2_add_callback_pre_subtest
test2_list_context_aquire_callbacks
test2_list_context_acquire_callbacks
test2_list_context_init_callbacks
test2_list_context_release_callbacks
test2_list_exit_callbacks
test2_list_post_load_callbacks
+ test2_list_pre_subtest_callbacks
test2_ipc
+ test2_has_ipc
test2_ipc_drivers
test2_ipc_add_driver
test2_ipc_polling
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 }
+sub test2_pid { $INST->pid }
+sub test2_tid { $INST->tid }
+sub test2_stack { $INST->stack }
+sub test2_ipc_wait_enable { $INST->set_no_wait(0) }
+sub test2_ipc_wait_disable { $INST->set_no_wait(1) }
+sub test2_ipc_wait_enabled { !$INST->no_wait }
+
sub test2_no_wait {
$INST->set_no_wait(@_) if @_;
$INST->no_wait;
sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) }
sub test2_add_callback_exit { $INST->add_exit_callback(@_) }
sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) }
+sub test2_add_callback_pre_subtest { $INST->add_pre_subtest_callback(@_) }
sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} }
sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} }
sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} }
sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} }
sub test2_list_exit_callbacks { @{$INST->exit_callbacks} }
sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} }
+sub test2_list_pre_subtest_callbacks { @{$INST->pre_subtest_callbacks} }
sub test2_ipc { $INST->ipc }
+sub test2_has_ipc { $INST->has_ipc }
sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) }
sub test2_ipc_drivers { @{$INST->ipc_drivers} }
sub test2_ipc_polling { $INST->ipc_polling }
sub run_subtest {
my ($name, $code, $params, @args) = @_;
+ $_->($name,$code,@args)
+ for Test2::API::test2_list_pre_subtest_callbacks();
+
$params = {buffered => $params} unless ref $params;
my $inherit_trace = delete $params->{inherit_trace};
This will return the global L<Test2::API::Stack> instance. If this has not
yet been initialized it will be initialized now.
+=item test2_ipc_wait_enable()
+
+=item test2_ipc_wait_disable()
+
+=item $bool = test2_ipc_wait_enabled()
+
+These can be used to turn IPC waiting on and off, or check the current value of
+the flag.
+
+Waiting is turned on by default. Waiting will cause the parent process/thread
+to wait until all child processes and threads are finished before exiting. You
+will almost never want to turn this off.
+
=item $bool = test2_no_wait()
=item test2_no_wait($bool)
+B<DISCOURAGED>: This is a confusing interface, it is better to use
+C<test2_ipc_wait_enable()>, C<test2_ipc_wait_disable()> and
+C<test2_ipc_wait_enabled()>.
+
This can be used to get/set the no_wait status. Waiting is turned on by
default. Waiting will cause the parent process/thread to wait until all child
processes and threads are finished before exiting. You will almost never want
Add a callback that will be called every time a context is released. The
callback will receive the released context as its only argument.
+=item test2_add_callback_pre_subtest(sub { ... })
+
+Add a callback that will be called every time a subtest is going to be
+run. The callback will receive the subtest name, coderef, and any
+arguments.
+
=item @list = test2_list_context_acquire_callbacks()
Return all the context acquire callback references.
Returns all the post load callback references.
+=item @list = test2_list_pre_subtest_callbacks()
+
+Returns all the pre-subtest callback references.
+
=back
=head2 IPC AND CONCURRENCY
=over 4
+=item $bool = test2_has_ipc()
+
+Check if IPC is enabled.
+
=item $ipc = test2_ipc()
This will return the global L<Test2::IPC::Driver> instance. If this has not yet
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test2::Util qw/pkg_to_file/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Carp qw/confess croak/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
context_acquire_callbacks
context_init_callbacks
context_release_callbacks
+ pre_subtest_callbacks
};
sub DEFAULT_IPC_TIMEOUT() { 30 }
}
}
+sub has_ipc { !!$_[0]->{+IPC} }
+
sub import {
my $class = shift;
return unless @_;
$self->{+CONTEXT_ACQUIRE_CALLBACKS} = [];
$self->{+CONTEXT_INIT_CALLBACKS} = [];
$self->{+CONTEXT_RELEASE_CALLBACKS} = [];
+ $self->{+PRE_SUBTEST_CALLBACKS} = [];
$self->{+STACK} = Test2::API::Stack->new;
}
$code->() if $self->{+LOADED};
}
+sub add_pre_subtest_callback {
+ my $self = shift;
+ my ($code) = @_;
+
+ my $rtype = reftype($code) || "";
+
+ confess "Pre-subtest callbacks must be coderefs"
+ unless $code && $rtype eq 'CODE';
+
+ push @{$self->{+PRE_SUBTEST_CALLBACKS}} => $code;
+}
+
sub load {
my $self = shift;
unless ($self->{+LOADED}) {
last if $pid == -1;
next unless $err;
$fail++;
- $err = $err >> 8;
- warn "Process $pid did not exit cleanly (status: $err)\n";
+
+ my $sig = $err & 127;
+ my $exit = $err >> 8;
+ warn "Process $pid did not exit cleanly (wstat: $err, exit: $exit, sig: $sig)\n";
}
alarm 0;
Get all context release callbacks.
+=item $arrayref = $obj->pre_subtest_callbacks
+
+Get all pre-subtest callbacks.
+
=item $obj->add_context_init_callback(sub { ... })
Add a context init callback. Subs are called every time a context is created. Subs
get the released context as their only argument. These callbacks should not
call release on the context.
+=item $obj->add_pre_subtest_callback(sub { ... })
+
+Add a pre-subtest callback. Subs are called every time a subtest is
+going to be run. Subs get the subtest name, coderef, and any
+arguments.
+
=item $obj->set_exit()
This is intended to be called in an C<END { ... }> block. This will look at
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test2::Hub();
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test2::Util::HashBase qw/trace -amnesty/;
use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Carp qw/croak/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test2::EventFacet::Info;
use Carp qw/croak/;
use Scalar::Util qw/reftype/;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::HashBase;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test2::EventFacet::Info;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use Test2::Util::HashBase qw{subevents buffered subtest_id};
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Carp qw/croak/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test2::Util::HashBase qw/-details/;
use Carp qw/croak/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -package -no_display };
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
sub is_list { 1 }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -pass -no_debug -number };
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding };
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
sub facet_key { 'errors' }
sub is_list { 1 }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
sub is_list { 1 }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use vars qw/$AUTOLOAD/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Carp qw/confess/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -count -skip -none };
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
my %ADDED;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test2::Util qw/clone_io/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Carp qw/carp croak confess/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test2::Hub::Interceptor::Terminator();
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
1;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
use Test2::Util::HashBase qw/nested exit_code manual_skip_all/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Test2::API::Instance;
use Test2::API qw{
test2_init_done
test2_ipc
+ test2_has_ipc
test2_ipc_enable_polling
test2_pid
test2_stack
BEGIN { require Exporter; our @ISA = qw(Exporter) }
sub import {
- goto &Exporter::import unless test2_init_done();
+ goto &Exporter::import if test2_has_ipc || !test2_init_done();
confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$;
confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid();
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Carp qw/confess/;
-use Test2::Util::HashBase qw{no_fatal};
+use Test2::Util::HashBase qw{no_fatal no_bail};
use Test2::API qw/test2_ipc_add_driver/;
sub abort {
my $self = shift;
chomp(my ($msg) = @_);
+
+ $self->driver_abort($msg) if $self->can('driver_abort');
+
print STDERR "IPC Fatal Error: $msg\n";
- print STDOUT "not ok - IPC Fatal Error\n";
+ print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail;
CORE::exit(255) unless $self->no_fatal;
}
=over 4
+=item $ipc->driver_abort($msg)
+
+This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your
+chance to cleanup when an abort happens. You cannot prevent the abort, but you
+can gracefully except it.
+
=item $bool = $ipc->use_shm()
True if you want to make use of the L<Test2::API>/L<Test2::API::Instance> SHM.
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }
-use Test2::Util::HashBase qw{tempdir event_id tid pid globals};
+use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals};
use Scalar::Util qw/blessed/;
use File::Temp();
print STDERR "\nIPC Temp Dir: $tmpdir\n\n"
if $ENV{T2_KEEP_TEMPDIR};
- $self->{+EVENT_ID} = 1;
+ $self->{+EVENT_IDS} = {};
+ $self->{+READ_IDS} = {};
+ $self->{+TIMEOUTS} = {};
$self->{+TID} = get_tid();
$self->{+PID} = $$;
$self->abort("'$e' is not an event object!")
unless $type->isa('Test2::Event');
+ my $tid = get_tid();
+ my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1;
+
my @type = split '::', $type;
- my $name = join(ipc_separator, $hid, $$, get_tid(), $self->{+EVENT_ID}++, @type);
+ my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type);
return File::Spec->catfile($tempdir, $name);
}
return 1;
}
+sub driver_abort {
+ my $self = shift;
+ my ($msg) = @_;
+
+ local ($@, $!, $?, $^E);
+ eval {
+ my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
+ open(my $fh, '>>', $abort) or die "Could not open abort file: $!";
+ print $fh $msg, "\n";
+ close($fh) or die "Could not close abort file: $!";
+ 1;
+ } or warn $@;
+}
+
sub cull {
my $self = shift;
my ($hid) = @_;
opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!");
+ my $read = $self->{+READ_IDS};
+ my $timeouts = $self->{+TIMEOUTS};
+
my @out;
for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) {
+ unless ($info->{global}) {
+ my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1;
+
+ $timeouts->{$info->{file}} ||= time;
+
+ if ($next != $info->{eid}) {
+ # Wait up to N seconds for missing events
+ next unless 5 < time - $timeouts->{$info->{file}};
+ $self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}.");
+ }
+
+ $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1;
+ }
+
my $full = $info->{full_path};
my $obj = $self->read_event_file($full);
push @out => $obj;
my $type = join '::' => @parts;
return {
+ file => $file,
ready => $ready,
complete => $complete,
global => $global,
my ($hid, $file) = @_;
return if substr($file, 0, 1) eq '.';
+ return if substr($file, 0, 3) eq 'HUB';
+ CORE::exit(255) if $file eq 'ABORT';
my $parsed = $self->parse_event_filename($file);
my $tempdir = $self->{+TEMPDIR};
+ my $aborted = 0;
+ my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
+ if (-e $abort_file) {
+ $aborted = 1;
+ my ($ok, $err) = do_unlink($abort_file);
+ warn $err unless $ok;
+ }
+
opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)");
while(my $file = readdir($dh)) {
next if $file =~ m/^\.+$/;
my $full = File::Spec->catfile($tempdir, $file);
my $sep = ipc_separator;
- if ($file =~ m/^(GLOBAL|HUB$sep)/) {
+ if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) {
$full =~ m/^(.*)$/;
$full = $1; # Untaint it
next if $ENV{T2_KEEP_TEMPDIR};
return;
}
+ my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
+ unlink($abort) if -e $abort;
rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)";
}
use Test2::Hub::Interceptor();
use Test2::Hub::Interceptor::Terminator();
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
BEGIN { require Exporter; our @ISA = qw(Exporter) }
our @EXPORT = qw{
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use POSIX();
use Config qw/%Config/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Carp qw/croak/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use Carp qw/croak confess/;
use Scalar::Util qw/blessed/;
use strict;
use warnings;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
#################################################################
# #
require Test2::EventFacet::Trace;
@ISA = ('Test2::EventFacet::Trace');
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
1;
package ok;
-our $VERSION = '1.302113';
+our $VERSION = '1.302120';
use strict;
use Test::More ();
--- /dev/null
+#!/usr/bin/perl -w
+
+# What happens when a subtest dies?
+
+use lib 't/lib';
+
+use strict;
+use Test::More;
+use Test::Builder;
+use Test2::API;
+
+my $Test = Test::Builder->new;
+
+my $step = 0;
+my @callback_calls = ();
+Test2::API::test2_add_callback_pre_subtest(
+ sub {
+ $Test->is_num(
+ $step,
+ 0,
+ 'pre-subtest callbacks should be invoked before the subtest',
+ );
+ ++$step;
+ push @callback_calls, [@_];
+ },
+);
+
+$Test->subtest(
+ (my $subtest_name='some subtest'),
+ (my $subtest_code=sub {
+ $Test->is_num(
+ $step,
+ 1,
+ 'subtest should be run after the pre-subtest callbacks',
+ );
+ ++$step;
+ }),
+ (my @subtest_args = (1,2,3)),
+);
+
+is_deeply(
+ \@callback_calls,
+ [[$subtest_name,$subtest_code,@subtest_args]],
+ 'pre-subtest callbacks should be invoked with the expected arguments',
+);
+
+$Test->is_num(
+ $step,
+ 2,
+ 'the subtest should be run',
+);
+
+$Test->done_testing();
--- /dev/null
+use strict;
+use warnings;
+
+use Test2::Tools::Tiny;
+
+use Test2::API qw/run_subtest intercept/;
+
+my $step = 0;
+my @callback_calls = ();
+Test2::API::test2_add_callback_pre_subtest(
+ sub {
+ is(
+ $step,
+ 0,
+ 'pre-subtest callbacks should be invoked before the subtest',
+ );
+ ++$step;
+ push @callback_calls, [@_];
+ },
+);
+
+run_subtest(
+ (my $subtest_name='some subtest'),
+ (my $subtest_code=sub {
+ is(
+ $step,
+ 1,
+ 'subtest should be run after the pre-subtest callbacks',
+ );
+ ++$step;
+ }),
+ undef,
+ (my @subtest_args = (1,2,3)),
+);
+
+is_deeply(
+ \@callback_calls,
+ [[$subtest_name,$subtest_code,@subtest_args]],
+ 'pre-subtest callbacks should be invoked with the expected arguments',
+);
+
+is(
+ $step,
+ 2,
+ 'the subtest should be run',
+);
+
+done_testing;
$CLASS->can('test2_no_wait')->(undef);
ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set");
+ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled");
+$CLASS->can('test2_ipc_wait_disable')->();
+ok(!$CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting disabled");
+$CLASS->can('test2_ipc_wait_enable')->();
+ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled");
+
my $pctx;
sub tool_a($;$) {
Test2::API::context_do {
context_acquire_callbacks => [],
context_init_callbacks => [],
context_release_callbacks => [],
+ pre_subtest_callbacks => [],
stack => [],
},
context_acquire_callbacks => [],
context_init_callbacks => [],
context_release_callbacks => [],
+ pre_subtest_callbacks => [],
stack => [],
},
"Exit callbacks must be coderefs"
);
+$one->reset;
+$one->add_pre_subtest_callback($callback);
+is(@{$one->pre_subtest_callbacks}, 1, "added a pre-subtest callback");
+$one->add_pre_subtest_callback($callback);
+is(@{$one->pre_subtest_callbacks}, 2, "added another pre-subtest callback");
+
+like(
+ exception { $one->add_pre_subtest_callback({}) },
+ qr/Pre-subtest callbacks must be coderefs/,
+ "Pre-subtest callbacks must be coderefs"
+);
+
if (CAN_REALLY_FORK) {
$one->reset;
my $pid = fork;
local $SIG{__WARN__} = sub { push @warnings => @_ };
is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly");
}
- like($warnings[0], qr/Process .* did not exit cleanly \(status: 255\)/, "Warn about exit");
+ like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 255, sig: 0\)/, "Warn about exit");
+
+ $pid = fork;
+ die "Failed to fork!" unless defined $pid;
+ unless($pid) { sleep 20; exit 0 }
+ kill('TERM', $pid) or die "Failed to send signal";
+ @warnings = ();
+ {
+ local $SIG{__WARN__} = sub { push @warnings => @_ };
+ is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly");
+ }
+ like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 0, sig: 15\)/, "Warn about exit");
}
if (CAN_THREAD && $] ge '5.010') {
use warnings;
use Test2::IPC qw/cull/;
-use Test2::API qw/context test2_ipc_drivers test2_ipc/;
+use Test2::API qw/context test2_ipc_drivers test2_ipc intercept/;
use Test2::Tools::Tiny;
ok(__PACKAGE__->can('cull'), "Imported cull");
+ok(eval { intercept { Test2::IPC->import }; 1 }, "Can re-import Test2::IPC without error") or diag $@;
+
done_testing;
}
is($err, "IPC Fatal Error: foo\n", "Got error");
- is($out, "not ok - IPC Fatal Error\n", "got 'not ok' on stdout");
+ is($out, "Bail out! IPC Fatal Error: foo\n", "got 'bail-out' on stdout");
($err, $out) = ("", "");
$one->abort_trace('foo');
}
- is($out, "not ok - IPC Fatal Error\n", "got 'not ok' on stdout");
+ like($out, qr/Bail out! IPC Fatal Error: foo/, "got 'bail-out' on stdout");
like($err, qr/IPC Fatal Error: foo/, "Got error");
};
}
}
{
- no warnings 'once';
+ no warnings qw/once redefine/;
+ local *Test2::IPC::Driver::Files::driver_abort = sub {};
local *Test2::IPC::Driver::Files::abort = sub {
my $self = shift;
local $self->{no_fatal} = 1;
+ local $self->{no_bail} = 1;
$self->Test2::IPC::Driver::abort(@_);
die 255;
};
};
$cleanup->();
- is($out->{STDOUT}, "not ok - IPC Fatal Error\nnot ok - IPC Fatal Error\n", "printed ");
-
like($out->{STDERR}, qr/IPC Temp Dir: \Q$tmpdir\E/m, "Got temp dir path");
like($out->{STDERR}, qr/^# Not removing temp dir: \Q$tmpdir\E$/m, "Notice about not closing tempdir");
pid => "123",
tid => "456",
eid => "789",
+ file => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo',
},
"Parsed global complete"
);
pid => "123",
tid => "456",
eid => "789",
+ file => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo',
},
"Parsed global ready"
);
pid => "123",
tid => "456",
eid => "789",
+ file => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo',
},
"Parsed global not ready"
);
pid => "123",
tid => "456",
eid => "789",
+ file => join ipc_separator, qw'1 1 1 123 456 789 Event Type Foo',
},
"Parsed event complete"
);
pid => "123",
tid => "456",
eid => "789",
+ file => join ipc_separator, qw'1 2 3 123 456 789 Event Type Foo',
},
"Parsed event ready"
);
pid => "123",
tid => "456",
eid => "789",
+ file => join ipc_separator, qw'3 2 11 123 456 789 Event',
},
"Parsed event not ready"
);
use strict;
use warnings;
-use Test2::IPC;
use Test2::Tools::Tiny;
-use Test2::API qw/context test2_stack/;
use Test2::Util qw/CAN_FORK/;
BEGIN {
+ skip_all "Set AUTHOR_TESTING to run this test" unless $ENV{AUTHOR_TESTING};
skip_all "System cannot fork" unless CAN_FORK;
skip_all "known to fail on $]" if $] le "5.006002";
}
-plan(3);
+use IPC::Open3 qw/open3/;
+use File::Temp qw/tempdir/;
-pipe(my ($read, $write));
+my $tempdir = tempdir(CLEANUP => 1);
-test2_stack()->top;
-my $hub = test2_stack()->new_hub();
+open(my $stdout, '>', "$tempdir/stdout") or die "Could not open: $!";
+open(my $stderr, '>', "$tempdir/stderr") or die "Could not open: $!";
-my $pid = fork();
-die "Failed to fork" unless defined $pid;
+my $pid = open3(undef, ">&" . fileno($stdout), ">&" . fileno($stderr), $^X, '-Ilib', '-e', <<'EOT');
+use Test2::IPC::Driver::Files;
+use Test2::IPC;
+use Test2::Tools::Tiny;
+use Test2::API qw/test2_ipc/;
+plan 1;
+ok(1);
-if ($pid) {
- close($read);
- test2_stack()->pop($hub);
- $hub = undef;
- print $write "Go\n";
- close($write);
- waitpid($pid, 0);
- my $err = $? >> 8;
- is($err, 255, "Exit code was not masked");
- ok($err != 100, "Did not hit the safety exit");
-}
-else {
- close($write);
- my $ignore = <$read>;
- close($read);
- close(STDERR);
- close(STDOUT);
- open(STDERR, '>', my $x);
- my $ctx = context(hub => $hub, level => -1);
- my $clone = $ctx->snapshot;
- $ctx->release;
- $clone->ok(0, "Should not see this");
- print STDERR "\n\nSomething went wrong!!!!\n\n";
- exit 100; # Safety exit
-};
-
-
-# The rest of this is to make sure nothing that happens when reading the event
-# messes with $?.
-
-pipe($read, $write);
-
-$pid = fork;
-die "Failed to fork" unless defined $pid;
-
-unless($pid) {
- my $ignore = <$read>;
- ok(1, "Test in forked process");
+my $tmpdir = test2_ipc()->tempdir;
+open(my $fh, '>', "$tmpdir/leftover") or die "Could not open file: $!";
+print $fh "XXX\n";
+close($fh) or die "Could not clone file";
+
+print "TEMPDIR: $tmpdir\n";
+
+exit 100;
+
+EOT
+
+waitpid($pid, 0);
+my $exit = $?;
+
+open($stdout, '<', "$tempdir/stdout") or die "Could not open: $!";
+open($stderr, '<', "$tempdir/stderr") or die "Could not open: $!";
+
+$stdout = join "" => <$stdout>;
+$stderr = join "" => <$stderr>;
+
+is(($exit >> 8), 255, "exited 255");
+like($stderr, qr{^IPC Fatal Error: Leftover files in the directory \(.*/leftover\)!$}m, "Got expected error");
+like($stdout, qr{^Bail out! IPC Fatal Error: Leftover files in the directory \(.*leftover\)!$}m, "Got a bail printed");
+
+if(ok($stdout =~ m/^TEMPDIR: (.*)$/m, "Found temp dir")) {
+ chomp(my $tmpdir = $1);
+ if (-d $tmpdir) {
+ note "Cleaning up temp dir\n";
+
+ opendir(my $dh, $tmpdir) or diag "Could not open temp dir: $!";
+ for my $file (readdir($dh)) {
+ next if $file =~ m/^\./;
+ unlink("$tmpdir/$file") or diag "Could not remove $tmpdir/$file: $!";
+ }
+ closedir($dh);
+ rmdir($tmpdir) or diag "Could not remove temp dir: $!";
+ }
}
-print $write "Go\n";
+done_testing;
https://perl5.git.perl.org / perl5.git / commitdiff