File Coverage

inc/Test/Deep.pm

Criterion	Covered	Total	%
statement	76	171	44.4
branch	22	78	28.2
condition	15	38	39.4
subroutine	15	34	44.1
pod	17	25	68.0
total	145	346	41.9

#line 1
use strict;
use warnings;

package Test::Deep;
use Carp qw( confess );

use Test::Deep::Cache;
use Test::Deep::Stack;
use Test::Deep::RegexpVersion;

require overload;
use Scalar::Util;

my $Test;
unless (defined $Test::Deep::NoTest::NoTest)
{
# for people who want eq_deeply but not Test::Builder
	require Test::Builder;
	$Test = Test::Builder->new;
}

our ($Stack, %Compared, $CompareCache, %WrapCache, $Shallow);

our $VERSION = '0.110';
$VERSION = eval $VERSION;

require Exporter;
our @ISA = qw( Exporter );

our $Snobby = 1; # should we compare classes?
our $Expects = 0; # are we comparing got vs expect or expect vs expect

our $DNE = \"";
our $DNE_ADDR = Scalar::Util::refaddr($DNE);

# if no sub name is supplied then we use the package name in lower case
my %constructors = (
  All               => "",
  Any               => "",
  Array             => "",
  ArrayEach         => "array_each",
  ArrayElementsOnly => "",
  ArrayLength       => "",
  ArrayLengthOnly   => "",
  Blessed           => "",
  Boolean           => "bool",
  Code              => "",
  Hash              => "",
  HashEach          => "hash_each",
  HashKeys          => "",
  HashKeysOnly      => "",
  Ignore            => "",
  Isa               => "Isa",
  ListMethods       => "",
  Methods           => "",
  Number            => "num",
  RefType           => "",
  Regexp            => "re",
  RegexpMatches     => "",
  RegexpOnly        => "",
  RegexpRef         => "",
  RegexpRefOnly     => "",
  ScalarRef         => "scalref",
  ScalarRefOnly     => "",
  Shallow           => "",
  String            => "str",
);

our @CONSTRUCTORS_FROM_CLASSES;

while (my ($pkg, $name) = each %constructors)
{
	$name = lc($pkg) unless $name;
	my $full_pkg = "Test::Deep::$pkg";
	my $file = "$full_pkg.pm";
	$file =~ s#::#/#g;
	my $sub = sub {
		require $file;
		return $full_pkg->new(@_);
	};
	{
		no strict 'refs';
		*{$name} = $sub;
	}

  push @CONSTRUCTORS_FROM_CLASSES, $name;
}

{
  our @EXPORT_OK = qw( descend render_stack class_base cmp_details deep_diag );

  our %EXPORT_TAGS;
  $EXPORT_TAGS{v0} = [
    qw(
      Isa

      all any array array_each arrayelementsonly arraylength arraylengthonly
      bag blessed bool cmp_bag cmp_deeply cmp_methods cmp_set code eq_deeply
      hash hash_each hashkeys hashkeysonly ignore isa listmethods methods
      noclass num re reftype regexpmatches regexponly regexpref regexprefonly
      scalarrefonly scalref set shallow str subbagof subhashof subsetof
      superbagof superhashof supersetof useclass
    )
  ];

  our @EXPORT = @{ $EXPORT_TAGS{ v0 } };

  $EXPORT_TAGS{all} = [ @EXPORT, @EXPORT_OK ];
}

# this is ugly, I should never have exported a sub called isa now I
# have to try figure out if the recipient wanted my isa or if a class
# imported us and UNIVERSAL::isa is being called on that class.
# Luckily our isa always expects 1 argument and U::isa always expects
# 2, so we can figure out (assuming the caller is not buggy).
sub isa
{
	if (@_ == 1)
	{
		goto &Isa;
	}
	else
	{
		goto &UNIVERSAL::isa;
	}
}

sub cmp_deeply
{
	my ($d1, $d2, $name) = @_;

	my ($ok, $stack) = cmp_details($d1, $d2);

	if (not $Test->ok($ok, $name))
	{
		my $diag = deep_diag($stack);
		$Test->diag($diag);
	}

	return $ok;
}

