X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FLeaner.pm;h=2ada2039793d8fe96e4cf97a9bd6d61298491c6c;hb=d5f69b6cc4f2193b93768f4a984d854a9dc7f9d4;hp=6f90cef1ae4663704ee01802d81ea66c00693396;hpb=653bd706f7c17c61e34d98e6fcaed75861b2f7d7;p=perl%2Fmodules%2FTest-Leaner.git diff --git a/lib/Test/Leaner.pm b/lib/Test/Leaner.pm index 6f90cef..2ada203 100644 --- a/lib/Test/Leaner.pm +++ b/lib/Test/Leaner.pm @@ -10,11 +10,11 @@ Test::Leaner - A slimmer Test::More for when you favor performance over complete =head1 VERSION -Version 0.01 +Version 0.02 =cut -our $VERSION = '0.01'; +our $VERSION = '0.02'; =head1 SYNOPSIS @@ -37,16 +37,16 @@ Its functions behave the same as their L counterparts, except for th =item * Stringification isn't forced on the test operands. -However, L honors C<'bool'> overloading, L and L honor C<'eq'> overloading (and just that one) and L honors whichever overloading category corresponds to the specified operator. +However, L honors C<'bool'> overloading, L and L honor C<'eq'> overloading (and just that one), L honors C<'ne'> overloading, and L honors whichever overloading category corresponds to the specified operator. =item * -L, L, L, L, L, L, L and L are all guaranteed to return the truth value of the test. +L, L, L, L, L, L, L, L and L are all guaranteed to return the truth value of the test. =item * L and L don't special case regular expressions that are passed as C<'/.../'> strings. -A string regexp argument is always treated as a the source of the regexp, making C and C equivalent to each other and to C (and likewise for C). +A string regexp argument is always treated as the source of the regexp, making C and C equivalent to each other and to C (and likewise for C). =item * @@ -61,23 +61,23 @@ If the two first arguments present parallel memory cycles, the test may result i =item * The tests don't output any kind of default diagnostic in case of failure ; the rationale being that if you have a large number of tests and a lot of them are failing, then you don't want to be flooded by diagnostics. +Moreover, this allows a much faster variant of L. =item * C, C, C, C, C, C, C, C blocks and C are not implemented. -=item * - -L depends on L, while L does not. - =back =cut -use Exporter (); -use Scalar::Util (); +use Exporter (); + +my $main_process; BEGIN { + $main_process = $$; + if ($] >= 5.008 and $INC{'threads.pm'}) { my $use_ithreads = do { require Config; @@ -121,7 +121,7 @@ our @EXPORT = qw< =head2 C If this environment variable is set, L will replace its functions by those from L. -Moreover, the symbols that are imported you C will be those from L, but you can still only import the symbols originally defined in L (hence the functions from L that are not implemented in L will not be imported). +Moreover, the symbols that are imported when you C will be those from L, but you can still only import the symbols originally defined in L (hence the functions from L that are not implemented in L will not be imported). If your version of L is too old and doesn't have some symbols (like L or L), they will be replaced in L by croaking stubs. This may be useful if your L-based test script fails and you want extra diagnostics. @@ -180,6 +180,7 @@ if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { my $import = sub { shift; + my @imports = &_handle_import_args; @imports = @EXPORT unless @imports; my @test_more_imports; @@ -192,7 +193,10 @@ if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { *{$pkg."::$_"} = $leaner_stash->{$_}; } } + my $test_more_import = 'Test::More'->can('import'); + return unless $test_more_import; + @_ = ( 'Test::More', @_, @@ -202,6 +206,7 @@ if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { lock $plan if THREADSAFE; push @_, 'no_diag' if $no_diag; } + goto $test_more_import; }; @@ -582,6 +587,37 @@ See L. =cut +BEGIN { + local $@; + if (eval { require Scalar::Util; 1 }) { + *_reftype = \&Scalar::Util::reftype; + } else { + # Stolen from Scalar::Util::PP + require B; + my %tmap = qw< + B::NULL SCALAR + + B::HV HASH + B::AV ARRAY + B::CV CODE + B::IO IO + B::GV GLOB + B::REGEXP REGEXP + >; + *_reftype = sub ($) { + my $r = shift; + + return undef unless length ref $r; + + my $t = ref B::svref_2object($r); + + return exists $tmap{$t} ? $tmap{$t} + : length ref $$r ? 'REF' + : 'SCALAR' + } + } +} + sub _deep_ref_check { my ($x, $y, $ry) = @_; @@ -600,8 +636,8 @@ sub _deep_ref_check { next if not(ref $ex xor ref $ey) and $ex eq $ey; - $ry = Scalar::Util::reftype($ey); - return 0 if Scalar::Util::reftype($ex) ne $ry; + $ry = _reftype($ey); + return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } @@ -621,8 +657,8 @@ sub _deep_ref_check { next if not(ref $ex xor ref $ey) and $ex eq $ey; - $ry = Scalar::Util::reftype($ey); - return 0 if Scalar::Util::reftype($ex) ne $ry; + $ry = _reftype($ey); + return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } @@ -650,8 +686,8 @@ sub _deep_check { # Test::More::is_deeply happily breaks encapsulation if the objects aren't # overloaded. - my $ry = Scalar::Util::reftype($y); - return 0 if Scalar::Util::reftype($x) ne $ry; + my $ry = _reftype($y); + return 0 if _reftype($x) ne $ry; # Shortcut if $x and $y are both not references and failed the previous # $x eq $y test. @@ -733,7 +769,7 @@ sub BAIL_OUT { } END { - unless ($?) { + if ($main_process == $$ and not $?) { lock $plan if THREADSAFE; if (defined $plan) { @@ -813,7 +849,7 @@ In that case, it also needs a working L. L 5.6. -L, L, L. +L, L. =head1 AUTHOR