From: Vincent Pit Date: Sat, 28 Mar 2015 00:32:38 +0000 (-0300) Subject: Thoroughly test module loading in threads X-Git-Tag: v0.57~23 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=7b8b372746ef6628806700587f374f84326fc914;p=perl%2Fmodules%2FVariable-Magic.git Thoroughly test module loading in threads --- diff --git a/MANIFEST b/MANIFEST index 8d72536..2df0f95 100644 --- a/MANIFEST +++ b/MANIFEST @@ -14,6 +14,7 @@ samples/vm_vs_tie.pl t/00-load.t t/01-import.t t/02-constants.t +t/09-load-threads.t t/10-simple.t t/11-multiple.t t/13-data.t @@ -39,6 +40,7 @@ t/35-stash.t t/40-threads.t t/41-clone.t t/80-leaks.t +t/lib/Test/Leaner.pm t/lib/VPIT/TestHelpers.pm t/lib/Variable/Magic/TestDestroyRequired.pm t/lib/Variable/Magic/TestGlobalDestruction.pm diff --git a/t/09-load-threads.t b/t/09-load-threads.t new file mode 100644 index 0000000..88d06c5 --- /dev/null +++ b/t/09-load-threads.t @@ -0,0 +1,253 @@ +#!perl + +use strict; +use warnings; + +use lib 't/lib'; +use VPIT::TestHelpers; + +my ($module, $thread_safe_var); +BEGIN { + $module = 'Variable::Magic'; + $thread_safe_var = 'Variable::Magic::VMG_THREADSAFE()'; +} + +sub load_test { + my $res = 0; + if (defined &Variable::Magic::wizard) { + my $wiz = Variable::Magic::wizard( + free => sub { $res = 1; return }, + ); + my $var; + &Variable::Magic::cast(\$var, $wiz); + $res = 2; + } + return $res; +} + +# Keep the rest of the file untouched + +BEGIN { + my $is_threadsafe; + + if (defined $thread_safe_var) { + my $stat = run_perl "require POSIX; require $module; exit($thread_safe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"; + if (defined $stat) { + require POSIX; + my $res = $stat >> 8; + if ($res == POSIX::EXIT_SUCCESS()) { + $is_threadsafe = 1; + } elsif ($res == POSIX::EXIT_FAILURE()) { + $is_threadsafe = !1; + } + } + if (not defined $is_threadsafe) { + skip_all "Could not detect if $module is thread safe or not"; + } + } + + VPIT::TestHelpers->import( + threads => [ $module => $is_threadsafe ], + ) +} + +my $could_not_create_thread = 'Could not create thread'; + +use Test::Leaner tests => 1 + (2 + 2 * 2) + 6 + (2 * 4) + 2; + +sub is_loaded { + my ($affirmative, $desc) = @_; + + my $res = load_test(); + + if ($affirmative) { + is $res, 1, "$desc: module loaded"; + } else { + is $res, 0, "$desc: module not loaded"; + } +} + +BEGIN { + local $@; + my $code = eval "sub { require $module }"; + die $@ if $@; + *do_load = $code; +} + +is_loaded 0, 'main body, beginning'; + +# Test serial loadings + +SKIP: { + my $thr = spawn(sub { + my $here = "first serial thread"; + is_loaded 0, "$here, beginning"; + + do_load; + is_loaded 1, "$here, after loading"; + + return; + }); + + skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr; + + $thr->join; + if (my $err = $thr->error) { + die $err; + } +} + +is_loaded 0, 'main body, in between serial loadings'; + +SKIP: { + my $thr = spawn(sub { + my $here = "second serial thread"; + is_loaded 0, "$here, beginning"; + + do_load; + is_loaded 1, "$here, after loading"; + + return; + }); + + skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr; + + $thr->join; + if (my $err = $thr->error) { + die $err; + } +} + +is_loaded 0, 'main body, after serial loadings'; + +# Test nested loadings + +SKIP: { + my $thr = spawn(sub { + my $here = 'parent thread'; + is_loaded 0, "$here, beginning"; + + SKIP: { + my $kid = spawn(sub { + my $here = 'child thread'; + is_loaded 0, "$here, beginning"; + + do_load; + is_loaded 1, "$here, after loading"; + + return; + }); + + skip "$could_not_create_thread (nested child)" => 2 unless defined $kid; + + $kid->join; + if (my $err = $kid->error) { + die "in child thread: $err\n"; + } + } + + is_loaded 0, "$here, after child terminated"; + + do_load; + is_loaded 1, "$here, after loading"; + + return; + }); + + skip "$could_not_create_thread (nested parent)" => (3 + 2) unless defined $thr; + + $thr->join; + if (my $err = $thr->error) { + die $err; + } +} + +is_loaded 0, 'main body, after nested loadings'; + +# Test parallel loadings + +use threads; +use threads::shared; + +my @locks = (1) x 5; +share($_) for @locks; + +sub sync_master { + my ($id) = @_; + + { + lock $locks[$id]; + $locks[$id] = 0; + cond_broadcast $locks[$id]; + } +} + +sub sync_slave { + my ($id) = @_; + + { + lock $locks[$id]; + cond_wait $locks[$id] until $locks[$id] == 0; + } +} + +SKIP: { + my $thr1 = spawn(sub { + my $here = 'first simultaneous thread'; + is_loaded 0, "$here, beginning"; + sync_slave 0; + + do_load; + is_loaded 1, "$here, after loading"; + sync_slave 1; + sync_slave 2; + + sync_slave 3; + is_loaded 1, "$here, still loaded while also loaded in the other thread"; + sync_slave 4; + + is_loaded 1, "$here, end"; + + return; + }); + + skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1; + + my $thr2 = spawn(sub { + my $here = 'second simultaneous thread'; + is_loaded 0, "$here, beginning"; + sync_slave 0; + + sync_slave 1; + is_loaded 0, "$here, loaded in other thread but not here"; + sync_slave 2; + + do_load; + is_loaded 1, "$here, after loading"; + sync_slave 3; + sync_slave 4; + + is_loaded 1, "$here, end"; + + return; + }); + + sync_master($_) for 0 .. $#locks; + + $thr1->join; + if (my $err = $thr1->error) { + die $err; + } + + skip "$could_not_create_thread (parallel 2)" => (4 * 1) unless defined $thr2; + + $thr2->join; + if (my $err = $thr2->error) { + die $err; + } +} + +is_loaded 0, 'main body, after simultaneous threads'; + +do_load; +is_loaded 1, 'main body, loaded at end'; diff --git a/t/lib/Test/Leaner.pm b/t/lib/Test/Leaner.pm new file mode 100644 index 0000000..9944e25 --- /dev/null +++ b/t/lib/Test/Leaner.pm @@ -0,0 +1,946 @@ +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.05 + +=cut + +our $VERSION = '0.05'; + +=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; + plan 'no_plan'; + 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 + + done_testing; + done_testing $count; + +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 + + ok $ok; + ok $ok, $desc; + +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 + + pass; + pass $desc; + +See L. + +=cut + +sub pass (;$) { + unshift @_, 1; + goto &ok; +} + +=head2 C + + fail; + fail $desc; + +See L. + +=cut + +sub fail (;$) { + unshift @_, 0; + goto &ok; +} + +=head2 C + + is $got, $expected; + is $got, $expected, $desc; + +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 + + isnt $got, $expected; + isnt $got, $expected, $desc; + +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 + + like $got, $regexp_expected; + like $got, $regexp_expected, $desc; + +See L. + +=head2 C + + unlike $got, $regexp_expected; + unlike $got, $regexp_expected, $desc; + +See L. + +=cut + +{ + no warnings 'once'; + *like = _create_binop_handler('=~'); + *unlike = _create_binop_handler('!~'); +} + +=head2 C + + cmp_ok $got, $op, $expected; + cmp_ok $got, $op, $expected, $desc; + +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 + + is_deeply $got, $expected; + is_deeply $got, $expected, $desc; + +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 + + diag @lines; + +See L. + +=cut + +sub diag { + unshift @_, $DIAG_STREAM; + goto &_diag_fh; +} + +=head2 C + + note @lines; + +See L. + +=cut + +sub note { + unshift @_, $TAP_STREAM; + goto &_diag_fh; +} + +=head2 C + + BAIL_OUT; + BAIL_OUT $desc; + +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 + + my $tap_fh = tap_stream; + tap_stream $fh; + +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 + + my $diag_fh = diag_stream; + diag_stream $fh; + +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,2013 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