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
$file = "lib/$file.pm";
my %PREREQ_PM = (
- 'Exporter' => 0,
- 'Test::More' => 0,
+ 'Exporter' => 0,
+ 'Scalar::Util' => 0,
+ 'Test::More' => 0,
);
my %META = (
=item *
Stringification isn't forced on the test operands.
-However, L</ok> honors C<'bool'> overloading, L</is> honors C<'eq'> overloading and L</cmp_ok> honors whichever overloading category corresponds to the specified operator.
+However, L</ok> honors C<'bool'> overloading, L</is> and L</is_deeply> honor C<'eq'> overloading (and just that one) and L</cmp_ok> honors whichever overloading category corresponds to the specified operator.
=item *
C<use_ok>, C<require_ok>, C<can_ok>, C<isa_ok>, C<new_ok>, C<subtest>, C<explain>, C<TODO> blocks and C<todo_skip> are not implemented.
+=item *
+
+L<Test::Leaner> depends on L<Scalar::Util>, while L<Test::More> does not.
+
=back
=cut
-use Exporter ();
+use Exporter ();
+use Scalar::Util ();
BEGIN {
if ($] >= 5.008 and $INC{'threads.pm'}) {
ok
is
isnt
- cmp_ok
like
unlike
+ cmp_ok
+ is_deeply
diag
note
BAIL_OUT
=head2 C<like $got, $regexp_expected [, $desc ]>
+=cut
+
=head2 C<unlike $got, $regexp_expected, [, $desc ]>
=cut
goto $handler;
}
+=head2 C<is_deeply $got, $expected [, $desc ]>
+
+=cut
+
+sub _deep_check {
+ my ($x, $y) = @_;
+
+ no warnings qw<numeric uninitialized>;
+
+ 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;
L<perl> 5.6.
-L<Exporter>, L<Test::More>
+L<Exporter>, L<Scalar::Util>, L<Test::More>.
=head1 AUTHOR
BEGIN { *tm_is = \&Test::More::is }
-Test::More::plan(tests => 2 * 14);
+Test::More::plan(tests => 2 * 15);
require Test::Leaner;
ok
is
isnt
- cmp_ok
like
unlike
+ cmp_ok
+ is_deeply
diag
note
BAIL_OUT
--- /dev/null
+#!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];
+}
--- /dev/null
+#!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 def> ],
+ [ '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';
+ }
+}
projects / perl / modules / Test-Leaner.git / commitdiff