X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FVPIT%2FTestHelpers.pm;h=e8cfa710ea73aec55801f5f9fcdd03548cb8a3e8;hb=3edc6d15d41c3ff378ba461d7c218bc9a5c851f0;hp=7dfd15eb63f108f9001d8f906fba2d53a92b9056;hpb=0bcc011a0cf1879908fd93fdfeb3a31d66657424;p=perl%2Fmodules%2FVPIT-TestHelpers.git diff --git a/lib/VPIT/TestHelpers.pm b/lib/VPIT/TestHelpers.pm index 7dfd15e..e8cfa71 100644 --- a/lib/VPIT/TestHelpers.pm +++ b/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,17 +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, - capture => \&init_capture, + threads => \&init_threads, + usleep => \&init_usleep, + run_perl => \&init_run_perl, + capture => \&init_capture, ); sub import { @@ -142,6 +169,52 @@ sub load_or_skip_all { return $loaded; } +=head1 FEATURES + +=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; @@ -165,6 +238,15 @@ sub fresh_perl_env (&) { 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; @@ -178,7 +260,77 @@ sub run_perl { }; } +=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', [ ]; @@ -188,7 +340,12 @@ sub init_capture { load_or_skip_all 'Socket', '0', [ ]; } - return capture => \&capture; + 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 @@ -319,6 +476,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 { @@ -328,34 +494,197 @@ sub capture { } } +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, $threadsafe_var, $force_var + ]; + +where : + +=over 8 + +=item - + +C<$pkg> is the target package name that will be exercised by this test ; + +=item - + +C<$threadsafe_var> is the name of an optional variable in C<$pkg> that evaluates to true if and only if the module claims to be thread safe (not checked if either C<$threadsafe_var> or C<$pkg> is 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 + +=item - + +L 1.67 + +=item - + +L 1.14 + +=back + +=item * + +Exports : + +=over 8 + +=item - + +C + +=back + +=back + +=cut + sub init_threads { - my ($pkg, $threadsafe, $force_var) = @_; + my ($pkg, $threadsafe_var, $force_var) = @_; skip_all 'This perl wasn\'t built to support threads' unless $Config::Config{useithreads}; - $pkg = 'package' unless defined $pkg; - skip_all "This $pkg isn't thread safe" if defined $threadsafe and !$threadsafe; + if (defined $pkg and defined $threadsafe_var) { + my $threadsafe; + my $stat = run_perl("require POSIX; require $pkg; exit($threadsafe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"); + if (defined $stat) { + require POSIX; + my $res = $stat >> 8; + if ($res == POSIX::EXIT_SUCCESS()) { + $threadsafe = 1; + } elsif ($res == POSIX::EXIT_FAILURE()) { + $threadsafe = !1; + } + } + if (not defined $threadsafe) { + skip_all "Could not detect if $pkg is thread safe or not"; + } elsif (not $threadsafe) { + skip_all "This $pkg is not thread safe"; + } + } $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var; my $force = $ENV{$force_var} ? 1 : !1; 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::shared', $force ? '0' : '1.14', [ ]; - require Test::Leaner; - diag "Threads testing forced by \$ENV{$force_var}" if $force; 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; @@ -366,7 +695,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; }; } @@ -374,17 +703,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; @@ -396,4 +726,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;