From: Vincent Pit Date: Thu, 9 Apr 2015 14:24:21 +0000 (-0300) Subject: Add capture feature X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVPIT-TestHelpers.git;a=commitdiff_plain;h=3b6eb95acf3764c1877a4309b0f9362323d71938 Add capture feature --- diff --git a/lib/VPIT/TestHelpers.pm b/lib/VPIT/TestHelpers.pm index b8623c5..9054314 100644 --- 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); + 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 ($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 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}; + 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"; + } +}