sub cmp_details
{
	my ($d1, $d2) = @_;

	local $Stack = Test::Deep::Stack->new;
	local $CompareCache = Test::Deep::Cache->new;
	local %WrapCache;

	my $ok = descend($d1, $d2);

	return ($ok, $Stack);
}

sub eq_deeply
{
	my ($d1, $d2) = @_;

	my ($ok) = cmp_details($d1, $d2);

	return $ok
}

sub eq_deeply_cache
{
	# this is like cross between eq_deeply and descend(). It doesn't start
	# with a new $CompareCache but if the comparison fails it will leave
	# $CompareCache as if nothing happened. However, if the comparison
	# succeeds then $CompareCache retains all the new information

	# this allows Set and Bag to handle circular refs

	my ($d1, $d2, $name) = @_;

	local $Stack = Test::Deep::Stack->new;
	$CompareCache->local;

	my $ok = descend($d1, $d2);

	$CompareCache->finish($ok);

	return $ok;
}

sub deep_diag
{
	my $stack = shift;
	# ick! incArrow and other things expect the stack has to be visible
	# in a well known place . TODO clean this up
	local $Stack = $stack;

	my $where = render_stack('$data', $stack);

	confess "No stack to diagnose" unless $stack;
	my $last = $stack->getLast;

	my $diag;
	my $message;
	my $got;
	my $expected;

	my $exp = $last->{exp};
	if (Scalar::Util::blessed($exp))
	{
		if ($exp->can("diagnostics"))
		{
			$diag = $exp->diagnostics($where, $last);
			$diag =~ s/\n+$/\n/;
		}
		else
		{
			if ($exp->can("diag_message"))
			{
				$message = $exp->diag_message($where);
			}
		}
	}

	if (not defined $diag)
	{
		$got = $exp->renderGot($last->{got}) unless defined $got;
		$expected = $exp->renderExp unless defined $expected;
		$message = "Compared $where" unless defined $message;

		$diag = <<EOM
$message
   got : $got
expect : $expected
EOM
	}

	return $diag;
}

sub render_val
{
	my $val = shift;

	my $rendered;
	if (defined $val)
	{
	 	$rendered = ref($val) ?
	 		(Scalar::Util::refaddr($val) eq $DNE_ADDR ?
	 			"Does not exist" :
				overload::StrVal($val)
			) :
			qq('$val');
	}
	else
	{
		$rendered = "undef";
	}

	return $rendered;
}

sub descend
{
	my ($d1, $d2) = @_;

	if (!ref $d1 and !ref $d2)
	{
    # Shortcut comparison for the non-reference case.
    if (defined $d1)
    {
      return 1 if defined $d2 and $d1 eq $d2;
    }
    else
    {
      return 1 if !defined $d2;
    }
	}

	if (! $Expects and Scalar::Util::blessed($d1) and $d1->isa("Test::Deep::Cmp"))
	{
		my $where = $Stack->render('$data');
		confess "Found a special comparison in $where\nYou can only the specials in the expects structure";
	}

	if (ref $d1 and ref $d2)
	{
		# this check is only done when we're comparing 2 expecteds against each
		# other

		if ($Expects and Scalar::Util::blessed($d1) and $d1->isa("Test::Deep::Cmp"))
		{
			# check they are the same class
			return 0 unless Test::Deep::blessed(Scalar::Util::blessed($d2))->descend($d1);
			if ($d1->can("compare"))
			{
				return $d1->compare($d2);
			}
		}

		my $s1 = Scalar::Util::refaddr($d1);
		my $s2 = Scalar::Util::refaddr($d2);

		if ($s1 eq $s2)
		{
			return 1;
		}
		if ($CompareCache->cmp($d1, $d2))
		{
			# we've tried comparing these already so either they turned out to
			# be the same or we must be in a loop and we have to assume they're
			# the same

			return 1;
		}
		else
		{
			$CompareCache->add($d1, $d2)
		}
	}

	$d2 = wrap($d2);

	$Stack->push({exp => $d2, got => $d1});

	if (ref($d1) and (Scalar::Util::refaddr($d1) == $DNE_ADDR))
	{
		# whatever it was suposed to be, it didn't exist and so it's an
		# automatic fail
		return 0;
	}

	if ($d2->descend($d1))
	{
#		print "d1 = $d1, d2 = $d2\nok\n";
		$Stack->pop;

		return 1;
	}
	else
	{
#		print "d1 = $d1, d2 = $d2\nnot ok\n";
		return 0;
	}
}

