From: Vincent Pit Date: Fri, 31 Jul 2015 16:07:27 +0000 (-0300) Subject: Update VPIT::TestHelpers to ba865c42 X-Git-Tag: v0.15~14 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FLexical-Types.git;a=commitdiff_plain;h=0c5eb4d19c4c97d9b26e6a3152e447d37db0a36e Update VPIT::TestHelpers to ba865c42 This causes several other changes : - Test::Leaner is now bundled. - t/80-threads.t and t/81-threads-teardown.t were ported to the new VPIT::TestHelpers interface. They also use Test::Leaner instead of Test::More. - Lexical::Types::TestThreads has been removed. --- diff --git a/MANIFEST b/MANIFEST index 5b1f67c..fbea2d0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -29,5 +29,5 @@ t/lib/Lexical/Types/TestRequired1.pm t/lib/Lexical/Types/TestRequired2.pm t/lib/Lexical/Types/TestRequired3X.pm t/lib/Lexical/Types/TestRequired3Y.pm -t/lib/Lexical/Types/TestThreads.pm +t/lib/Test/Leaner.pm t/lib/VPIT/TestHelpers.pm diff --git a/t/80-threads.t b/t/80-threads.t index 73359c3..62a23b2 100644 --- a/t/80-threads.t +++ b/t/80-threads.t @@ -1,12 +1,14 @@ -#!perl -T +#!perl use strict; use warnings; use lib 't/lib'; -use Lexical::Types::TestThreads; +use VPIT::TestHelpers ( + threads => [ 'Lexical::Types' => 'Lexical::Types::LT_THREADSAFE()' ], +); -use Test::More 'no_plan'; +use Test::Leaner; my $threads = 10; my $runs = 2; @@ -19,8 +21,8 @@ my $runs = 2; my ($file, $line) = (caller(0))[1, 2]; my $where = "at $file line $line in thread $tid"; local $Test::Builder::Level = $Test::Builder::Level + 1; - Test::More::is($_[0], __PACKAGE__, "base type is correct $where"); - Test::More::is($_[2], 'Tag', "original type is correct $where"); + Test::Leaner::is($_[0], __PACKAGE__, "base type is correct $where"); + Test::Leaner::is($_[2], 'Tag', "original type is correct $where"); $_[1] = $tid; (); } @@ -61,3 +63,5 @@ my @t = map spawn(\&try), 1 .. $threads; $_->join for @t; pass 'done'; + +done_testing; diff --git a/t/81-threads-teardown.t b/t/81-threads-teardown.t index 7a5c227..a46d678 100644 --- a/t/81-threads-teardown.t +++ b/t/81-threads-teardown.t @@ -4,12 +4,14 @@ use strict; use warnings; use lib 't/lib'; -use VPIT::TestHelpers; -use Lexical::Types::TestThreads; +use VPIT::TestHelpers ( + threads => [ 'Lexical::Types' => 'Lexical::Types::LT_THREADSAFE()' ], + 'run_perl', +); -use Test::More tests => 2; +use Test::Leaner tests => 2; -{ +SKIP: { my $status = run_perl <<' RUN'; { package IntX; package IntY; package IntZ; } my ($code, @expected); @@ -30,10 +32,11 @@ use Test::More tests => 2; $code += 256 if $code < 0; exit $code; RUN + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault'; } -{ +SKIP: { my $status = run_perl <<' RUN'; use threads; BEGIN { require Lexical::Types; } @@ -48,5 +51,6 @@ use Test::More tests => 2; })->join; exit 0; RUN + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'Lexical::Types can be loaded in eval STRING during global destruction at the end of a thread'; } diff --git a/t/lib/Lexical/Types/TestThreads.pm b/t/lib/Lexical/Types/TestThreads.pm deleted file mode 100644 index 13a72d2..0000000 --- a/t/lib/Lexical/Types/TestThreads.pm +++ /dev/null @@ -1,52 +0,0 @@ -package Lexical::Types::TestThreads; - -use strict; -use warnings; - -use Config qw<%Config>; - -use VPIT::TestHelpers; - -sub import { - shift; - - require Lexical::Types; - - skip_all 'This Lexical::Types isn\'t thread safe' - unless Lexical::Types::LT_THREADSAFE(); - - my $force = $ENV{PERL_LEXICAL_TYPES_TEST_THREADS} ? 1 : !1; - skip_all 'This perl wasn\'t built to support threads' - unless $Config{useithreads}; - skip_all 'perl 5.13.4 required to test thread safety' - unless $force or "$]" >= 5.013_004; - - load_or_skip_all('threads', $force ? '0' : '1.67', [ ]); - - 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; 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 diff --git a/t/lib/VPIT/TestHelpers.pm b/t/lib/VPIT/TestHelpers.pm index c147f80..75ca216 100644 --- a/t/lib/VPIT/TestHelpers.pm +++ b/t/lib/VPIT/TestHelpers.pm @@ -5,20 +5,84 @@ use warnings; use Config (); -my %exports = ( +=head1 NAME + +VPIT::TestHelpers + +=head1 SYNTAX + + use VPIT::TestHelpers ( + feature1 => \@feature1_args, + feature2 => \@feature2_args, + ); + +=cut + +sub export_to_pkg { + my ($subs, $pkg) = @_; + + while (my ($name, $code) = each %$subs) { + no strict 'refs'; + *{$pkg.'::'.$name} = $code; + } + + return 1; +} + +sub sanitize_prefix { + my $prefix = shift; + + if (defined $prefix) { + if (length $prefix and $prefix !~ /_$/) { + $prefix .= '_'; + } + } else { + $prefix = ''; + } + + return $prefix; +} + +my %default_exports = ( load_or_skip => \&load_or_skip, load_or_skip_all => \&load_or_skip_all, - run_perl => \&run_perl, skip_all => \&skip_all, ); +my %features = ( + threads => \&init_threads, + usleep => \&init_usleep, + run_perl => \&init_run_perl, + capture => \&init_capture, +); + sub import { - my $pkg = caller; + shift; + my @opts = @_; - while (my ($name, $code) = each %exports) { - no strict 'refs'; - *{$pkg.'::'.$name} = $code; + my %exports = %default_exports; + + for (my $i = 0; $i <= $#opts; ++$i) { + my $feature = $opts[$i]; + next unless defined $feature; + + my $args; + if ($i < $#opts and defined $opts[$i+1] and ref $opts[$i+1] eq 'ARRAY') { + ++$i; + $args = $opts[$i]; + } else { + $args = [ ]; + } + + my $handler = $features{$feature}; + die "Unknown feature '$feature'" unless defined $handler; + + my %syms = $handler->(@$args); + + $exports{$_} = $syms{$_} for sort keys %syms; } + + export_to_pkg \%exports => scalar caller; } my $test_sub = sub { @@ -105,8 +169,54 @@ sub load_or_skip_all { return $loaded; } -sub run_perl { - my $code = shift; +=head1 FEATURES + +=head2 C + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers run_perl => [ $p ] + +where : + +=over 8 + +=item - + +C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). + +=back + +=item * + +Dependencies : none + +=item * + +Exports : + +=over 8 + +=item - + +C + +=item - + +C (possibly prefixed by C<$p>) + +=back + +=back + +=cut + +sub fresh_perl_env (&) { + my $handler = shift; my ($SystemRoot, $PATH) = @ENV{qw}; my $ld_name = $Config::Config{ldlibpthname}; @@ -117,9 +227,569 @@ sub run_perl { $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; - system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code; + my $perl = $^X; + unless (-e $perl and -x $perl) { + $perl = $Config::Config{perlpath}; + unless (-e $perl and -x $perl) { + return undef; + } + } + + return $handler->($perl, '-T', map("-I$_", @INC)); +} + +sub init_run_perl { + my $p = sanitize_prefix(shift); + + return ( + run_perl => \&run_perl, + "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' }, + ); +} + +sub run_perl { + my $code = shift; + + if ($code =~ /"/) { + die 'Double quotes in evaluated code are not portable'; + } + + fresh_perl_env { + my ($perl, @perl_args) = @_; + system { $perl } $perl, @perl_args, '-e', $code; + }; +} + +=head2 C + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers capture => [ $p ]; + +where : + +=over 8 + +=item - + +C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). + +=back + +=item * + +Dependencies : + +=over 8 + +=item - + +Neither VMS nor OS/2 + +=item - + +L + +=item - + +L + +=item - + +L + +=item - + +On MSWin32 : L + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C + +=item - + +C (possibly prefixed by C<$p>) + +=item - + +C + +=item - + +C (possibly prefixed by C<$p>) + +=back + +=back + +=cut + +sub init_capture { + my $p = sanitize_prefix(shift); + + skip_all 'Cannot capture output on VMS' if $^O eq 'VMS'; + skip_all 'Cannot capture output on OS/2' if $^O eq 'os2'; + + load_or_skip_all 'IO::Handle', '0', [ ]; + load_or_skip_all 'IO::Select', '0', [ ]; + load_or_skip_all 'IPC::Open3', '0', [ ]; + if ($^O eq 'MSWin32') { + load_or_skip_all 'Socket', '0', [ ]; + } + + return ( + capture => \&capture, + "${p}CAPTURE_FAILED" => \&capture_failed_msg, + capture_perl => \&capture_perl, + "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg, + ); +} + +# Inspired from IPC::Cmd + +sub capture { + my @cmd = @_; + + my $want = wantarray; + + my $fail = sub { + my $err = $!; + my $ext_err = $^O eq 'MSWin32' ? $^E : undef; + + my $syscall = shift; + my $args = join ', ', @_; + + my $msg = "$syscall($args) failed: "; + + if (defined $err) { + no warnings 'numeric'; + my ($err_code, $err_str) = (int $err, "$err"); + $msg .= "$err_str ($err_code)"; + } + + if (defined $ext_err) { + no warnings 'numeric'; + my ($ext_err_code, $ext_err_str) = (int $ext_err, "$ext_err"); + $msg .= ", $ext_err_str ($ext_err_code)"; + } + + die "$msg\n"; + }; + + my ($status, $content_out, $content_err); + + local $@; + my $ok = eval { + my ($pid, $out, $err); + + if ($^O eq 'MSWin32') { + my $pipe = sub { + socketpair $_[0], $_[1], + &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC + or $fail->(qw); + shutdown $_[0], 1 or $fail->(qw); + shutdown $_[1], 0 or $fail->(qw); + return 1; + }; + local (*IN_R, *IN_W); + local (*OUT_R, *OUT_W); + local (*ERR_R, *ERR_W); + $pipe->(*IN_R, *IN_W); + $pipe->(*OUT_R, *OUT_W); + $pipe->(*ERR_R, *ERR_W); + + $pid = IPC::Open3::open3('>&IN_R', '<&OUT_W', '<&ERR_W', @cmd); + + close *IN_W or $fail->(qw); + $out = *OUT_R; + $err = *ERR_R; + } else { + my $in = IO::Handle->new; + $out = IO::Handle->new; + $out->autoflush(1); + $err = IO::Handle->new; + $err->autoflush(1); + + $pid = IPC::Open3::open3($in, $out, $err, @cmd); + + close $in; + } + + # Forward signals to the child (except SIGKILL) + my %sig_handlers; + foreach my $s (keys %SIG) { + $sig_handlers{$s} = sub { + kill "$s" => $pid; + $SIG{$s} = $sig_handlers{$s}; + }; + } + local $SIG{$_} = $sig_handlers{$_} for keys %SIG; + + unless ($want) { + close $out or $fail->(qw); + close $err or $fail->(qw); + waitpid $pid, 0; + $status = $?; + return 1; + } + + my $sel = IO::Select->new(); + $sel->add($out, $err); + + my $fd_out = fileno $out; + my $fd_err = fileno $err; + + my %contents; + $contents{$fd_out} = ''; + $contents{$fd_err} = ''; + + while (my @ready = $sel->can_read) { + for my $fh (@ready) { + my $buf; + my $bytes_read = sysread $fh, $buf, 4096; + if (not defined $bytes_read) { + $fail->('sysread', 'fd(' . fileno($fh) . ')'); + } elsif ($bytes_read) { + $contents{fileno($fh)} .= $buf; + } else { + $sel->remove($fh); + close $fh or $fail->('close', 'fd(' . fileno($fh) . ')'); + last unless $sel->count; + } + } + } + + waitpid $pid, 0; + $status = $?; + + if ($^O eq 'MSWin32') { + # Manual CRLF translation that couldn't be done with sysread. + s/\x0D\x0A/\n/g for values %contents; + } + + $content_out = $contents{$fd_out}; + $content_err = $contents{$fd_err}; + + 1; + }; + + if ("$]" < 5.014 and $ok and ($status >> 8) == 255 and defined $content_err + and $content_err =~ /^open3/) { + # Before perl commit 8960aa87 (between 5.12 and 5.14), exceptions in open3 + # could be reported to STDERR instead of being propagated, so work around + # this. + $ok = 0; + $@ = $content_err; + } + + if ($ok) { + return ($status, $content_out, $content_err); + } else { + my $err = $@; + chomp $err; + return (undef, $err); + } +} + +sub capture_failed_msg { + my $details = shift; + + my $msg = 'Could not capture command output'; + $msg .= " ($details)" if defined $details; + + return $msg; +} + +sub capture_perl { + my $code = shift; + + if ($code =~ /"/) { + die 'Double quotes in evaluated code are not portable'; + } + + fresh_perl_env { + my @perl = @_; + capture @perl, '-e', $code; + }; +} + +sub capture_perl_failed_msg { + my $details = shift; + + my $msg = 'Could not capture perl output'; + $msg .= " ($details)" if defined $details; + + return $msg; +} + +=head2 C + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers threads => [ + $pkg, $threadsafe_var, $force_var + ]; + +where : + +=over 8 + +=item - + +C<$pkg> is the target package name that will be exercised by this test ; + +=item - + +C<$threadsafe_var> is the name of an optional variable in C<$pkg> that evaluates to true if and only if the module claims to be thread safe (not checked if either C<$threadsafe_var> or C<$pkg> is C) ; + +=item - + +C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C). + +=back + +=item * + +Dependencies : + +=over 8 + +=item - + +C 5.13.4 + +=item - + +L + +=item - + +L 1.67 + +=item - + +L 1.14 + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C + +=back + +=item * + +Notes : + +=over 8 + +=item - + +C<< exit => 'threads_only' >> is passed to C<< threads->import >>. + +=back + +=back + +=cut + +sub init_threads { + my ($pkg, $threadsafe_var, $force_var) = @_; + + skip_all 'This perl wasn\'t built to support threads' + unless $Config::Config{useithreads}; + + if (defined $pkg and defined $threadsafe_var) { + my $threadsafe; + my $stat = run_perl("require POSIX; require $pkg; exit($threadsafe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"); + if (defined $stat) { + require POSIX; + my $res = $stat >> 8; + if ($res == POSIX::EXIT_SUCCESS()) { + $threadsafe = 1; + } elsif ($res == POSIX::EXIT_FAILURE()) { + $threadsafe = !1; + } + } + if (not defined $threadsafe) { + skip_all "Could not detect if $pkg is thread safe or not"; + } elsif (not $threadsafe) { + skip_all "This $pkg is not thread safe"; + } + } + + $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var; + my $force = $ENV{$force_var} ? 1 : !1; + skip_all 'perl 5.13.4 required to test thread safety' + unless $force or "$]" >= 5.013_004; + + unless ($INC{'threads.pm'}) { + my $test_module; + if ($INC{'Test/Leaner.pm'}) { + $test_module = 'Test::Leaner'; + } elsif ($INC{'Test/More.pm'}) { + $test_module = 'Test::More'; + } + die "$test_module was loaded too soon" if defined $test_module; + } + + load_or_skip_all 'threads', $force ? '0' : '1.67', [ + exit => 'threads_only', + ]; + load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ]; + + diag "Threads testing forced by \$ENV{$force_var}" if $force; + + return spawn => \&spawn; +} + +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 $@; + diag @diag; + return $thread ? $thread : (); } +=head2 C + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers 'usleep' => [ @impls ]; + +where : + +=over 8 + +=item - + +C<@impls> is the list of desired implementations (which may be C<'Time::HiRes'>, C<'select'> or C<'sleep'>), in the order they should be checked. +When the list is empty, it defaults to all of them. + +=back + +=item * + +Dependencies : none + +=item * + +Exports : + +=over 8 + +=item - + +C + +=back + +=back + +=cut + +sub init_usleep { + my (@impls) = @_; + + my %impls = ( + 'Time::HiRes' => sub { + if (do { local $@; eval { require Time::HiRes; 1 } }) { + defined and diag "Using usleep() from Time::HiRes $_" + for $Time::HiRes::VERSION; + return \&Time::HiRes::usleep; + } else { + return undef; + } + }, + 'select' => sub { + if ($Config::Config{d_select}) { + diag 'Using select()-based fallback usleep()'; + return sub ($) { + my $s = $_[0]; + my $r = 0; + while ($s > 0) { + my ($found, $t) = select(undef, undef, undef, $s / 1e6); + last unless defined $t; + $t = int($t * 1e6); + $s -= $t; + $r += $t; + } + return $r; + }; + } else { + return undef; + } + }, + 'sleep' => sub { + diag 'Using sleep()-based fallback usleep()'; + return sub ($) { + my $ms = int $_[0]; + my $s = int($ms / 1e6) + ($ms % 1e6 == 0 ? 0 : 1); + my $t = sleep $s; + return $t * 1e6; + }; + }, + ); + + @impls = qw unless @impls; + + my $usleep; + for my $impl (@impls) { + next unless defined $impl and $impls{$impl}; + $usleep = $impls{$impl}->(); + last if defined $usleep; + } + + skip_all "Could not find a suitable usleep() implementation among: @impls" + unless $usleep; + + return usleep => $usleep; +} + +=head1 CLASSES + +=head2 C + +Syntax : + + { + my $guard = VPIT::TestHelpers::Guard->new($coderef); + ... + } # $codref called here + +=cut + package VPIT::TestHelpers::Guard; sub new { @@ -130,4 +800,16 @@ sub new { sub DESTROY { $_[0]->{code}->() } +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +=head1 COPYRIGHT & LICENSE + +Copyright 2012,2013,2014,2015 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. + +=cut + 1;