X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FTest-Leaner.git;a=blobdiff_plain;f=lib%2FTest%2FLeaner.pm;h=6f90cef1ae4663704ee01802d81ea66c00693396;hp=d79aef2c9a527bfa3f1e5a4d429bb700b4dc2e83;hb=653bd706f7c17c61e34d98e6fcaed75861b2f7d7;hpb=465440ff9c9519d5ce33d582cbf3fa4d03b4358a diff --git a/lib/Test/Leaner.pm b/lib/Test/Leaner.pm index d79aef2..6f90cef 100644 --- a/lib/Test/Leaner.pm +++ b/lib/Test/Leaner.pm @@ -45,11 +45,25 @@ L, L, L, L, L, L, L and 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). + +=item * + L throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants). It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator. =item * +L doesn't guard for memory cycles. +If the two first arguments present parallel memory cycles, the test may result in an infinite loop. + +=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. + +=item * + C, C, C, C, C, C, C, C blocks and C are not implemented. =item * @@ -84,6 +98,119 @@ my ($TAP_STREAM, $DIAG_STREAM); my ($plan, $test, $failed, $no_diag, $done_testing); +our @EXPORT = qw< + plan + skip + done_testing + pass + fail + ok + is + isnt + like + unlike + cmp_ok + is_deeply + diag + note + BAIL_OUT +>; + +=head1 ENVIRONMENT + +=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). +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. + +=cut + +sub _handle_import_args { + my @imports; + + my $i = 0; + while ($i <= $#_) { + my $item = $_[$i]; + my $splice; + if (defined $item) { + if ($item eq 'import') { + push @imports, @{ $_[$i+1] }; + $splice = 2; + } elsif ($item eq 'no_diag') { + lock $plan if THREADSAFE; + $no_diag = 1; + $splice = 1; + } + } + if ($splice) { + splice @_, $i, $splice; + } else { + ++$i; + } + } + + return @imports; +} + +if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { + require Test::More; + + my $leaner_stash = \%Test::Leaner::; + my $more_stash = \%Test::More::; + + my %valid_imports; + + for (@EXPORT) { + my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE} + : undef; + if (defined $replacement) { + $valid_imports{$_} = 1; + } else { + $replacement = sub { + @_ = ("$_ is not implemented in this version of Test::More"); + goto &croak; + }; + } + no warnings 'redefine'; + $leaner_stash->{$_} = $replacement; + } + + my $import = sub { + shift; + my @imports = &_handle_import_args; + @imports = @EXPORT unless @imports; + my @test_more_imports; + for (@imports) { + if ($valid_imports{$_}) { + push @test_more_imports, $_; + } else { + my $pkg = caller; + no strict 'refs'; + *{$pkg."::$_"} = $leaner_stash->{$_}; + } + } + my $test_more_import = 'Test::More'->can('import'); + @_ = ( + 'Test::More', + @_, + import => \@test_more_imports, + ); + { + lock $plan if THREADSAFE; + push @_, 'no_diag' if $no_diag; + } + goto $test_more_import; + }; + + no warnings 'redefine'; + *import = $import; + + return 1; +} + sub NO_PLAN () { -1 } sub SKIP_ALL () { -2 } @@ -101,13 +228,21 @@ BEGIN { sub carp { my $level = 1 + ($Test::Builder::Level || 0); - my ($file, $line) = (caller $level)[1, 2]; + my @caller; + do { + @caller = caller $level--; + } while (!@caller and $level >= 0); + my ($file, $line) = @caller[1, 2]; warn @_, " at $file line $line.\n"; } sub croak { my $level = 1 + ($Test::Builder::Level || 0); - my ($file, $line) = (caller $level)[1, 2]; + my @caller; + do { + @caller = caller $level--; + } while (!@caller and $level >= 0); + my ($file, $line) = @caller[1, 2]; die @_, " at $file line $line.\n"; } @@ -123,6 +258,8 @@ The following functions from L are implemented and exported by defau =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >> +See L. + =cut sub plan { @@ -168,48 +305,10 @@ sub plan { return 1; } -our @EXPORT = qw< - plan - skip - done_testing - pass - fail - ok - is - isnt - like - unlike - cmp_ok - is_deeply - diag - note - BAIL_OUT ->; - sub import { my $class = shift; - my @imports; - my $i = 0; - while ($i <= $#_) { - my $item = $_[$i]; - my $splice; - if (defined $item) { - if ($item eq 'import') { - push @imports, @{ $_[$i+1] }; - $splice = 2; - } elsif ($item eq 'no_diag') { - lock $plan if THREADSAFE; - $no_diag = 1; - $splice = 1; - } - } - if ($splice) { - splice @_, $i, $splice; - } else { - ++$i; - } - } + my @imports = &_handle_import_args; if (@_) { local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; @@ -222,6 +321,8 @@ sub import { =head2 C<< skip $reason => $count >> +See L. + =cut sub skip { @@ -257,6 +358,8 @@ sub skip { =head2 C +See L. + =cut sub done_testing { @@ -288,6 +391,8 @@ sub done_testing { =head2 C +See L. + =cut sub ok ($;$) { @@ -315,6 +420,8 @@ sub ok ($;$) { =head2 C +See L. + =cut sub pass (;$) { @@ -324,6 +431,8 @@ sub pass (;$) { =head2 C +See L. + =cut sub fail (;$) { @@ -333,6 +442,8 @@ sub fail (;$) { =head2 C +See L. + =cut sub is ($$;$) { @@ -347,6 +458,8 @@ sub is ($$;$) { =head2 C +See L. + =cut sub isnt ($$;$) { @@ -432,10 +545,12 @@ IS_BINOP =head2 C -=cut +See L. =head2 C +See L. + =cut { @@ -446,6 +561,8 @@ IS_BINOP =head2 C +See L. + =cut sub cmp_ok ($$$;$) { @@ -461,20 +578,75 @@ sub cmp_ok ($$$;$) { =head2 C +See L. + =cut +sub _deep_ref_check { + my ($x, $y, $ry) = @_; + + no warnings qw; + + if ($ry eq 'ARRAY') { + return 0 unless $#$x == $#$y; + + my ($ex, $ey); + for (0 .. $#$y) { + $ex = $x->[$_]; + $ey = $y->[$_]; + + # Inline the beginning of _deep_check + return 0 if defined $ex xor defined $ey; + + 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; + + return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); + } + + return 1; + } elsif ($ry eq 'HASH') { + return 0 unless keys(%$x) == keys(%$y); + + my ($ex, $ey); + for (keys %$y) { + return 0 unless exists $x->{$_}; + $ex = $x->{$_}; + $ey = $y->{$_}; + + # Inline the beginning of _deep_check + return 0 if defined $ex xor defined $ey; + + 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; + + return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); + } + + return 1; + } elsif ($ry eq 'SCALAR' or $ry eq 'REF') { + return _deep_check($$x, $$y); + } + + return 0; +} + sub _deep_check { my ($x, $y) = @_; no warnings qw; - return 0 if defined($x) xor defined($y); + return 0 if defined $x xor defined $y; # Try object identity/eq overloading first. It also covers the case where # $x and $y are both undefined. # If either $x or $y is overloaded but none has eq overloading, the test will # break at that point. - return 1 if not(ref($x) xor ref($y)) and $x eq $y; + return 1 if not(ref $x xor ref $y) and $x eq $y; # Test::More::is_deeply happily breaks encapsulation if the objects aren't # overloaded. @@ -485,23 +657,9 @@ sub _deep_check { # $x eq $y test. return 0 unless $ry; - if ($ry eq 'ARRAY') { - if ($#$x == $#$y) { - _deep_check($x->[$_], $y->[$_]) or return 0 for 0 .. $#$y; - return 1; - } - } elsif ($ry eq 'HASH') { - if (keys(%$x) == keys(%$y)) { - (exists $x->{$_} and _deep_check($x->{$_}, $y->{$_})) - or return 0 for keys %$y; - return 1; - } - } elsif ($ry eq 'SCALAR' or $ry eq 'REF') { - return _deep_check($$x, $$y); - } - - return 0; -}; + # We know that $x and $y are both references of type $ry, without overloading. + _deep_ref_check($x, $y, $ry); +} sub is_deeply { @_ = ( @@ -531,6 +689,8 @@ sub _diag_fh { =head2 C +See L. + =cut sub diag { @@ -540,6 +700,8 @@ sub diag { =head2 C +See L. + =cut sub note { @@ -549,6 +711,8 @@ sub note { =head2 C +See L. + =cut sub BAIL_OUT { @@ -577,7 +741,8 @@ END { $? = $failed <= 254 ? $failed : 254; } elsif ($plan >= 0) { $? = $test == $plan ? 0 : 255; - } elsif ($plan == NO_PLAN) { + } + if ($plan == NO_PLAN) { local $\; print $TAP_STREAM "1..$test\n"; }