sub wrap
{
	my $data = shift;

	return $data if Scalar::Util::blessed($data) and $data->isa("Test::Deep::Cmp");

	my ($class, $base) = class_base($data);

	my $cmp;

	if($base eq '')
	{
		$cmp = shallow($data);
	}
	else
	{
		my $addr = Scalar::Util::refaddr($data);

		return $WrapCache{$addr} if $WrapCache{$addr};

		if($base eq 'ARRAY')
		{
			$cmp = array($data);
		}
		elsif($base eq 'HASH')
		{
			$cmp = hash($data);
		}
		elsif($base eq 'SCALAR' or $base eq 'REF')
		{
			$cmp = scalref($data);
		}
		elsif(($base eq 'Regexp') or ($base eq 'REGEXP'))
		{
			$cmp = regexpref($data);
		}
		else
		{
			$cmp = shallow($data);
		}

		$WrapCache{$addr} = $cmp;
	}
	return $cmp;
}

sub class_base
{
	my $val = shift;

	if (ref $val)
	{
		my $blessed = Scalar::Util::blessed($val);
		$blessed = defined($blessed) ? $blessed : "";
		my $reftype = Scalar::Util::reftype($val);


		if ($Test::Deep::RegexpVersion::OldStyle) {
			if ($blessed eq "Regexp" and $reftype eq "SCALAR")
			{
				$reftype = "Regexp"
			}
		}
		return ($blessed, $reftype);
	}
	else
	{
		return ("", "");
	}
}

sub render_stack
{
	my ($var, $stack) = @_;

	return $stack->render($var);
}

sub cmp_methods
{
	local $Test::Builder::Level = $Test::Builder::Level + 1;
	return cmp_deeply(shift, methods(@{shift()}), shift);
}

sub requireclass
{
	require Test::Deep::Class;

	my $val = shift;

	return Test::Deep::Class->new(1, $val);
}

# docs and export say this is call useclass, doh!

*useclass = \&requireclass;

sub noclass
{
	require Test::Deep::Class;

	my $val = shift;

	return Test::Deep::Class->new(0, $val);
}

sub set
{
	require Test::Deep::Set;

	return Test::Deep::Set->new(1, "", @_);
}

sub supersetof
{
	require Test::Deep::Set;

	return Test::Deep::Set->new(1, "sup", @_);
}

sub subsetof
{
	require Test::Deep::Set;

	return Test::Deep::Set->new(1, "sub", @_);
}

sub cmp_set
{
	local $Test::Builder::Level = $Test::Builder::Level + 1;
	return cmp_deeply(shift, set(@{shift()}), shift);
}

sub bag
{
	require Test::Deep::Set;

	return Test::Deep::Set->new(0, "", @_);
}

sub superbagof
{
	require Test::Deep::Set;

	return Test::Deep::Set->new(0, "sup", @_);
}

sub subbagof
{
	require Test::Deep::Set;

	return Test::Deep::Set->new(0, "sub", @_);
}

sub cmp_bag
{
	local $Test::Builder::Level = $Test::Builder::Level + 1;
  my $ref = ref($_[1]) || "";
  confess "Argument 2 to cmp_bag is not an ARRAY ref (".render_val($_[1]).")"
    unless $ref eq "ARRAY";
  return cmp_deeply(shift, bag(@{shift()}), shift);
}

sub superhashof
{
	require Test::Deep::Hash;

	my $val = shift;

	return Test::Deep::SuperHash->new($val);
}

sub subhashof
{
	require Test::Deep::Hash;

	my $val = shift;

	return Test::Deep::SubHash->new($val);
}

sub builder
{
	if (@_)
	{
		$Test = shift;
	}
	return $Test;
}

1;

__END__

#line 1475