From: Vincent Pit Date: Mon, 20 Apr 2015 15:58:55 +0000 (-0300) Subject: Update VPIT::TestHelpers to 2a6ac0f1 X-Git-Tag: rt104312~5 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=8845e141913781c0e0b4b928a38fd23da1752f6b;p=perl%2Fmodules%2Findirect.git Update VPIT::TestHelpers to 2a6ac0f1 --- diff --git a/t/09-load-threads.t b/t/09-load-threads.t index 0d474d5..26c061d 100644 --- a/t/09-load-threads.t +++ b/t/09-load-threads.t @@ -3,9 +3,6 @@ use strict; use warnings; -use lib 't/lib'; -use VPIT::TestHelpers; - BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } my ($module, $thread_safe_var); @@ -32,29 +29,8 @@ sub load_test { # 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 ], - ) -} +use lib 't/lib'; +use VPIT::TestHelpers threads => [ $module, $thread_safe_var ]; my $could_not_create_thread = 'Could not create thread'; diff --git a/t/40-threads.t b/t/40-threads.t index 41ce0a5..a6a38ae 100644 --- a/t/40-threads.t +++ b/t/40-threads.t @@ -1,14 +1,10 @@ -#!perl -T +#!perl use strict; use warnings; -BEGIN { require indirect; } - use lib 't/lib'; -use VPIT::TestHelpers ( - threads => [ 'indirect' => indirect::I_THREADSAFE ], -); +use VPIT::TestHelpers threads => [ 'indirect' => 'indirect::I_THREADSAFE()' ]; use Test::Leaner; diff --git a/t/41-threads-teardown.t b/t/41-threads-teardown.t index 6794151..ecb2636 100644 --- a/t/41-threads-teardown.t +++ b/t/41-threads-teardown.t @@ -3,17 +3,14 @@ use strict; use warnings; -BEGIN { require indirect; } - use lib 't/lib'; use VPIT::TestHelpers ( - threads => [ 'indirect' => indirect::I_THREADSAFE ], + threads => [ 'indirect' => 'indirect::I_THREADSAFE()' ], + 'run_perl', ); use Test::Leaner tests => 3; -my $run_perl_failed = 'Could not execute perl subprocess'; - SKIP: { skip 'Fails on 5.8.2 and lower' => 1 if "$]" <= 5.008_002; @@ -33,7 +30,7 @@ SKIP: { eval q{return; no indirect hook => \&cb; new Z;}; exit $code; RUN - skip $run_perl_failed => 1 unless defined $status; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault'; } @@ -50,7 +47,7 @@ SKIP: { })->join; exit $code; RUN - skip $run_perl_failed => 1 unless defined $status; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'indirect can be loaded in eval STRING during global destruction at the end of a thread'; } @@ -69,6 +66,6 @@ SKIP: { })->join; exit $code; RUN - skip $run_perl_failed => 1 unless defined $status; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'indirect does not check eval STRING during global destruction at the end of a thread'; } diff --git a/t/42-threads-global.t b/t/42-threads-global.t index b3e0bff..dba1a79 100644 --- a/t/42-threads-global.t +++ b/t/42-threads-global.t @@ -1,14 +1,10 @@ -#!perl -T +#!perl use strict; use warnings; -BEGIN { require indirect; } - use lib 't/lib'; -use VPIT::TestHelpers ( - threads => [ 'indirect' => indirect::I_THREADSAFE ], -); +use VPIT::TestHelpers threads => [ 'indirect' => 'indirect::I_THREADSAFE()' ]; use Test::Leaner; diff --git a/t/50-external.t b/t/50-external.t index b98a18f..ebf123f 100644 --- a/t/50-external.t +++ b/t/50-external.t @@ -8,15 +8,13 @@ use Config; use Test::More tests => 6; use lib 't/lib'; -use VPIT::TestHelpers; +use VPIT::TestHelpers 'run_perl'; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } -my $run_perl_failed = 'Could not execute perl subprocess'; - SKIP: { my $status = run_perl 'no indirect; qq{a\x{100}b} =~ /\A[\x00-\x7f]*\z/;'; - skip $run_perl_failed => 1 unless defined $status; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'RT #47866'; } @@ -24,7 +22,7 @@ SKIP: { skip 'Fixed in core only since 5.12' => 1 unless "$]" >= 5.012; my $status = run_perl 'no indirect hook => sub { exit 2 }; new X'; - skip $run_perl_failed => 1 unless defined $status; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 2 << 8, 'no semicolon at the end of -e'; } @@ -32,7 +30,7 @@ SKIP: { load_or_skip('Devel::CallParser', undef, undef, 1); my $status = run_perl "use Devel::CallParser (); no indirect; sub ok { } ok 1"; - skip $run_perl_failed => 1 unless defined $status; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'indirect is not getting upset by Devel::CallParser'; } @@ -45,7 +43,7 @@ SKIP: { unless $has_package_empty; my $status = run_perl 'no indirect hook => sub { }; exit 0; package; new X;'; - skip $run_perl_failed => 1 unless defined $status; + skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'indirect does not croak while package empty is in use'; } @@ -62,10 +60,10 @@ SKIP: { => $tests unless $fork_status == 0; my $status = run_perl 'require indirect; END { eval q[1] } my $pid = fork; exit 0 unless defined $pid; if ($pid) { waitpid $pid, 0; my $status = $?; exit(($status >> 8) || $status) } else { exit 0 }'; - skip $run_perl_failed => $tests unless defined $status; + skip RUN_PERL_FAILED() => $tests unless defined $status; is $status, 0, 'indirect and global END blocks executed at the end of a forked process (RT #99083)'; $status = run_perl 'require indirect; my $pid = fork; exit 0 unless defined $pid; if ($pid) { waitpid $pid, 0; my $status = $?; exit(($status >> 8) || $status) } else { eval q[END { eval q(1) }]; exit 0 }'; - skip $run_perl_failed => ($tests - 1) unless defined $status; + skip RUN_PERL_FAILED() => ($tests - 1) unless defined $status; is $status, 0, 'indirect and local END blocks executed at the end of a forked process'; } diff --git a/t/lib/VPIT/TestHelpers.pm b/t/lib/VPIT/TestHelpers.pm index b8623c5..b7b7635 100644 --- a/t/lib/VPIT/TestHelpers.pm +++ b/t/lib/VPIT/TestHelpers.pm @@ -5,6 +5,19 @@ use warnings; use Config (); +=head1 NAME + +VPIT::TestHelpers + +=head1 SYNTAX + + use VPIT::TestHelpers ( + feature1 => \@feature1_args, + feature2 => \@feature2_args, + ); + +=cut + sub export_to_pkg { my ($subs, $pkg) = @_; @@ -16,16 +29,31 @@ sub export_to_pkg { 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, + threads => \&init_threads, + usleep => \&init_usleep, + run_perl => \&init_run_perl, + capture => \&init_capture, ); sub import { @@ -141,12 +169,54 @@ sub load_or_skip_all { return $loaded; } -sub run_perl { - my $code = shift; +=head1 FEATURES - if ($code =~ /"/) { - die 'Double quotes in evaluated code are not portable'; - } +=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}; @@ -165,55 +235,423 @@ sub run_perl { } } - system { $perl } $perl, '-T', map("-I$_", @INC), '-e', $code; + 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 + +=back + +=cut + sub init_threads { - my ($pkg, $threadsafe, $force_var) = @_; + my ($pkg, $threadsafe_var, $force_var) = @_; skip_all 'This perl wasn\'t built to support threads' unless $Config::Config{useithreads}; - $pkg = 'package' unless defined $pkg; - skip_all "This $pkg isn't thread safe" if defined $threadsafe and !$threadsafe; + 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; - if (($INC{'Test/More.pm'} || $INC{'Test/Leaner.pm'}) && !$INC{'threads.pm'}) { - die 'Test::More/Test::Leaner was loaded too soon'; + 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', [ ]; load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ]; - require Test::Leaner; - diag "Threads testing forced by \$ENV{$force_var}" if $force; return spawn => \&spawn; } -sub init_usleep { - my $usleep; - - if (do { local $@; eval { require Time::HiRes; 1 } }) { - defined and diag "Using usleep() from Time::HiRes $_" - for $Time::HiRes::VERSION; - $usleep = \&Time::HiRes::usleep; - } else { - diag 'Using fallback usleep()'; - $usleep = sub { - my $s = int($_[0] / 2.5e5); - sleep $s if $s; - }; - } - - return usleep => $usleep; -} - sub spawn { local $@; my @diag; @@ -226,6 +664,118 @@ sub spawn { 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'> 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 { @@ -236,4 +786,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;