Add capture feature

diff --git a/lib/VPIT/TestHelpers.pm b/lib/VPIT/TestHelpers.pm
index b8623c536b65a652df5b5d01fdb6e980f95e6ee5..9054314e3be4a04356cadac696e7f8ddd88f2d9d 100644 (file)
--- a/lib/VPIT/TestHelpers.pm
+++ b/lib/VPIT/TestHelpers.pm
@@ -26,6 +26,7 @@ my %default_exports = (
 my %features = (
  threads => \&init_threads,
  usleep  => \&init_usleep,
+ capture => \&init_capture,
 );
 
 sub import {
@@ -168,6 +169,156 @@ sub run_perl {
  system { $perl } $perl, '-T', map("-I$_", @INC), '-e', $code;
 }
 
+sub init_capture {
+ skip_all 'Cannot capture output on VMS' if $^O eq 'VMS';
+
+ 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;
+}
+
+# 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<socketpair reader writer>);
+    shutdown $_[0], 1 or $fail->(qw<shutdown reader>);
+    shutdown $_[1], 0 or $fail->(qw<shutdown writer>);
+    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<close input>);
+   $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 output>);
+   close $err or $fail->(qw<close error>);
+   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 ($ok) {
+  return ($status, $content_out, $content_err);
+ } else {
+  my $err = $@;
+  chomp $err;
+  return (undef, $err);
+ }
+}
+
 sub init_threads {
  my ($pkg, $threadsafe, $force_var) = @_;
 

diff --git a/t/31-capture.t b/t/31-capture.t
new file mode 100644 (file)
index 0000000..d211c99
--- /dev/null
+++ b/t/31-capture.t
@@ -0,0 +1,137 @@
+#!perl
+
+use strict;
+use warnings;
+
+use VPIT::TestHelpers 'capture';
+
+use Test::More tests => (4 + 4 * 2 + 2) * 4;
+
+my $long_length = 32 * 4096;
+
+sub hexdump {
+ my $s = $_[0];
+ $s =~ s/([^ a-zA-Z0-9_-])/sprintf '\x{%0*X}', (ord($1) <= 0xFF ? 2 : 4), ord $1/eg;
+ return $s;
+}
+
+my @tests = (
+ {
+  desc   => 'STDOUT only',
+  cmd    => [ $^X, '-e', 'print STDOUT qq[hello\n]' ],
+  expect => {
+   status => 0,
+   out    => "hello\n",
+   err    => '',
+  },
+ },
+ {
+  desc   => 'STDERR only',
+  cmd    => [ $^X, '-e', 'print STDERR qq[hi\n]' ],
+  expect => {
+   status => 0,
+   out    => '',
+   err    => "hi\n",
+  },
+ },
+ {
+  desc   => 'STDOUT+STDERR',
+  cmd    => [ $^X, '-e', 'print STDOUT qq[sup\n]; print STDERR qq[yo\n]' ],
+  expect => {
+   status => 0,
+   out    => "sup\n",
+   err    => "yo\n",
+  },
+ },
+ {
+  desc   => 'long',
+  cmd    => [ $^X, '-e', "sleep 1; print STDOUT q[a] x $long_length; sleep 1; print STDERR q[b] x $long_length; sleep 1; print STDOUT q[c] x $long_length" ],
+  expect => {
+   status => 0,
+   out    => ('a' x $long_length) . ('c' x $long_length),
+   err    => ('b' x $long_length),
+  },
+ },
+);
+
+for my $eol_spec (qw<0D 0A 0D0A 0A0D>) {
+ (my $eol = $eol_spec) =~ s/(..)/\\x{$1}/g;
+
+ my $eol_exp;
+ {
+  local $@;
+  $eol_exp = eval qq["$eol"];
+  die $@ if $@;
+ }
+ push @tests, {
+  desc   => "End of line $eol",
+  cmd    => [ $^X, '-e', "print STDOUT qq[out$eol]; print STDERR qq[err$eol]" ],
+  expect => {
+   status => 0,
+   out    => "out$eol_exp",
+   err    => "err$eol_exp",
+  },
+  hexcmp  => 1,
+ };
+
+ my $eol_bin_exp = ($^O eq 'MSWin32' && $eol_spec eq '0D0A')
+                   ? chr 0x0A : $eol_exp;
+ push @tests, {
+  desc   => "End of line $eol (binary mode)",
+  cmd    => [ $^X, '-e', "binmode *STDOUT; print STDOUT qq[out$eol]; binmode *STDERR; print STDERR qq[err$eol]" ],
+  expect => {
+   status => 0,
+   out    => "out$eol_bin_exp",
+   err    => "err$eol_bin_exp",
+  },
+  hexcmp  => 1,
+ };
+}
+
+push @tests, {
+ desc   => 'Non-existent',
+ cmd    => [ 'nonexistentexecutable' ],
+ expect => {
+  status => undef,
+  out    => qr/open3.*exec.*failed/,
+  err    => undef,
+ },
+};
+
+push @tests, {
+ desc   => 'Exception',
+ cmd    => [ $^X, '-e', 'die q[carrot]' ],
+ expect => {
+  status => 255 << 8,
+  out    => '',
+  err    => qr/carrot at -e/,
+ },
+};
+
+for my $test (@tests) {
+ my $desc     = $test->{desc};
+ my $expected = $test->{expect};
+
+ local $@;
+ my ($status, $out, $err) = eval { capture @{ $test->{cmd} } };
+
+ is $@,      '',                  "$desc: did not croak";
+ is $status, $expected->{status}, "$desc: status";
+
+ my ($exp_out, $exp_err) = @$expected{qw<out err>};
+ if ($test->{hexcmp}) {
+  $_       = hexdump($_)       for $out, $err;
+  $exp_out = hexdump($exp_out) unless ref $exp_out;
+  $exp_err = hexdump($exp_err) unless ref $exp_err;
+ }
+ if (ref $exp_out) {
+  like $out, $exp_out, "$desc: out";
+ } else {
+  is   $out, $exp_out, "$desc: out";
+ }
+ if (ref $exp_err) {
+  like $err, $exp_err, "$desc: err";
+ } else {
+  is   $err, $exp_err, "$desc: err";
+ }
+}