From: Vincent Pit Date: Sun, 23 Oct 2011 10:14:20 +0000 (+0200) Subject: Port threads test to Test::Leaner and move boilerplate to an helper module X-Git-Tag: v0.26~5 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=commitdiff_plain;h=1868a5983f5045def63a5cc7edf41454b407f66c Port threads test to Test::Leaner and move boilerplate to an helper module Test::Leaner 0.04 is bundled. --- diff --git a/MANIFEST b/MANIFEST index ac3d160..ac8dc76 100644 --- a/MANIFEST +++ b/MANIFEST @@ -30,6 +30,7 @@ t/91-pod.t t/92-pod-coverage.t t/95-portability-files.t t/99-kwalitee.t +t/lib/Test/Leaner.pm t/lib/indirect/Test0/Fffff/Vvvvvvv.pm t/lib/indirect/Test0/Oooooo/Pppppppp.pm t/lib/indirect/Test1/il1.pm @@ -47,3 +48,4 @@ t/lib/indirect/TestRequired5/c0.pm t/lib/indirect/TestRequired5/d0.pm t/lib/indirect/TestRequired6.pm t/lib/indirect/TestRequiredGlobal.pm +t/lib/indirect/TestThreads.pm diff --git a/t/40-threads.t b/t/40-threads.t index bde269a..33f5837 100644 --- a/t/40-threads.t +++ b/t/40-threads.t @@ -3,33 +3,10 @@ use strict; use warnings; -sub skipall { - my ($msg) = @_; - require Test::More; - Test::More::plan(skip_all => $msg); -} - -use Config qw<%Config>; - -BEGIN { - my $force = $ENV{PERL_INDIRECT_TEST_THREADS} ? 1 : !1; - skipall 'This perl wasn\'t built to support threads' - unless $Config{useithreads}; - skipall 'perl 5.13.4 required to test thread safety' - unless $force or "$]" >= 5.013004; -} - -use threads; +use lib 't/lib'; +use indirect::TestThreads; -use Test::More; - -BEGIN { - delete $ENV{PERL_INDIRECT_PM_DISABLE}; - require indirect; - skipall 'This indirect isn\'t thread safe' unless indirect::I_THREADSAFE(); - plan tests => 10 * 2 * (2 + 3); - defined and diag "Using threads $_" for $threads::VERSION; -} +use Test::Leaner; sub expect { my ($pkg) = @_; @@ -79,5 +56,8 @@ SKIP: } } -my @t = map threads->create(\&try), 1 .. 10; -$_->join for @t; +my @threads = map spawn(\&try), 1 .. 10; + +$_->join for @threads; + +done_testing(scalar(@threads) * 2 * (2 + 3)); diff --git a/t/41-threads-teardown.t b/t/41-threads-teardown.t index 0b4405e..42d4ae8 100644 --- a/t/41-threads-teardown.t +++ b/t/41-threads-teardown.t @@ -3,33 +3,10 @@ use strict; use warnings; -sub skipall { - my ($msg) = @_; - require Test::More; - Test::More::plan(skip_all => $msg); -} - -use Config qw<%Config>; - -BEGIN { - my $force = $ENV{PERL_INDIRECT_TEST_THREADS} ? 1 : !1; - skipall 'This perl wasn\'t built to support threads' - unless $Config{useithreads}; - skipall 'perl 5.13.4 required to test thread safety' - unless $force or "$]" >= 5.013004; -} +use lib 't/lib'; +use indirect::TestThreads; -use threads; - -use Test::More; - -BEGIN { - delete $ENV{PERL_INDIRECT_PM_DISABLE}; - require indirect; - skipall 'This indirect isn\'t thread safe' unless indirect::I_THREADSAFE(); - plan tests => 1; - defined and diag "Using threads $_" for $threads::VERSION; -} +use Test::Leaner tests => 1; sub run_perl { my $code = shift; diff --git a/t/lib/Test/Leaner.pm b/t/lib/Test/Leaner.pm new file mode 100644 index 0000000..08c8de5 --- /dev/null +++ b/t/lib/Test/Leaner.pm @@ -0,0 +1,897 @@ +package Test::Leaner; + +use 5.006; +use strict; +use warnings; + +=head1 NAME + +Test::Leaner - A slimmer Test::More for when you favor performance over completeness. + +=head1 VERSION + +Version 0.04 + +=cut + +our $VERSION = '0.04'; + +=head1 SYNOPSIS + + use Test::Leaner tests => 10_000; + for (1 .. 10_000) { + ... + is $one, 1, "checking situation $_"; + } + + +=head1 DESCRIPTION + +When profiling some L-based test script that contained about 10 000 unit tests, I realized that 60% of the time was spent in L itself, even though every single test actually involved a costly C. + +This module aims to be a partial replacement to L in those situations where you want to run a large number of simple tests. +Its functions behave the same as their L counterparts, except for the following differences : + +=over 4 + +=item * + +Stringification isn't forced on the test operands. +However, L honors C<'bool'> overloading, L and L honor C<'eq'> overloading (and just that one), L honors C<'ne'> overloading, and L honors whichever overloading category corresponds to the specified operator. + +=item * + +L, L, L, L, L, L, L, L and L are all guaranteed to return the truth value of the test. + +=item * + +C (the sub C in package C) is not aliased to L. + +=item * + +L and L don't special case regular expressions that are passed as C<'/.../'> strings. +A string regexp argument is always treated as the source of the regexp, making C and C equivalent to each other and to C (and likewise for C). + +=item * + +L throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants). +It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator. + +=item * + +L doesn't guard for memory cycles. +If the two first arguments present parallel memory cycles, the test may result in an infinite loop. + +=item * + +The tests don't output any kind of default diagnostic in case of failure ; the rationale being that if you have a large number of tests and a lot of them are failing, then you don't want to be flooded by diagnostics. +Moreover, this allows a much faster variant of L. + +=item * + +C, C, C, C, C, C, C, C blocks and C are not implemented. + +=back + +=cut + +use Exporter (); + +my $main_process; + +BEGIN { + $main_process = $$; + + if ("$]" >= 5.008 and $INC{'threads.pm'}) { + my $use_ithreads = do { + require Config; + no warnings 'once'; + $Config::Config{useithreads}; + }; + if ($use_ithreads) { + require threads::shared; + *THREADSAFE = sub () { 1 }; + } + } + unless (defined &Test::Leaner::THREADSAFE) { + *THREADSAFE = sub () { 0 } + } +} + +my ($TAP_STREAM, $DIAG_STREAM); + +my ($plan, $test, $failed, $no_diag, $done_testing); + +our @EXPORT = qw< + plan + skip + done_testing + pass + fail + ok + is + isnt + like + unlike + cmp_ok + is_deeply + diag + note + BAIL_OUT +>; + +=head1 ENVIRONMENT + +=head2 C + +If this environment variable is set, L will replace its functions by those from L. +Moreover, the symbols that are imported when you C will be those from L, but you can still only import the symbols originally defined in L (hence the functions from L that are not implemented in L will not be imported). +If your version of L is too old and doesn't have some symbols (like L or L), they will be replaced in L by croaking stubs. + +This may be useful if your L-based test script fails and you want extra diagnostics. + +=cut + +sub _handle_import_args { + my @imports; + + my $i = 0; + while ($i <= $#_) { + my $item = $_[$i]; + my $splice; + if (defined $item) { + if ($item eq 'import') { + push @imports, @{ $_[$i+1] }; + $splice = 2; + } elsif ($item eq 'no_diag') { + lock $plan if THREADSAFE; + $no_diag = 1; + $splice = 1; + } + } + if ($splice) { + splice @_, $i, $splice; + } else { + ++$i; + } + } + + return @imports; +} + +if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { + require Test::More; + + my $leaner_stash = \%Test::Leaner::; + my $more_stash = \%Test::More::; + + my %stubbed; + + for (@EXPORT) { + my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE} + : undef; + unless (defined $replacement) { + $stubbed{$_}++; + $replacement = sub { + @_ = ("$_ is not implemented in this version of Test::More"); + goto &croak; + }; + } + no warnings 'redefine'; + $leaner_stash->{$_} = $replacement; + } + + my $import = sub { + my $class = shift; + + my @imports = &_handle_import_args; + if (@imports == grep /^!/, @imports) { + # All imports are negated, or @imports is empty + my %negated; + /^!(.*)/ and ++$negated{$1} for @imports; + push @imports, grep !$negated{$_}, @EXPORT; + } + + my @test_more_imports; + for (@imports) { + if ($stubbed{$_}) { + my $pkg = caller; + no strict 'refs'; + *{$pkg."::$_"} = $leaner_stash->{$_}; + } elsif (/^!/ or !exists $more_stash->{$_} or exists $leaner_stash->{$_}) { + push @test_more_imports, $_; + } else { + # Croak for symbols in Test::More but not in Test::Leaner + Exporter::import($class, $_); + } + } + + my $test_more_import = 'Test::More'->can('import'); + return unless $test_more_import; + + @_ = ( + 'Test::More', + @_, + import => \@test_more_imports, + ); + { + lock $plan if THREADSAFE; + push @_, 'no_diag' if $no_diag; + } + + goto $test_more_import; + }; + + no warnings 'redefine'; + *import = $import; + + return 1; +} + +sub NO_PLAN () { -1 } +sub SKIP_ALL () { -2 } + +BEGIN { + if (THREADSAFE) { + threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing; + } + + lock $plan if THREADSAFE; + + $plan = undef; + $test = 0; + $failed = 0; +} + +sub carp { + my $level = 1 + ($Test::Builder::Level || 0); + my @caller; + do { + @caller = caller $level--; + } while (!@caller and $level >= 0); + my ($file, $line) = @caller[1, 2]; + warn @_, " at $file line $line.\n"; +} + +sub croak { + my $level = 1 + ($Test::Builder::Level || 0); + my @caller; + do { + @caller = caller $level--; + } while (!@caller and $level >= 0); + my ($file, $line) = @caller[1, 2]; + die @_, " at $file line $line.\n"; +} + +sub _sanitize_comment { + $_[0] =~ s/\n+\z//; + $_[0] =~ s/#/\\#/g; + $_[0] =~ s/\n/\n# /g; +} + +=head1 FUNCTIONS + +The following functions from L are implemented and exported by default. + +=head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >> + +See L. + +=cut + +sub plan { + my ($key, $value) = @_; + + return unless $key; + + lock $plan if THREADSAFE; + + croak("You tried to plan twice") if defined $plan; + + my $plan_str; + + if ($key eq 'no_plan') { + croak("no_plan takes no arguments") if $value; + $plan = NO_PLAN; + } elsif ($key eq 'tests') { + croak("Got an undefined number of tests") unless defined $value; + croak("You said to run 0 tests") unless $value; + croak("Number of tests must be a positive integer. You gave it '$value'") + unless $value =~ /^\+?[0-9]+$/; + $plan = $value; + $plan_str = "1..$value"; + } elsif ($key eq 'skip_all') { + $plan = SKIP_ALL; + $plan_str = '1..0 # SKIP'; + if (defined $value) { + _sanitize_comment($value); + $plan_str .= " $value" if length $value; + } + } else { + my @args = grep defined, $key, $value; + croak("plan() doesn't understand @args"); + } + + if (defined $plan_str) { + local $\; + print $TAP_STREAM "$plan_str\n"; + } + + exit 0 if $plan == SKIP_ALL; + + return 1; +} + +sub import { + my $class = shift; + + my @imports = &_handle_import_args; + + if (@_) { + local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; + &plan; + } + + @_ = ($class, @imports); + goto &Exporter::import; +} + +=head2 C<< skip $reason => $count >> + +See L. + +=cut + +sub skip { + my ($reason, $count) = @_; + + lock $plan if THREADSAFE; + + if (not defined $count) { + carp("skip() needs to know \$how_many tests are in the block") + unless defined $plan and $plan == NO_PLAN; + $count = 1; + } elsif ($count =~ /[^0-9]/) { + carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?'); + $count = 1; + } + + for (1 .. $count) { + ++$test; + + my $skip_str = "ok $test # skip"; + if (defined $reason) { + _sanitize_comment($reason); + $skip_str .= " $reason" if length $reason; + } + + local $\; + print $TAP_STREAM "$skip_str\n"; + } + + no warnings 'exiting'; + last SKIP; +} + +=head2 C + +See L. + +=cut + +sub done_testing { + my ($count) = @_; + + lock $plan if THREADSAFE; + + $count = $test unless defined $count; + croak("Number of tests must be a positive integer. You gave it '$count'") + unless $count =~ /^\+?[0-9]+$/; + + if (not defined $plan or $plan == NO_PLAN) { + $plan = $count; # $plan can't be NO_PLAN anymore + $done_testing = 1; + local $\; + print $TAP_STREAM "1..$plan\n"; + } else { + if ($done_testing) { + @_ = ('done_testing() was already called'); + goto &fail; + } elsif ($plan != $count) { + @_ = ("planned to run $plan tests but done_testing() expects $count"); + goto &fail; + } + } + + return 1; +} + +=head2 C + +See L. + +=cut + +sub ok ($;$) { + my ($ok, $desc) = @_; + + lock $plan if THREADSAFE; + + ++$test; + + my $test_str = "ok $test"; + $ok or do { + $test_str = "not $test_str"; + ++$failed; + }; + if (defined $desc) { + _sanitize_comment($desc); + $test_str .= " - $desc" if length $desc; + } + + local $\; + print $TAP_STREAM "$test_str\n"; + + return $ok; +} + +=head2 C + +See L. + +=cut + +sub pass (;$) { + unshift @_, 1; + goto &ok; +} + +=head2 C + +See L. + +=cut + +sub fail (;$) { + unshift @_, 0; + goto &ok; +} + +=head2 C + +See L. + +=cut + +sub is ($$;$) { + my ($got, $expected, $desc) = @_; + no warnings 'uninitialized'; + @_ = ( + (not(defined $got xor defined $expected) and $got eq $expected), + $desc, + ); + goto &ok; +} + +=head2 C + +See L. + +=cut + +sub isnt ($$;$) { + my ($got, $expected, $desc) = @_; + no warnings 'uninitialized'; + @_ = ( + ((defined $got xor defined $expected) or $got ne $expected), + $desc, + ); + goto &ok; +} + +my %binops = ( + 'or' => 'or', + 'xor' => 'xor', + 'and' => 'and', + + '||' => 'hor', + ('//' => 'dor') x ("$]" >= 5.010), + '&&' => 'hand', + + '|' => 'bor', + '^' => 'bxor', + '&' => 'band', + + 'lt' => 'lt', + 'le' => 'le', + 'gt' => 'gt', + 'ge' => 'ge', + 'eq' => 'eq', + 'ne' => 'ne', + 'cmp' => 'cmp', + + '<' => 'nlt', + '<=' => 'nle', + '>' => 'ngt', + '>=' => 'nge', + '==' => 'neq', + '!=' => 'nne', + '<=>' => 'ncmp', + + '=~' => 'like', + '!~' => 'unlike', + ('~~' => 'smartmatch') x ("$]" >= 5.010), + + '+' => 'add', + '-' => 'substract', + '*' => 'multiply', + '/' => 'divide', + '%' => 'modulo', + '<<' => 'lshift', + '>>' => 'rshift', + + '.' => 'concat', + '..' => 'flipflop', + '...' => 'altflipflop', + ',' => 'comma', + '=>' => 'fatcomma', +); + +my %binop_handlers; + +sub _create_binop_handler { + my ($op) = @_; + my $name = $binops{$op}; + croak("Operator $op not supported") unless defined $name; + { + local $@; + eval <<"IS_BINOP"; +sub is_$name (\$\$;\$) { + my (\$got, \$expected, \$desc) = \@_; + \@_ = (scalar(\$got $op \$expected), \$desc); + goto &ok; +} +IS_BINOP + die $@ if $@; + } + $binop_handlers{$op} = do { + no strict 'refs'; + \&{__PACKAGE__."::is_$name"}; + } +} + +=head2 C + +See L. + +=head2 C + +See L. + +=cut + +{ + no warnings 'once'; + *like = _create_binop_handler('=~'); + *unlike = _create_binop_handler('!~'); +} + +=head2 C + +See L. + +=cut + +sub cmp_ok ($$$;$) { + my ($got, $op, $expected, $desc) = @_; + my $handler = $binop_handlers{$op}; + unless ($handler) { + local $Test::More::Level = ($Test::More::Level || 0) + 1; + $handler = _create_binop_handler($op); + } + @_ = ($got, $expected, $desc); + goto $handler; +} + +=head2 C + +See L. + +=cut + +BEGIN { + local $@; + if (eval { require Scalar::Util; 1 }) { + *_reftype = \&Scalar::Util::reftype; + } else { + # Stolen from Scalar::Util::PP + require B; + my %tmap = qw< + B::NULL SCALAR + + B::HV HASH + B::AV ARRAY + B::CV CODE + B::IO IO + B::GV GLOB + B::REGEXP REGEXP + >; + *_reftype = sub ($) { + my $r = shift; + + return undef unless length ref $r; + + my $t = ref B::svref_2object($r); + + return exists $tmap{$t} ? $tmap{$t} + : length ref $$r ? 'REF' + : 'SCALAR' + } + } +} + +sub _deep_ref_check { + my ($x, $y, $ry) = @_; + + no warnings qw; + + if ($ry eq 'ARRAY') { + return 0 unless $#$x == $#$y; + + my ($ex, $ey); + for (0 .. $#$y) { + $ex = $x->[$_]; + $ey = $y->[$_]; + + # Inline the beginning of _deep_check + return 0 if defined $ex xor defined $ey; + + next if not(ref $ex xor ref $ey) and $ex eq $ey; + + $ry = _reftype($ey); + return 0 if _reftype($ex) ne $ry; + + return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); + } + + return 1; + } elsif ($ry eq 'HASH') { + return 0 unless keys(%$x) == keys(%$y); + + my ($ex, $ey); + for (keys %$y) { + return 0 unless exists $x->{$_}; + $ex = $x->{$_}; + $ey = $y->{$_}; + + # Inline the beginning of _deep_check + return 0 if defined $ex xor defined $ey; + + next if not(ref $ex xor ref $ey) and $ex eq $ey; + + $ry = _reftype($ey); + return 0 if _reftype($ex) ne $ry; + + return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); + } + + return 1; + } elsif ($ry eq 'SCALAR' or $ry eq 'REF') { + return _deep_check($$x, $$y); + } + + return 0; +} + +sub _deep_check { + my ($x, $y) = @_; + + no warnings qw; + + return 0 if defined $x xor defined $y; + + # Try object identity/eq overloading first. It also covers the case where + # $x and $y are both undefined. + # If either $x or $y is overloaded but none has eq overloading, the test will + # break at that point. + return 1 if not(ref $x xor ref $y) and $x eq $y; + + # Test::More::is_deeply happily breaks encapsulation if the objects aren't + # overloaded. + my $ry = _reftype($y); + return 0 if _reftype($x) ne $ry; + + # Shortcut if $x and $y are both not references and failed the previous + # $x eq $y test. + return 0 unless $ry; + + # We know that $x and $y are both references of type $ry, without overloading. + _deep_ref_check($x, $y, $ry); +} + +sub is_deeply { + @_ = ( + &_deep_check, + $_[2], + ); + goto &ok; +} + +sub _diag_fh { + my $fh = shift; + + return unless @_; + + lock $plan if THREADSAFE; + return if $no_diag; + + my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; + _sanitize_comment($msg); + return unless length $msg; + + local $\; + print $fh "# $msg\n"; + + return 0; +}; + +=head2 C + +See L. + +=cut + +sub diag { + unshift @_, $DIAG_STREAM; + goto &_diag_fh; +} + +=head2 C + +See L. + +=cut + +sub note { + unshift @_, $TAP_STREAM; + goto &_diag_fh; +} + +=head2 C + +See L. + +=cut + +sub BAIL_OUT { + my ($desc) = @_; + + lock $plan if THREADSAFE; + + my $bail_out_str = 'Bail out!'; + if (defined $desc) { + _sanitize_comment($desc); + $bail_out_str .= " $desc" if length $desc; # Two spaces + } + + local $\; + print $TAP_STREAM "$bail_out_str\n"; + + exit 255; +} + +END { + if ($main_process == $$ and not $?) { + lock $plan if THREADSAFE; + + if (defined $plan) { + if ($failed) { + $? = $failed <= 254 ? $failed : 254; + } elsif ($plan >= 0) { + $? = $test == $plan ? 0 : 255; + } + if ($plan == NO_PLAN) { + local $\; + print $TAP_STREAM "1..$test\n"; + } + } + } +} + +=pod + +L also provides some functions of its own, which are never exported. + +=head2 C + +Read/write accessor for the filehandle to which the tests are outputted. +On write, it also turns autoflush on onto C<$fh>. + +Note that it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. + +Defaults to C. + +=cut + +sub tap_stream (;*) { + if (@_) { + $TAP_STREAM = $_[0]; + + my $fh = select $TAP_STREAM; + $|++; + select $fh; + } + + return $TAP_STREAM; +} + +tap_stream *STDOUT; + +=head2 C + +Read/write accessor for the filehandle to which the diagnostics are printed. +On write, it also turns autoflush on onto C<$fh>. + +Just like L, it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. + +Defaults to C. + +=cut + +sub diag_stream (;*) { + if (@_) { + $DIAG_STREAM = $_[0]; + + my $fh = select $DIAG_STREAM; + $|++; + select $fh; + } + + return $DIAG_STREAM; +} + +diag_stream *STDERR; + +=head2 C + +This constant evaluates to true if and only if L is thread-safe, i.e. when this version of C is at least 5.8, has been compiled with C defined, and L has been loaded B L. +In that case, it also needs a working L. + +=head1 DEPENDENCIES + +L 5.6. + +L, L. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +You can contact me by mail or on C (vincent). + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. +I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Test::Leaner + +=head1 COPYRIGHT & LICENSE + +Copyright 2010,2011 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +Except for the fallback implementation of the internal C<_reftype> function, which has been taken from L and is + +Copyright 1997-2007 Graham Barr, all rights reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; # End of Test::Leaner diff --git a/t/lib/indirect/TestThreads.pm b/t/lib/indirect/TestThreads.pm new file mode 100644 index 0000000..1290340 --- /dev/null +++ b/t/lib/indirect/TestThreads.pm @@ -0,0 +1,67 @@ +package indirect::TestThreads; + +use strict; +use warnings; + +use Config qw<%Config>; + +sub skipall { + my ($msg) = @_; + require Test::Leaner; + Test::Leaner::plan(skip_all => $msg); +} + +sub diag { + require Test::Leaner; + Test::Leaner::diag(@_); +} + +sub import { + shift; + + require indirect; + + skipall 'This indirect isn\'t thread safe' unless indirect::I_THREADSAFE(); + + my $force = $ENV{PERL_INDIRECT_TEST_THREADS} ? 1 : !1; + skipall 'This perl wasn\'t built to support threads' + unless $Config{useithreads}; + skipall 'perl 5.13.4 required to test thread safety' + unless $force or "$]" >= 5.013004; + + my $t_v = $force ? '0' : '1.67'; + my $has_threads = do { + local $@; + eval "use threads $t_v; 1"; + }; + skipall "threads $t_v required to test thread safety" unless $has_threads; + + defined and diag "Using threads $_" for $threads::VERSION; + + my %exports = ( + spawn => \&spawn, + ); + + my $pkg = caller; + while (my ($name, $code) = each %exports) { + no strict 'refs'; + *{$pkg.'::'.$name} = $code; + } +} + +sub spawn { + local $@; + my @diag; + my $thread = eval { + local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; + threads->create(@_); + }; + push @diag, "Thread creation error: $@" if $@; + if (@diag) { + require Test::Leaner; + Test::Leaner::diag($_) for @diag; + } + return $thread ? $thread : (); +} + +1;