X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FVPIT%2FTestHelpers.pm;h=75ca21603ff4c794b51e3752f9ebf6f497c4c323;hb=ba865c42d13de4c435b55379b0a32fe232053668;hp=01aff874a8f7a8563554437cf3aee322870b405a;hpb=c9ae9f1b1179b6241fed5883450f6a39a88ef5e7;p=perl%2Fmodules%2FVPIT-TestHelpers.git

diff --git a/lib/VPIT/TestHelpers.pm b/lib/VPIT/TestHelpers.pm
index 01aff87..75ca216 100644
--- a/lib/VPIT/TestHelpers.pm
+++ b/lib/VPIT/TestHelpers.pm
@@ -288,11 +288,19 @@ Dependencies :
 
 =item -
 
-Not VMS
+Neither VMS nor OS/2
 
 =item -
 
-L<IO::Handle>, L<IO::Select>, L<IPC::Open3>
+L<IO::Handle>
+
+=item -
+
+L<IO::Select>
+
+=item -
+
+L<IPC::Open3>
 
 =item -
 
@@ -331,7 +339,8 @@ C<CAPTURE_PERL_FAILED $details> (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 +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 {
@@ -568,21 +586,29 @@ L<threads> 1.67
 
 L<threads::shared> 1.14
 
+=back
+
+=item *
+
+Exports :
+
+=over 8
+
 =item -
 
-L<Test::Leaner>
+C<spawn $coderef>
 
 =back
 
 =item *
 
-Exports :
+Notes :
 
 =over 8
 
 =item -
 
-C<spawn $coderef>
+C<< exit => 'threads_only' >> is passed to C<< threads->import >>.
 
 =back
 
@@ -630,11 +656,11 @@ sub init_threads {
   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;
@@ -660,7 +686,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 *
 
@@ -683,20 +720,60 @@ C<usleep $microseconds>
 =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<Time::HiRes select sleep> 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;
 }