X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FVPIT%2FTestHelpers.pm;h=10550eec28c139e43612a455205230900984c994;hb=32b272838d5cd4620aec5d8b2c6d2fea43e8e0a9;hp=d2484c647322a536947f666e3ebccbd45f0c4503;hpb=ab33575c14a06487f6779b29ab3919291ce0c219;p=perl%2Fmodules%2FVPIT-TestHelpers.git diff --git a/lib/VPIT/TestHelpers.pm b/lib/VPIT/TestHelpers.pm index d2484c6..10550ee 100644 --- a/lib/VPIT/TestHelpers.pm +++ b/lib/VPIT/TestHelpers.pm @@ -193,7 +193,15 @@ C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =item * -Dependencies : none +Dependencies : + +=over 8 + +=item - + +L + +=back =item * @@ -207,6 +215,10 @@ C =item - +C + +=item - + C (possibly prefixed by C<$p>) =back @@ -241,8 +253,14 @@ sub fresh_perl_env (&) { sub init_run_perl { my $p = sanitize_prefix(shift); + # This is only required for run_perl_file(), so it is not needed for the + # threads feature which only calls run_perl() - don't forget to update its + # requirements if this ever changes. + require File::Spec; + return ( run_perl => \&run_perl, + run_perl_file => \&run_perl_file, "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' }, ); } @@ -260,6 +278,20 @@ sub run_perl { }; } +sub run_perl_file { + my $file = shift; + + $file = File::Spec->rel2abs($file); + unless (-e $file and -r _) { + die 'Could not run perl file'; + } + + fresh_perl_env { + my ($perl, @perl_args) = @_; + system { $perl } $perl, @perl_args, $file; + }; +} + =head2 C =over 4 @@ -288,11 +320,19 @@ Dependencies : =item - -Not VMS +Neither VMS nor OS/2 + +=item - + +L =item - -L, L, L +L + +=item - + +L =item - @@ -331,7 +371,8 @@ C (possibly prefixed by C<$p>) 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 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', [ ]; @@ -476,6 +517,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 { @@ -568,21 +618,29 @@ L 1.67 L 1.14 +=back + +=item * + +Exports : + +=over 8 + =item - -L +C =back =item * -Exports : +Notes : =over 8 =item - -C +C<< exit => 'threads_only' >> is passed to C<< threads->import >>. =back @@ -598,6 +656,7 @@ sub init_threads { if (defined $pkg and defined $threadsafe_var) { my $threadsafe; + # run_perl() doesn't actually require anything my $stat = run_perl("require POSIX; require $pkg; exit($threadsafe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"); if (defined $stat) { require POSIX; @@ -620,15 +679,21 @@ sub init_threads { 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', $force ? '0' : '1.67', [ + exit => 'threads_only', + ]; 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; @@ -654,7 +719,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'>, 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 * @@ -677,20 +753,60 @@ 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; + } + }, + '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; }