X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FVPIT%2FTestHelpers.pm;h=0f37b40b6e3026eda9cb99dfb747276a4080aa71;hb=f24eb57f90ecd534833e5b4237144240d4562290;hp=a6ca51908cc9f3398a125f93a7353844dbc6043c;hpb=274ec39542b4a7f51a3dd39cd3e9e5dd1ee88eb8;p=perl%2Fmodules%2FVPIT-TestHelpers.git diff --git a/lib/VPIT/TestHelpers.pm b/lib/VPIT/TestHelpers.pm index a6ca519..0f37b40 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,6 +29,20 @@ 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, @@ -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; @@ -166,17 +239,7 @@ sub fresh_perl_env (&) { } sub init_run_perl { - my $prefix = shift; - - if (defined $prefix) { - if (length $prefix and $prefix !~ /_$/) { - $prefix .= '_'; - } - } else { - $prefix = ''; - } - - my $p = $prefix; + my $p = sanitize_prefix(shift); return ( run_perl => \&run_perl, @@ -197,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', [ ]; @@ -208,8 +341,10 @@ sub init_capture { } return ( - capture => \&capture, - capture_perl => \&capture_perl, + capture => \&capture, + "${p}CAPTURE_FAILED" => \&capture_failed_msg, + capture_perl => \&capture_perl, + "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg, ); } @@ -350,6 +485,15 @@ 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; @@ -363,6 +507,85 @@ sub capture_perl { }; } +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) = @_; @@ -391,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; @@ -401,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; }; } @@ -409,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; @@ -431,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;