X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FVPIT%2FTestHelpers.pm;h=27c814907a08f247b9d5b8c3f0be2c5281922f45;hb=ded5cdb5a343bc4e48b7a3f19968af3af55a7c0f;hp=763c7115a5f22e780dc04b1513d28b3d17526d6b;hpb=09bc4632d4b12d88192269d8e57251b41e157380;p=perl%2Fmodules%2FVPIT-TestHelpers.git diff --git a/lib/VPIT/TestHelpers.pm b/lib/VPIT/TestHelpers.pm index 763c711..27c8149 100644 --- a/lib/VPIT/TestHelpers.pm +++ b/lib/VPIT/TestHelpers.pm @@ -29,6 +29,20 @@ 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, @@ -225,17 +239,7 @@ sub fresh_perl_env (&) { } sub init_run_perl { - my $prefix = shift; - - if (defined $prefix) { - if (length $prefix and $prefix !~ /_$/) { - $prefix .= '_'; - } - } else { - $prefix = ''; - } - - my $p = $prefix; + my $p = sanitize_prefix(shift); return ( run_perl => \&run_perl, @@ -264,7 +268,17 @@ sub run_perl { Import : - use VPIT::TestHelpers 'capture' + 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 * @@ -274,11 +288,19 @@ Dependencies : =item - -Not VMS +Neither VMS nor OS/2 =item - -L, L, L +L + +=item - + +L + +=item - + +L =item - @@ -298,8 +320,16 @@ C =item - +C (possibly prefixed by C<$p>) + +=item - + C +=item - + +C (possibly prefixed by C<$p>) + =back =back @@ -307,7 +337,10 @@ C =cut sub init_capture { - skip_all 'Cannot capture output on VMS' if $^O eq 'VMS'; + 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', [ ]; @@ -317,8 +350,10 @@ sub init_capture { } return ( - capture => \&capture, - capture_perl => \&capture_perl, + capture => \&capture, + "${p}CAPTURE_FAILED" => \&capture_failed_msg, + capture_perl => \&capture_perl, + "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg, ); } @@ -450,6 +485,15 @@ sub capture { 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 { @@ -459,6 +503,15 @@ sub capture { } } +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; @@ -472,6 +525,15 @@ sub capture_perl { }; } +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 @@ -481,7 +543,7 @@ sub capture_perl { Import : use VPIT::TestHelpers threads => [ - $pkg, $is_threadsafe, $force_var + $pkg, $threadsafe_var, $force_var ]; where : @@ -490,11 +552,11 @@ where : =item - -C<$pkg> is the target package name to be used in error messages (defaults to C<'package'>) ; +C<$pkg> is the target package name that will be exercised by this test ; =item - -C<$is_threadsafe> is a boolean telling whether the target module is thread-safe (not tested if C) ; +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 - @@ -514,15 +576,15 @@ C 5.13.4 =item - -L 1.67 +L =item - -L 1.14 +L 1.67 =item - -L +L 1.14 =back @@ -543,28 +605,48 @@ C =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; @@ -590,7 +672,18 @@ sub spawn { Import : - use VPIT::TestHelpers 'usleep' + 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 * @@ -613,20 +706,39 @@ C =cut sub init_usleep { - my $usleep; + my (@impls) = @_; - if (do { local $@; eval { require Time::HiRes; 1 } }) { - defined and diag "Using usleep() from Time::HiRes $_" + 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; - $usleep = \&Time::HiRes::usleep; - } else { - diag 'Using fallback usleep()'; - $usleep = sub { - my $s = int($_[0] / 1e6); - sleep $s if $s; - }; + return \&Time::HiRes::usleep; + } else { + return undef; + } + }, + 'sleep' => sub { + diag 'Using sleep()-based fallback usleep()'; + return sub { + my $s = int($_[0] / 1e6); + sleep $s if $s; + }; + }, + ); + + @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; }