From: Vincent Pit Date: Tue, 28 Dec 2010 14:31:22 +0000 (+0100) Subject: Implement and test is_deeply() X-Git-Tag: v0.01~3 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=465440ff9c9519d5ce33d582cbf3fa4d03b4358a;p=perl%2Fmodules%2FTest-Leaner.git Implement and test is_deeply() --- diff --git a/MANIFEST b/MANIFEST index bcb88fd..0dbf27c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -24,6 +24,8 @@ t/20-ok.t t/21-ok-failing.t t/22-is.t t/24-cmp_ok.t +t/26-is_deeply.t +t/27-is_deeply-failing.t t/91-pod.t t/92-pod-coverage.t t/95-portability-files.t diff --git a/Makefile.PL b/Makefile.PL index 63bd771..6fcb76c 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -12,8 +12,9 @@ my $dist = 'Test-Leaner'; $file = "lib/$file.pm"; my %PREREQ_PM = ( - 'Exporter' => 0, - 'Test::More' => 0, + 'Exporter' => 0, + 'Scalar::Util' => 0, + 'Test::More' => 0, ); my %META = ( diff --git a/lib/Test/Leaner.pm b/lib/Test/Leaner.pm index 7fe001a..d79aef2 100644 --- a/lib/Test/Leaner.pm +++ b/lib/Test/Leaner.pm @@ -37,7 +37,7 @@ 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 honors C<'eq'> overloading 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) and L honors whichever overloading category corresponds to the specified operator. =item * @@ -52,11 +52,16 @@ It also tests in scalar context, so C<'..'> will be treated as the flip-flop ope 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 Exporter (); +use Scalar::Util (); BEGIN { if ($] >= 5.008 and $INC{'threads.pm'}) { @@ -172,9 +177,10 @@ our @EXPORT = qw< ok is isnt - cmp_ok like unlike + cmp_ok + is_deeply diag note BAIL_OUT @@ -426,6 +432,8 @@ IS_BINOP =head2 C +=cut + =head2 C =cut @@ -451,6 +459,58 @@ sub cmp_ok ($$$;$) { goto $handler; } +=head2 C + +=cut + +sub _deep_check { + my ($x, $y) = @_; + + no warnings qw; + + 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; + + # 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; + + # Shortcut if $x and $y are both not references and failed the previous + # $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; +}; + +sub is_deeply { + @_ = ( + &_deep_check, + $_[2], + ); + goto &ok; +} + sub _diag_fh { my $fh = shift; @@ -588,7 +648,7 @@ In that case, it also needs a working L. L 5.6. -L, L +L, L, L. =head1 AUTHOR diff --git a/t/01-import.t b/t/01-import.t index 55f581d..3b42068 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -7,7 +7,7 @@ use Test::More (); BEGIN { *tm_is = \&Test::More::is } -Test::More::plan(tests => 2 * 14); +Test::More::plan(tests => 2 * 15); require Test::Leaner; @@ -20,9 +20,10 @@ my @syms = qw< ok is isnt - cmp_ok like unlike + cmp_ok + is_deeply diag note BAIL_OUT diff --git a/t/26-is_deeply.t b/t/26-is_deeply.t new file mode 100644 index 0000000..0d6b84c --- /dev/null +++ b/t/26-is_deeply.t @@ -0,0 +1,102 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner tests => 21 + 2 + 1; + +my $lacunary = [ [ 1, 2, 3 ] => [ 1, 2, 3 ] ]; +delete $lacunary->[0]->[1]; +$lacunary->[1]->[1] = undef; + +my $scalar_ref = \1; +my $array_ref = [ ]; +my $hash_ref = { }; +my $code_ref = sub { }; + +my @tests = ( + [ undef, undef ], + + [ 1 => 1 ], + [ 'a' => 'a' ], + + [ \1 => \1 ], + [ \'a' => \'a' ], + [ \(\1) => \(\1) ], + [ \(\'a') => \(\'a') ], + + [ [ 1 ] => [ 1 ] ], + [ [ 'a' ] => [ 'a' ] ], + [ [ \1 ] => [ \1 ] ], + + [ [ 1, 2, 3 ] => [ 1, 2, 3 ] ], + [ [ 1, undef, 3 ] => [ 1, undef, 3 ] ], + $lacunary, + + [ { a => 1 } => { a => 1 } ], + [ { a => undef } => { a => undef } ], + [ { a => \1 } => { a => \1 } ], + + [ { a => [ 1, undef, 2 ], b => \3 } => { a => [ 1, undef, 2 ], b => \3 } ], + + [ $scalar_ref => $scalar_ref ], + [ $array_ref => $array_ref ], + [ $hash_ref => $hash_ref ], + [ $code_ref => $code_ref ], +); + +# Test breaking encapsulation + +{ + package Test::Leaner::TestIsDeeplyObject; + + sub new { + my $class = shift; + + bless { @_ }, $class; + } +} + +{ + package Test::Leaner::TestIsDeeplyObject2; + + sub new { + my $class = shift; + + bless { @_ }, $class; + } +} + +push @tests, ( + [ map Test::Leaner::TestIsDeeplyObject->new( + a => [ 1, { b => 2, c => undef }, undef, \3 ], + c => { d => \(\4), e => [ 5, undef ] }, + ), 1 .. 2 ], + [ + Test::Leaner::TestIsDeeplyObject->new(a => 1), + Test::Leaner::TestIsDeeplyObject2->new(a => 1), + ], +); + +{ + package Test::Leaner::TestIsDeeplyOverload; + + use overload 'eq' => sub { + my ($x, $y, $r) = @_; + + $x = $x->{str}; + $y = $y->{str} if ref $y; + + ($x, $y) = ($y, $x) if $r; + + return $x eq $y; + }; + + sub new { bless { str => $_[1] }, $_[0] } +} + +push @tests, [ map Test::Leaner::TestIsDeeplyOverload->new('foo'), 1 .. 2 ]; + +for my $t (@tests) { + is_deeply $t->[0], $t->[1]; +} diff --git a/t/27-is_deeply-failing.t b/t/27-is_deeply-failing.t new file mode 100644 index 0000000..b1b3d2f --- /dev/null +++ b/t/27-is_deeply-failing.t @@ -0,0 +1,121 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +use Test::Leaner (); + +use lib 't/lib'; +use Test::Leaner::TestHelper; + +my $buf; +capture_to_buffer $buf + or plan skip_all =>'perl 5.8 required to test is_deeply() failing'; + +plan tests => 3 * 2 * (30 + 1 + 2); + +my $shrunk = [ [ 1, 2, 3 ] => [ 1, 2, 3 ] ]; +delete $shrunk->[0]->[2]; +$shrunk->[1]->[2] = undef; + +my $scalar_ref = \1; +my $array_ref = [ ]; +my $hash_ref = { }; +my $code_ref = sub { }; + +my @tests = ( + [ undef, '' ], + [ undef, 0 ], + + [ 1 => 2 ], + [ 1 => '1.0' ], + [ 1 => '1e0' ], + [ 'a' => 'A' ], + [ 'a' => 'a ' ], + + [ \1 => \2 ], + [ \(\1) => \(\2) ], + + [ [ undef ] => [ ] ], + [ [ undef ] => [ 0 ] ], + [ [ undef ] => [ '' ] ], + [ [ 0 ] => [ ] ], + [ [ 0 ] => [ '' ] ], + [ [ '' ] => [ ] ], + + [ [ 1, undef, 3 ] => [ 1, 2, 3 ] ], + [ [ 1, 2, undef ] => [ 1, 2 ] ], + $shrunk, + + [ { a => undef } => { } ], + [ { a => undef } => { a => 0 } ], + [ { a => undef } => { a => '' } ], + [ { a => 0 } => { } ], + [ { a => 0 } => { a => '' } ], + [ { a => '' } => { } ], + + [ { a => 1 } => { 'A' => 1 } ], + + [ [ { a => 1 }, 2, { b => \3 } ] => [ { a => 1 }, 2, { b => \'3.0' } ] ], + + [ $scalar_ref => "$scalar_ref" ], + [ $array_ref => "$array_ref" ], + [ $hash_ref => "$hash_ref" ], + [ $code_ref => "$code_ref" ], +); + +{ + package Test::Leaner::TestIsDeeplyObject; + + sub new { + my $class = shift; + + bless { @_ }, $class; + } +} + +push @tests, [ + Test::Leaner::TestIsDeeplyObject->new(a => 1), + Test::Leaner::TestIsDeeplyObject->new(a => 2), +]; + +{ + package Test::Leaner::TestIsDeeplyOverload; + + use overload 'eq' => sub { + my ($x, $y, $r) = @_; + + $x = $x->{str}; + $y = $y->{str} if ref $y; + + ($x, $y) = ($y, $x) if $r; + + return $x eq $y; + }; + + sub new { bless { str => $_[1] }, $_[0] } +} + +push @tests, ( + [ map Test::Leaner::TestIsDeeplyOverload->new($_), qw ], + [ 'abc' => Test::Leaner::TestIsDeeplyOverload->new('abc') ], +); + +my $count = 0; + +@tests = map { + $_, [ $_->[1], $_->[0] ] +} @tests; + +for my $t (@tests) { + reset_buffer { + local $@; + my $ret = eval { Test::Leaner::is_deeply($t->[0], $t->[1]) }; + ++$count if $@ eq ''; + is $@, '', 'is_deeply(...) does not croak'; + ok !$ret, 'is_deeply(...) returns false'; + is $buf, "not ok $count\n", 'is_deeply(...) produces the correct TAP code'; + } +}