From: Vincent Pit Date: Thu, 9 Apr 2015 16:57:47 +0000 (-0300) Subject: Update VPIT::TestHelpers to f24eb57f X-Git-Tag: v0.57~10 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=34c317825d931337c0d5cdc6b365ca9a16906310;p=perl%2Fmodules%2FVariable-Magic.git Update VPIT::TestHelpers to f24eb57f And port t/17-ctl.t to the new 'capture' feature. Capture::Tiny is no longer needed for the optional external tests. --- diff --git a/t/09-load-threads.t b/t/09-load-threads.t index 557258b..91092b0 100644 --- a/t/09-load-threads.t +++ b/t/09-load-threads.t @@ -4,7 +4,7 @@ use strict; use warnings; use lib 't/lib'; -use VPIT::TestHelpers; +use VPIT::TestHelpers 'run_perl'; my ($module, $thread_safe_var); BEGIN { diff --git a/t/17-ctl.t b/t/17-ctl.t index c9dd4ca..8834540 100644 --- a/t/17-ctl.t +++ b/t/17-ctl.t @@ -6,7 +6,7 @@ use warnings; use Test::More tests => 4 * 8 + 4 * (2 * 6 + 1) + 10 + 1 + 1; use lib 't/lib'; -use VPIT::TestHelpers; +use VPIT::TestHelpers 'capture'; use Variable::Magic qw; @@ -345,41 +345,15 @@ eval q{BEGIN { like $@, expect('tomato', undef, "\nBEGIN.*"), 'die in BEGIN in eval triggers hints hash destructor'; -my $has_capture_tiny = do { - local $@; - eval { - require Capture::Tiny; - Capture::Tiny->VERSION('0.08'); - } -}; -if ($has_capture_tiny) { - local $@; - my $output = eval { - Capture::Tiny::capture_merged(sub { run_perl <<' CODE' }); -print STDOUT "pants\n"; -print STDERR "trousers\n"; - CODE - }; - unless (defined $output and $output =~ /pants/ and $output =~ /trousers/) { - $has_capture_tiny = 0; - } -} -if ($has_capture_tiny) { - defined and diag "Using Capture::Tiny $_" for $Capture::Tiny::VERSION; -} - -SKIP: -{ +SKIP: { my $count = 1; - skip 'No working Capture::Tiny is installed'=> $count unless $has_capture_tiny; - - my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' }); + my ($stat, $out, $err) = capture_perl <<' CODE'; use Variable::Magic qw; { BEGIN { $^H |= 0x020000; cast %^H, wizard free => sub { die q[cucumber] } } } CODE - skip 'Test code didn\'t run properly' => $count unless defined $output; - like $output, expect('cucumber', '-e', "\nExecution(?s:.*)"), - 'die in free callback at compile time and not in eval string'; + skip CAPTURE_PERL_FAILED($out) => $count unless defined $stat; + like $err, expect('cucumber', '-e', "\nExecution(?s:.*)"), + 'die in free callback at compile time and not in eval string'; --$count; } @@ -389,14 +363,13 @@ SKIP: { my $count = 1; - skip 'No nice uvar magic for this perl' => $count unless VMG_UVAR; - skip 'No working Capture::Tiny is installed'=> $count unless $has_capture_tiny; + skip 'No nice uvar magic for this perl' => $count unless VMG_UVAR; - my $output = Capture::Tiny::capture_merged(sub { run_perl <<' CODE' }); + my ($stat, $out, $err) = capture_perl <<' CODE'; use Variable::Magic qw; BEGIN { cast %derp::, wizard fetch => sub { die q[raddish] } } derp::hlagh() CODE - skip 'Test code didn\'t run properly' => $count unless defined $output; - like $output, expect('raddish', '-e', "\nExecution(?s:.*)"), - 'die in free callback at compile time and not in eval string'; + skip CAPTURE_PERL_FAILED($out) => $count unless defined $stat; + like $err, expect('raddish', '-e', "\nExecution(?s:.*)"), + 'die in free callback at compile time and not in eval string'; --$count; } diff --git a/t/lib/VPIT/TestHelpers.pm b/t/lib/VPIT/TestHelpers.pm index b8623c5..0f37b40 100644 --- a/t/lib/VPIT/TestHelpers.pm +++ b/t/lib/VPIT/TestHelpers.pm @@ -5,6 +5,19 @@ use warnings; use Config (); +=head1 NAME + +VPIT::TestHelpers + +=head1 SYNTAX + + use VPIT::TestHelpers ( + feature1 => \@feature1_args, + feature2 => \@feature2_args, + ); + +=cut + sub export_to_pkg { my ($subs, $pkg) = @_; @@ -16,16 +29,31 @@ 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, - run_perl => \&run_perl, skip_all => \&skip_all, ); my %features = ( - threads => \&init_threads, - usleep => \&init_usleep, + threads => \&init_threads, + usleep => \&init_usleep, + run_perl => \&init_run_perl, + capture => \&init_capture, ); sub import { @@ -141,12 +169,54 @@ sub load_or_skip_all { return $loaded; } -sub run_perl { - my $code = shift; +=head1 FEATURES - if ($code =~ /"/) { - die 'Double quotes in evaluated code are not portable'; - } +=head2 C + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers run_perl => [ $p ] + +where : + +=over 8 + +=item - + +C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). + +=back + +=item * + +Dependencies : none + +=item * + +Exports : + +=over 8 + +=item - + +C + +=item - + +C (possibly prefixed by C<$p>) + +=back + +=back + +=cut + +sub fresh_perl_env (&) { + my $handler = shift; my ($SystemRoot, $PATH) = @ENV{qw}; my $ld_name = $Config::Config{ldlibpthname}; @@ -165,9 +235,357 @@ sub run_perl { } } - system { $perl } $perl, '-T', map("-I$_", @INC), '-e', $code; + return $handler->($perl, '-T', map("-I$_", @INC)); +} + +sub init_run_perl { + my $p = sanitize_prefix(shift); + + return ( + run_perl => \&run_perl, + "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' }, + ); +} + +sub run_perl { + my $code = shift; + + if ($code =~ /"/) { + die 'Double quotes in evaluated code are not portable'; + } + + fresh_perl_env { + my ($perl, @perl_args) = @_; + system { $perl } $perl, @perl_args, '-e', $code; + }; } +=head2 C + +=over 4 + +=item * + +Import : + + 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 * + +Dependencies : + +=over 8 + +=item - + +Not VMS + +=item - + +L, L, L + +=item - + +On MSWin32 : L + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C + +=item - + +C (possibly prefixed by C<$p>) + +=item - + +C + +=item - + +C (possibly prefixed by C<$p>) + +=back + +=back + +=cut + +sub init_capture { + my $p = sanitize_prefix(shift); + + 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, + "${p}CAPTURE_FAILED" => \&capture_failed_msg, + capture_perl => \&capture_perl, + "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg, + ); +} + +# 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 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; + + if ($code =~ /"/) { + die 'Double quotes in evaluated code are not portable'; + } + + fresh_perl_env { + my @perl = @_; + capture @perl, '-e', $code; + }; +} + +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 + +=item * + +Import : + + use VPIT::TestHelpers threads => [ + $pkg, $is_threadsafe, $force_var + ]; + +where : + +=over 8 + +=item - + +C<$pkg> is the target package name to be used in error messages (defaults to C<'package'>) ; + +=item - + +C<$is_threadsafe> is a boolean telling whether the target module is thread-safe (not tested if C) ; + +=item - + +C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C). + +=back + +=item * + +Dependencies : + +=over 8 + +=item - + +C 5.13.4 + +=item - + +L 1.67 + +=item - + +L 1.14 + +=item - + +L + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C + +=back + +=back + +=cut + sub init_threads { my ($pkg, $threadsafe, $force_var) = @_; @@ -196,6 +614,48 @@ sub init_threads { return spawn => \&spawn; } +sub spawn { + local $@; + my @diag; + my $thread = eval { + local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; + threads->create(@_); + }; + push @diag, "Thread creation error: $@" if $@; + diag @diag; + return $thread ? $thread : (); +} + +=head2 C + +=over 4 + +=item * + +Import : + + use VPIT::TestHelpers 'usleep' + +=item * + +Dependencies : none + +=item * + +Exports : + +=over 8 + +=item - + +C + +=back + +=back + +=cut + sub init_usleep { my $usleep; @@ -206,7 +666,7 @@ sub init_usleep { } else { diag 'Using fallback usleep()'; $usleep = sub { - my $s = int($_[0] / 2.5e5); + my $s = int($_[0] / 1e6); sleep $s if $s; }; } @@ -214,17 +674,18 @@ sub init_usleep { return usleep => $usleep; } -sub spawn { - local $@; - my @diag; - my $thread = eval { - local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; - threads->create(@_); - }; - push @diag, "Thread creation error: $@" if $@; - diag @diag; - return $thread ? $thread : (); -} +=head1 CLASSES + +=head2 C + +Syntax : + + { + my $guard = VPIT::TestHelpers::Guard->new($coderef); + ... + } # $codref called here + +=cut package VPIT::TestHelpers::Guard; @@ -236,4 +697,16 @@ sub new { sub DESTROY { $_[0]->{code}->() } +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +=head1 COPYRIGHT & LICENSE + +Copyright 2012,2013,2014,2015 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + 1;