Initial Commit

database/perl/lib/Test/Deep/All.pm

@@ -0,0 +1,54 @@
+use strict;
+use warnings;
+
+package Test::Deep::All;
+
+use Scalar::Util ();
+use Test::Deep::Cmp;
+
+sub init
+{
+  my $self = shift;
+
+  my @list = map {
+    (Scalar::Util::blessed($_) && $_->isa('Test::Deep::All'))
+    ? @{ $_->{val} }
+    : $_
+  } @_;
+
+  $self->{val} = \@list;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $data = $self->data;
+
+  my $index = 1;
+
+  foreach my $cmp (@{$self->{val}})
+  {
+    $data->{index} = $index;
+    $index++;
+
+    next if Test::Deep::descend($got, $cmp);
+    return 0
+  }
+
+  return 1;
+}
+
+sub render_stack
+{
+  my $self = shift;
+  my $var = shift;
+  my $data = shift;
+
+  my $max = @{$self->{val}};
+
+  return "(Part $data->{index} of $max in $var)";
+}
+
+1;

database/perl/lib/Test/Deep/Any.pm

@@ -0,0 +1,63 @@
+use strict;
+use warnings;
+
+package Test::Deep::Any;
+
+use Scalar::Util ();
+use Test::Deep::Cmp;
+
+sub init
+{
+  my $self = shift;
+
+  my @list = map {
+    (Scalar::Util::blessed($_) && $_->isa('Test::Deep::Any'))
+    ? @{ $_->{val} }
+    : $_
+  } @_;
+
+  $self->{val} = \@list;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  foreach my $cmp (@{$self->{val}})
+  {
+    return 1 if Test::Deep::eq_deeply_cache($got, $cmp);
+  }
+
+  return 0;
+}
+
+sub renderExp
+{
+  my $self = shift;
+
+  my @expect = map {; Test::Deep::wrap($_) } @{ $self->{val} };
+  my $things = join(", ", map {$_->renderExp} @expect);
+
+  return "Any of ( $things )";
+}
+
+sub diagnostics
+{
+  my $self = shift;
+  my ($where, $last) = @_;
+
+  my $got = $self->renderGot($last->{got});
+  my $exp = $self->renderExp;
+
+  my $diag = <<EOM;
+Comparing $where with Any
+got      : $got
+expected : $exp
+EOM
+
+  $diag =~ s/\n+$/\n/;
+  return $diag;
+}
+
+4;

database/perl/lib/Test/Deep/Array.pm

@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+
+package Test::Deep::Array;
+
+use Test::Deep::Ref;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $exp = $self->{val};
+
+  return 0 unless Test::Deep::descend($got, Test::Deep::arraylength(scalar @$exp));
+
+  return 0 unless $self->test_class($got);
+
+  return Test::Deep::descend($got, Test::Deep::arrayelementsonly($exp));
+}
+
+sub reset_arrow
+{
+  return 0;
+}
+
+1;

database/perl/lib/Test/Deep/ArrayEach.pm

@@ -0,0 +1,37 @@
+use strict;
+use warnings;
+
+package Test::Deep::ArrayEach;
+
+use Test::Deep::Cmp;
+use Scalar::Util ();
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  return unless ref $got && Scalar::Util::reftype($got) eq 'ARRAY';
+  my $exp = [ ($self->{val}) x @$got ];
+
+  return Test::Deep::descend($got, $exp);
+}
+
+sub renderExp
+{
+  my $self = shift;
+  my $exp = shift;
+
+  return '[ ' . $self->SUPER::renderExp($self->{val}) . ', ... ]';
+}
+
+1;

database/perl/lib/Test/Deep/ArrayElementsOnly.pm

@@ -0,0 +1,54 @@
+use strict;
+use warnings;
+
+package Test::Deep::ArrayElementsOnly;
+
+use Test::Deep::Ref;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $exp = $self->{val};
+
+  my $data = $self->data;
+
+  for my $i (0..$#{$exp})
+  {
+    $data->{index} = $i;
+
+    my $got_elem = $got->[$i];
+    my $exp_elem = $exp->[$i];
+
+    return 0 unless Test::Deep::descend($got_elem, $exp_elem)
+  }
+
+  return 1;
+}
+
+sub render_stack
+{
+  my $self = shift;
+  my ($var, $data) = @_;
+  $var .= "->" unless $Test::Deep::Stack->incArrow;
+  $var .= "[$data->{index}]";
+
+  return $var;
+}
+
+sub reset_arrow
+{
+  return 0;
+}
+
+1;

database/perl/lib/Test/Deep/ArrayLength.pm

@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+
+package Test::Deep::ArrayLength;
+
+use Test::Deep::Ref;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $exp = $self->{val};
+
+  return 0 unless $self->test_reftype($got, "ARRAY");
+
+  return Test::Deep::descend($got, Test::Deep::arraylengthonly($exp));
+}
+
+1;

database/perl/lib/Test/Deep/ArrayLengthOnly.pm

@@ -0,0 +1,60 @@
+use strict;
+use warnings;
+
+package Test::Deep::ArrayLengthOnly;
+
+use Test::Deep::Ref;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $len = $self->{val};
+
+  return @$got == $len;
+}
+
+sub render_stack
+{
+  my $self = shift;
+  my ($var, $data) = @_;
+
+  return "array length of $var";
+}
+
+sub renderVal
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  return "array with $val element(s)"
+}
+
+sub renderGot
+{
+  my $self = shift;
+
+  my $got = shift;
+
+  return $self->renderVal(@$got + 0);
+}
+
+sub renderExp
+{
+  my $self = shift;
+
+  return $self->renderVal($self->{val});
+}
+
+1;

database/perl/lib/Test/Deep/Blessed.pm

@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+
+package Test::Deep::Blessed;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util qw( blessed );
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $exp = $self->{val};
+  my $blessed = blessed($got);
+
+  return Test::Deep::descend($blessed, Test::Deep::shallow($exp));
+}
+
+sub render_stack
+{
+  my $self = shift;
+  my $var = shift;
+
+  return "blessed($var)"
+}
+
+sub renderGot
+{
+  my $self = shift;
+
+  my $got = shift;
+
+  $self->SUPER::renderGot(blessed($got));
+}
+
+1;

database/perl/lib/Test/Deep/Boolean.pm

@@ -0,0 +1,46 @@
+use strict;
+use warnings;
+
+package Test::Deep::Boolean;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+  my $self = shift;
+
+  $self->{val} = shift() ? 1 : 0;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  return !( $got xor $self->{val} );
+}
+
+sub diag_message
+{
+  my $self = shift;
+  my $where = shift;
+  return "Comparing $where as a boolean";
+}
+
+sub renderExp
+{
+  my $self = shift;
+
+  $self->renderGot($self->{val});
+}
+
+sub renderGot
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  return ($val ? "true" : "false")." (".Test::Deep::render_val($val).")";
+}
+
+1;

database/perl/lib/Test/Deep/Cache.pm

@@ -0,0 +1,78 @@
+use strict;
+use warnings;
+
+package Test::Deep::Cache;
+
+use Test::Deep::Cache::Simple;
+
+sub new
+{
+  my $pkg = shift;
+
+  my $self = bless {}, $pkg;
+
+  $self->{expects} = [Test::Deep::Cache::Simple->new];
+  $self->{normal} = [Test::Deep::Cache::Simple->new];
+
+  $self->local;
+
+  return $self;
+}
+
+sub add
+{
+  my $self = shift;
+
+  my $type = $self->type;
+
+  $self->{$type}->[-1]->add(@_);
+}
+
+sub cmp
+{
+  # go through all the caches to see if we know this one
+
+  my $self = shift;
+
+  my $type = $self->type;
+
+  foreach my $cache (@{$self->{$type}})
+  {
+    return 1 if $cache->cmp(@_);
+  }
+
+  return 0
+}
+
+sub local
+{
+  my $self = shift;
+
+  foreach my $type (qw( expects normal ))
+  {
+    push(@{$self->{$type}}, Test::Deep::Cache::Simple->new);
+  }
+}
+
+sub finish
+{
+  my $self = shift;
+
+  my $keep = shift;
+
+  foreach my $type (qw( expects normal ))
+  {
+    my $caches = $self->{$type};
+
+    my $last = pop @$caches;
+
+    $caches->[-1]->absorb($last) if $keep;
+  }
+}
+
+sub type
+{
+  return $Test::Deep::Expects ? "expects" : "normal";
+}
+
+1;

database/perl/lib/Test/Deep/Cache/Simple.pm

@@ -0,0 +1,83 @@
+use strict;
+use warnings;
+
+package Test::Deep::Cache::Simple;
+use Carp qw( confess );
+
+use Scalar::Util qw( refaddr );
+
+BEGIN
+{
+  if (grep /^weaken$/, @Scalar::Util::EXPORT_FAIL)
+  {
+    # we're running on a version of perl that has no weak refs, so we
+    # just install a no-op sub for weaken instead of importing it
+    *weaken = sub {};
+  }
+  else
+  {
+    Scalar::Util->import('weaken');
+  }
+}
+
+sub new
+{
+  my $pkg = shift;
+
+  my $self = bless {}, $pkg;
+
+  return $self;
+}
+
+sub add
+{
+  my $self = shift;
+
+  my ($d1, $d2) = @_;
+  {
+    local $SIG{__DIE__};
+
+    local $@;
+
+    # cannot weaken read only refs, no harm if we can't as they never
+    # disappear
+    eval{weaken($d1)};
+    eval{weaken($d2)};
+  }
+
+  $self->{fn_get_key(@_)} = [$d1, $d2];
+}
+
+sub cmp
+{
+  my $self = shift;
+
+  my $key = fn_get_key(@_);
+  my $pair = $self->{$key};
+
+  # are both weakened refs still valid, if not delete this entry
+  if (ref($pair->[0]) and ref($pair->[1]))
+  {
+    return 1;
+  }
+  else
+  {
+    delete $self->{$key};
+    return 0;
+  }
+}
+
+sub absorb
+{
+  my $self = shift;
+
+  my $other = shift;
+
+  @{$self}{keys %$other} = values %$other;
+}
+
+sub fn_get_key
+{
+  return join(",", sort (map {refaddr($_)} @_));
+}
+1;

database/perl/lib/Test/Deep/Class.pm

@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+
+package Test::Deep::Class;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+  my $self = shift;
+
+  my $snobby = shift;
+  my $val = shift;
+
+  $self->{snobby} = $snobby;
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  local $Test::Deep::Snobby = $self->{snobby};
+
+  Test::Deep::wrap($self->{val})->descend($got);
+}
+
+1;

database/perl/lib/Test/Deep/Cmp.pm

@@ -0,0 +1,106 @@
+use strict;
+use warnings;
+
+package Test::Deep::Cmp;
+
+use overload
+  '&' => \&make_all,
+  '|' => \&make_any,
+  '""' => \&string,
+  fallback => 1,
+;
+
+use Scalar::Util ();
+
+sub import
+{
+  my $pkg = shift;
+
+  my $callpkg = caller();
+  if ($callpkg =~ /^Test::Deep::/)
+  {
+    no strict 'refs';
+
+    push @{$callpkg."::ISA"}, $pkg;
+  }
+}
+
+sub new
+{
+  my $pkg = shift;
+
+  my $self = bless {}, $pkg;
+
+  $self->init(@_);
+  return $self;
+}
+
+sub init
+{
+}
+
+sub make_all
+{
+  my ($e1, $e2) = @_;
+
+  return Test::Deep::all($e1, $e2);
+}
+
+sub make_any
+{
+  my ($e1, $e2) = @_;
+
+  return Test::Deep::any($e1, $e2);
+}
+
+sub cmp
+{
+  my ($a1, $a2, $rev) = @_;
+
+  ($a1, $a2) = ($a2, $a1) if $rev;
+
+  return (overload::StrVal($a1) cmp overload::StrVal($a2));
+}
+
+sub string
+{
+  my $self = shift;
+
+  return overload::StrVal($self);
+}
+
+sub render_stack
+{
+  my $self = shift;
+  my $var = shift;
+
+  return $var;
+}
+
+sub renderExp
+{
+  my $self = shift;
+
+  return $self->renderGot($self->{val});
+}
+
+sub renderGot
+{
+  my $self = shift;
+
+  return Test::Deep::render_val(@_);
+}
+
+sub reset_arrow
+{
+  return 1;
+}
+
+sub data
+{
+  my $self = shift;
+
+  return $Test::Deep::Stack->getLast;
+}
+
+1;

database/perl/lib/Test/Deep/Code.pm

@@ -0,0 +1,58 @@
+use strict;
+use warnings;
+
+package Test::Deep::Code;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+  my $self = shift;
+
+  my $code = shift || die "No coderef supplied";
+
+  $self->{code} = $code;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my ($ok, $diag) = &{$self->{code}}($got);
+
+  $self->data->{diag} = $diag;
+
+  return $ok;
+}
+
+sub diagnostics
+{
+  my $self = shift;
+  my ($where, $last) = @_;
+
+  my $error = $last->{diag};
+  my $data = Test::Deep::render_val($last->{got});
+  my $diag = <<EOM;
+Ran coderef at $where on
+
+$data
+EOM
+  if (defined($error))
+  {
+    $diag .= <<EOM;
+and it said
+$error
+EOM
+  }
+  else
+  {
+    $diag .= <<EOM;
+it failed but it didn't say why.
+EOM
+  }
+
+  return $diag;
+}
+
+1;

database/perl/lib/Test/Deep/Hash.pm

@@ -0,0 +1,104 @@
+use strict;
+use warnings;
+
+package Test::Deep::Hash;
+
+use Test::Deep::Ref;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+
+  my $got = shift;
+
+  my $exp = $self->{val};
+
+  my $data = $self->data;
+
+  return 0 unless Test::Deep::descend($got, $self->hash_keys($exp));
+
+  return 0 unless $self->test_class($got);
+
+  return Test::Deep::descend($got, $self->hash_elements($exp));
+}
+
+sub hash_elements
+{
+  require Test::Deep::HashElements;
+
+  my $self = shift;
+
+  return Test::Deep::HashElements->new(@_);
+}
+
+sub hash_keys
+{
+  require Test::Deep::HashKeys;
+
+  my $self = shift;
+  my $exp = shift;
+
+  return Test::Deep::HashKeys->new(keys %$exp);
+}
+
+sub reset_arrow
+{
+  return 0;
+}
+
+package Test::Deep::SuperHash;
+
+use base 'Test::Deep::Hash';
+
+sub hash_elements
+{
+  require Test::Deep::HashElements;
+
+  my $self = shift;
+
+  return Test::Deep::SuperHashElements->new(@_);
+}
+
+sub hash_keys
+{
+  require Test::Deep::HashKeys;
+
+  my $self = shift;
+  my $exp = shift;
+
+  return Test::Deep::SuperHashKeys->new(keys %$exp);
+}
+
+package Test::Deep::SubHash;
+
+use base 'Test::Deep::Hash';
+
+sub hash_elements
+{
+  require Test::Deep::HashElements;
+
+  my $self = shift;
+
+  return Test::Deep::SubHashElements->new(@_);
+}
+
+sub hash_keys
+{
+  require Test::Deep::HashKeys;
+
+  my $self = shift;
+  my $exp = shift;
+
+  return Test::Deep::SubHashKeys->new(keys %$exp);
+}
+
+1;

database/perl/lib/Test/Deep/HashEach.pm

@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+
+package Test::Deep::HashEach;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my %exp;
+
+  @exp{keys %$got} = ($self->{val}) x (keys %$got);
+
+  return Test::Deep::descend($got, \%exp);
+}
+
+1;

database/perl/lib/Test/Deep/HashElements.pm

@@ -0,0 +1,94 @@
+use strict;
+use warnings;
+
+package Test::Deep::HashElements;
+
+use Test::Deep::Ref;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+
+  my $got = shift;
+
+  my $exp = $self->{val};
+
+  my $data = $self->data;
+
+  my $master = $self->getMaster($got, $exp);
+
+  foreach my $key (keys %$master)
+  {
+    $data->{index} = $key;
+
+    my $got_elem = exists $got->{$key} ? $got->{$key} : $Test::Deep::DNE;
+    my $exp_elem = exists $exp->{$key} ? $exp->{$key} : $Test::Deep::DNE;
+
+    next if Test::Deep::descend($got_elem, $exp_elem);
+
+    return 0;
+  }
+
+  return 1;
+}
+
+sub getMaster
+{
+  my $self = shift;
+
+  my ($got, $exp) = @_;
+
+  return keys %$got > keys %$exp ? $got : $exp;
+}
+
+sub render_stack
+{
+  my $self = shift;
+  my ($var, $data) = @_;
+  $var .= "->" unless $Test::Deep::Stack->incArrow;
+  $var .= '{"'.quotemeta($data->{index}).'"}';
+
+  return $var;
+}
+
+sub reset_arrow
+{
+  return 0;
+}
+
+package Test::Deep::SuperHashElements;
+
+use base 'Test::Deep::HashElements';
+
+sub getMaster
+{
+  my $self = shift;
+
+  my ($got, $exp) = @_;
+
+  return $exp;
+}
+
+package Test::Deep::SubHashElements;
+
+use base 'Test::Deep::HashElements';
+
+sub getMaster
+{
+  my $self = shift;
+
+  my ($got, $exp) = @_;
+
+  return $got;
+}
+
+1;

database/perl/lib/Test/Deep/HashKeys.pm

@@ -0,0 +1,68 @@
+use strict;
+use warnings;
+
+package Test::Deep::HashKeys;
+
+use Test::Deep::Ref;
+
+sub init
+{
+  my $self = shift;
+
+  my %keys;
+  @keys{@_} = ();
+  $self->{val} = \%keys;
+  $self->{keys} = [sort @_];
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $exp = $self->{val};
+
+  return 0 unless $self->test_reftype($got, "HASH");
+
+  return Test::Deep::descend($got, $self->hashkeysonly($exp));
+}
+
+sub hashkeysonly
+{
+  require Test::Deep::HashKeysOnly;
+
+  my $self = shift;
+  my $exp = shift;
+
+  return Test::Deep::HashKeysOnly->new(keys %$exp)
+}
+
+package Test::Deep::SuperHashKeys;
+
+use base 'Test::Deep::HashKeys';
+
+sub hashkeysonly
+{
+  require Test::Deep::HashKeysOnly;
+
+  my $self = shift;
+  my $exp = shift;
+
+  return Test::Deep::SuperHashKeysOnly->new(keys %$exp)
+}
+
+package Test::Deep::SubHashKeys;
+
+use base 'Test::Deep::HashKeys';
+
+sub hashkeysonly
+{
+  require Test::Deep::HashKeysOnly;
+
+  my $self = shift;
+  my $exp = shift;
+
+  return Test::Deep::SubHashKeysOnly->new(keys %$exp)
+}
+
+1;

database/perl/lib/Test/Deep/HashKeysOnly.pm

@@ -0,0 +1,126 @@
+use strict;
+use warnings;
+
+package Test::Deep::HashKeysOnly;
+
+use Test::Deep::Ref;
+
+sub init
+{
+  my $self = shift;
+
+  my %keys;
+  @keys{@_} = ();
+  $self->{val} = \%keys;
+  $self->{keys} = [sort @_];
+}
+
+sub descend
+{
+  my $self = shift;
+  my $hash = shift;
+
+  my $data = $self->data;
+  my $exp = $self->{val};
+  my %got;
+  @got{keys %$hash} = ();
+
+  my @missing;
+  my @extra;
+
+  while (my ($key, $value) = each %$exp)
+  {
+    if (exists $got{$key})
+    {
+      delete $got{$key};
+    }
+    else
+    {
+      push(@missing, $key);
+    }
+  }
+
+  my @diags;
+  if (@missing and (not $self->ignoreMissing))
+  {
+    push(@diags, "Missing: ".nice_list(\@missing));
+  }
+
+  if (%got and (not $self->ignoreExtra))
+  {
+    push(@diags, "Extra: ".nice_list([keys %got]));
+  }
+
+  if (@diags)
+  {
+    $data->{diag} = join("\n", @diags);
+    return 0;
+  }
+
+  return 1;
+}
+
+sub diagnostics
+{
+  my $self = shift;
+  my ($where, $last) = @_;
+
+  my $type = $self->{IgnoreDupes} ? "Set" : "Bag";
+
+  my $error = $last->{diag};
+  my $diag = <<EOM;
+Comparing hash keys of $where
+$error
+EOM
+
+  return $diag;
+}
+
+sub nice_list
+{
+  my $list = shift;
+
+  return join(", ",
+    (map {"'$_'"} sort @$list),
+  );
+}
+
+sub ignoreMissing
+{
+  return 0;
+}
+
+sub ignoreExtra
+{
+  return 0;
+}
+
+package Test::Deep::SuperHashKeysOnly;
+
+use base 'Test::Deep::HashKeysOnly';
+
+sub ignoreMissing
+{
+  return 0;
+}
+
+sub ignoreExtra
+{
+  return 1;
+}
+
+package Test::Deep::SubHashKeysOnly;
+
+use base 'Test::Deep::HashKeysOnly';
+
+sub ignoreMissing
+{
+  return 1;
+}
+
+sub ignoreExtra
+{
+  return 0;
+}
+
+1;

database/perl/lib/Test/Deep/Ignore.pm

@@ -0,0 +1,20 @@
+use strict;
+use warnings;
+
+package Test::Deep::Ignore;
+
+use Test::Deep::Cmp;
+
+my $Singleton = __PACKAGE__->SUPER::new;
+
+sub new
+{
+  return $Singleton;
+}
+
+sub descend
+{
+  return 1;
+}
+
+1;

database/perl/lib/Test/Deep/Isa.pm

@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+
+package Test::Deep::Isa;
+
+use Test::Deep::Cmp;
+use Scalar::Util;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  return Scalar::Util::blessed($got)
+    ? $got->isa($self->{val})
+    : ref($got) eq $self->{val};
+}
+
+sub diag_message
+{
+  my $self = shift;
+
+  my $where = shift;
+
+  return "Checking class of $where with isa()";
+}
+
+sub renderExp
+{
+  my $self = shift;
+
+  return "blessed into or ref of type '$self->{val}'";
+}
+
+1;

database/perl/lib/Test/Deep/ListMethods.pm

@@ -0,0 +1,24 @@
+use strict;
+use warnings;
+
+package Test::Deep::ListMethods;
+
+use base 'Test::Deep::Methods';
+
+sub call_method
+{
+  my $self = shift;
+
+  return [$self->SUPER::call_method(@_)];
+}
+
+sub render_stack
+{
+  my $self = shift;
+
+  my $var = $self->SUPER::render_stack(@_);
+
+  return "[$var]";
+}
+
+1;

database/perl/lib/Test/Deep/MM.pm

@@ -0,0 +1,64 @@
+use strict;
+use warnings;
+
+package Test::Deep::MM;
+
+sub import
+{
+  my $self = shift;
+
+  my ($pkg) = caller();
+  my $mpkg = $pkg."::Methods";
+  foreach my $attr (@_)
+  {
+    if ($attr =~ /^[a-z]/)
+    {
+      no strict 'refs';
+      *{$mpkg."::$attr"} = \&{$attr};
+    }
+    else
+    {
+      my $get_name = $mpkg."::get$attr";
+      my $set_name = $mpkg."::set$attr";
+      my $get_sub = sub {
+        return $_[0]->{$attr};
+      };
+      my $set_sub = sub {
+        return $_[0]->{$attr} = $_[1];
+      };
+
+      {
+        no strict 'refs';
+        *$get_name = $get_sub;
+        *$set_name = $set_sub;
+        push(@{$pkg."::ISA"}, $mpkg);
+      }
+    }
+  }
+}
+
+sub new
+{
+  my $pkg = shift;
+
+  my $self = bless {}, $pkg;
+
+  $self->init(@_);
+
+  return $self;
+}
+
+sub init
+{
+  my $self = shift;
+
+  while (@_)
+  {
+    my $name = shift || confess("No name");
+
+    my $method = "set$name";
+    $self->$method(shift);
+  }
+}
+
+1;

database/perl/lib/Test/Deep/Methods.pm

@@ -0,0 +1,83 @@
+use strict;
+use warnings;
+
+package Test::Deep::Methods;
+
+use Test::Deep::Cmp;
+use Scalar::Util;
+
+sub init
+{
+  my $self = shift;
+
+  # get them all into [$name,@args] => $value format
+  my @methods;
+  while (@_)
+  {
+    my $name = shift;
+    my $value = shift;
+    push(@methods,
+      [
+        ref($name) ? $name : [ $name ],
+        $value
+      ]
+    );
+  }
+  $self->{methods} = \@methods;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $data = $self->data;
+
+  foreach my $method (@{$self->{methods}})
+  {
+    $data->{method} = $method;
+
+    my ($call, $exp_res) = @$method;
+    my ($name, @args) = @$call;
+
+    local $@;
+
+    my $got_res;
+    if (! eval { $got_res = $self->call_method($got, $call); 1 }) {
+      die $@ unless $@ =~ /\ACan't locate object method "\Q$name"/;
+      $got_res = $Test::Deep::DNE;
+    }
+
+    next if Test::Deep::descend($got_res, $exp_res);
+
+    return 0;
+  }
+
+  return 1;
+}
+
+sub call_method
+{
+  my $self = shift;
+  my ($got, $call) = @_;
+  my ($name, @args) = @$call;
+
+  return $got->$name(@args);
+}
+
+sub render_stack
+{
+  my $self = shift;
+  my ($var, $data) = @_;
+
+  my $method = $data->{method};
+  my ($call, $expect) = @$method;
+  my ($name, @args) = @$call;
+
+  my $args = @args ? "(".join(", ", @args).")" : "";
+  $var .= "->$name$args";
+
+  return $var;
+}
+
+1;

database/perl/lib/Test/Deep/NoTest.pm

@@ -0,0 +1,42 @@
+use strict;
+use warnings;
+
+# this is for people who don't want Test::Builder to be loaded but want to
+# use eq_deeply. It's a bit hacky...
+
+package Test::Deep::NoTest;
+
+our $NoTest;
+
+{
+  local $NoTest = 1;
+  require Test::Deep;
+}
+
+sub import {
+  my $import = Test::Deep->can("import");
+  # make the stack look like it should for use Test::Deep
+  my $pkg = shift;
+  unshift(@_, "Test::Deep");
+  push @_, '_notest';
+  goto &$import;
+}
+
+1;
+
+=head1 NAME
+
+Test::Deep::NoTest - Use Test::Deep outside of the testing framework
+
+=head1 SYNOPSIS
+
+  use Test::Deep::NoTest;
+
+  if (eq_deeply($a, $b)) {
+    print "they were deeply equal\n";
+  }
+
+=head1 DESCRIPTION
+
+This exports all the same things as Test::Deep but it does not load
+Test::Builder so it can be used in ordinary non-test situations.

database/perl/lib/Test/Deep/None.pm

@@ -0,0 +1,62 @@
+use strict;
+use warnings;
+
+package Test::Deep::None;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+  my $self = shift;
+
+  my @list = map {
+    eval { $_->isa('Test::Deep::None') }
+    ? @{ $_->{val} }
+    : $_
+  } @_;
+
+  $self->{val} = \@list;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  foreach my $cmp (@{$self->{val}})
+  {
+    return 0 if Test::Deep::eq_deeply_cache($got, $cmp);
+  }
+
+  return 1;
+}
+
+sub renderExp
+{
+  my $self = shift;
+
+  my @expect = map {; Test::Deep::wrap($_) } @{ $self->{val} };
+  my $things = join(", ", map {$_->renderExp} @expect);
+
+  return "None of ( $things )";
+}
+
+sub diagnostics
+{
+  my $self = shift;
+  my ($where, $last) = @_;
+
+  my $got = $self->renderGot($last->{got});
+  my $exp = $self->renderExp;
+
+  my $diag = <<EOM;
+Comparing $where with None
+got      : $got
+expected : $exp
+EOM
+
+  $diag =~ s/\n+$/\n/;
+  return $diag;
+}
+
+1;

database/perl/lib/Test/Deep/Number.pm

@@ -0,0 +1,80 @@
+use strict;
+use warnings;
+
+package Test::Deep::Number;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util;
+
+sub init
+{
+  my $self = shift;
+
+  $self->{val} = shift(@_) + 0;
+  $self->{tolerance} = shift;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+  $self->data->{got_string} = $got;
+  {
+    no warnings 'numeric';
+    $got += 0;
+  }
+
+  $self->data->{got} = $got;
+  if (defined(my $tolerance = $self->{tolerance}))
+  {
+    return abs($got - $self->{val}) <= $tolerance;
+  }
+  else
+  {
+    return $got == $self->{val};
+  }
+}
+
+sub diag_message
+{
+  my $self = shift;
+
+  my $where = shift;
+
+  return "Comparing $where as a number";
+}
+
+sub renderGot
+{
+  my $self = shift;
+  my $val = shift;
+
+  my $got_string = $self->data->{got_string};
+  if ("$val" ne "$got_string")
+  {
+    $got_string = $self->SUPER::renderGot($got_string);
+    return "$val ($got_string)"
+  }
+  else
+  {
+    return $val;
+  }
+}
+sub renderExp
+{
+  my $self = shift;
+
+  my $exp = $self->{val};
+
+  if (defined(my $tolerance = $self->{tolerance}))
+  {
+    return "$exp +/- $tolerance";
+  }
+  else
+  {
+    return $exp;
+  }
+}
+
+1;

database/perl/lib/Test/Deep/Obj.pm

@@ -0,0 +1,42 @@
+use strict;
+use warnings;
+
+package Test::Deep::Obj;
+
+use Test::Deep::Cmp;
+use Scalar::Util;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  return Scalar::Util::blessed($got)
+    && $got->isa($self->{val});
+}
+
+sub diag_message
+{
+  my $self = shift;
+
+  my $where = shift;
+
+  return "Checking class of $where with isa()";
+}
+
+sub renderExp
+{
+  my $self = shift;
+
+  return "blessed into '$self->{val}' or subclass of '$self->{val}'";
+}
+
+1;

database/perl/lib/Test/Deep/Ref.pm

@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+
+package Test::Deep::Ref;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util qw( blessed );
+
+sub test_class
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $exp = $self->{val};
+  
+  if ($Test::Deep::Snobby)
+  {
+    return Test::Deep::descend($got, Test::Deep::blessed(blessed($exp)));
+  }
+  else
+  {
+    return 1;
+  }
+}
+
+sub test_reftype
+{
+  my $self = shift;
+  my $got = shift;
+  my $reftype = shift;
+
+  return Test::Deep::descend($got, Test::Deep::reftype($reftype));
+}
+
+1;

database/perl/lib/Test/Deep/RefType.pm

@@ -0,0 +1,46 @@
+use strict;
+use warnings;
+
+package Test::Deep::RefType;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util qw( reftype );
+
+sub init
+{
+  my $self = shift;
+
+  $self->{val} = shift;
+}
+
+sub descend
+{
+  my $self = shift;
+
+  my $got = shift;
+
+  my $exp = $self->{val};
+  my $reftype = reftype($got);
+
+  return Test::Deep::descend($reftype, Test::Deep::shallow($exp));
+}
+
+sub render_stack
+{
+  my $self = shift;
+  my $var = shift;
+
+  return "reftype($var)";
+}
+
+sub renderGot
+{
+  my $self = shift;
+
+  my $got = shift;
+
+  $self->SUPER::renderGot(reftype($got));
+}
+
+1;

database/perl/lib/Test/Deep/Regexp.pm

@@ -0,0 +1,102 @@
+use strict;
+use warnings;
+
+package Test::Deep::Regexp;
+
+use Test::Deep::Cmp;
+use Test::Deep::RegexpMatches;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $val = ref $val ? $val : qr/$val/;
+
+  $self->{val} = $val;
+
+  if (my $matches = shift)
+  {
+    $self->{matches} = Test::Deep::regexpmatches($matches, $val);
+
+    $self->{flags} = shift || "";
+  }
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $re = $self->{val};
+  if (my $match_exp = $self->{matches})
+  {
+    my $flags = $self->{flags};
+    my @match_got;
+    if ($flags eq "g")
+    {
+      @match_got = $got =~ /$re/g;
+    }
+    else
+    {
+      @match_got = $got =~ /$re/;
+    }
+
+    if (@match_got)
+    {
+      return Test::Deep::descend(\@match_got, $match_exp);
+    }
+    else
+    {
+      return 0;
+    }
+  }
+  else
+  {
+    return ($got =~ $re) ? 1 : 0;
+  }
+}
+
+sub diag_message
+{
+  my $self = shift;
+
+  my $where = shift;
+
+  return "Using Regexp on $where";
+}
+
+sub render_stack1
+{
+  my $self = shift;
+
+  my $stack = shift;
+  return "($stack =~ $self->{regex})";
+}
+
+sub renderExp
+{
+  my $self = shift;
+
+  return "$self->{val}";
+}
+
+sub renderGot
+{
+  my $self = shift;
+  my $got  = shift;
+
+  if (defined (my $class = Scalar::Util::blessed($got)))
+  {
+    my $ostr = qq{$got};
+    if ($ostr ne overload::StrVal($got))
+    {
+      return qq{'$ostr' (instance of $class)};
+    }
+  }
+
+  return Test::Deep::render_val($got);
+}
+
+1;

database/perl/lib/Test/Deep/RegexpMatches.pm

@@ -0,0 +1,51 @@
+use strict;
+use warnings;
+
+package Test::Deep::RegexpMatches;
+
+use Test::Deep::Array;
+
+use base 'Test::Deep::Array';
+
+use Scalar::Util qw( blessed );
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $val = Test::Deep::array($val) unless
+    blessed($val) and $val->isa("Test::Deep::Cmp");
+
+  $self->{val} = $val;
+  $self->{regex} = shift;
+}
+
+sub descend
+{
+  my $self = shift;
+
+  my $got = shift;
+
+  return Test::Deep::descend($got, $self->{val});
+}
+
+sub render_stack
+{
+  my $self = shift;
+
+  my $stack = shift;
+
+  $stack = "[$stack =~ $self->{regex}]";
+
+  return $stack;
+#  return $self->SUPER::render_stack($stack);
+}
+
+sub reset_arrow
+{
+  return 1;
+}
+
+1;

database/perl/lib/Test/Deep/RegexpOnly.pm

@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+
+package Test::Deep::RegexpOnly;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util qw( blessed );
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $val = ref $val ? $val : qr/$val/;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift;
+
+  my $re = $self->{val};
+
+  return $got =~ $self->{val} ? 1 : 0;
+}
+
+sub diag_message
+{
+  my $self = shift;
+
+  my $where = shift;
+
+  return "Using Regexp on $where";
+}
+
+sub renderExp
+{
+  my $self = shift;
+
+  return "$self->{val}";
+}
+
+1;

database/perl/lib/Test/Deep/RegexpRef.pm

@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+
+package Test::Deep::RegexpRef;
+
+use Test::Deep::Ref;
+use Test::Deep::RegexpVersion;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+
+  my $got = shift;
+
+  my $exp = $self->{val};
+
+  if ($Test::Deep::RegexpVersion::OldStyle) {
+    return 0 unless $self->test_class($got, "Regexp");
+    return 0 unless $self->test_reftype($got, "SCALAR");
+  } else {
+    return 0 unless $self->test_reftype($got, "REGEXP");
+  }
+
+  return Test::Deep::descend($got, Test::Deep::regexprefonly($exp));
+}
+
+sub renderGot
+{
+  my $self = shift;
+
+  return shift()."";
+}
+
+1;

database/perl/lib/Test/Deep/RegexpRefOnly.pm

@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+
+package Test::Deep::RegexpRefOnly;
+
+use Test::Deep::Ref;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+
+  my $got = shift;
+
+  my $exp = $self->{val};
+
+  return $got eq $exp;
+}
+
+sub render_stack
+{
+  my $self = shift;
+  my ($var, $data) = @_;
+
+  return "m/$var/";
+}
+
+sub renderGot
+{
+  my $self = shift;
+
+  return shift()."";
+}
+
+1;

database/perl/lib/Test/Deep/RegexpVersion.pm

@@ -0,0 +1,11 @@
+use strict;
+use warnings;
+
+package Test::Deep::RegexpVersion;
+
+# Older versions of Perl treated Regexp refs as opaque scalars blessed
+# into the "Regexp" class. Several bits of code need this so we
+# centralise the test for that kind of version.
+our $OldStyle = ($] < 5.011);
+
+1;

database/perl/lib/Test/Deep/ScalarRef.pm

@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+
+package Test::Deep::ScalarRef;
+
+use Test::Deep::Ref;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+
+  my $got = shift;
+  my $exp = $self->{val};
+
+  return 0 unless $self->test_class($got);
+  return 0 unless $self->test_reftype($got, Scalar::Util::reftype($exp));
+  return Test::Deep::descend($got, Test::Deep::scalarrefonly($exp));
+}
+
+1;

database/perl/lib/Test/Deep/ScalarRefOnly.pm

@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+
+package Test::Deep::ScalarRefOnly;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+
+  my $got = shift;
+
+  my $exp = $self->{val};
+
+  return Test::Deep::descend($$got, $$exp);
+}
+
+sub render_stack
+{
+  my $self = shift;
+  my ($var, $data) = @_;
+
+  return "\${$var}";
+}
+
+1;

database/perl/lib/Test/Deep/Set.pm

@@ -0,0 +1,193 @@
+use strict;
+use warnings;
+
+package Test::Deep::Set;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+  my $self = shift;
+
+  $self->{IgnoreDupes} = shift;
+  $self->{SubSup} = shift;
+
+  $self->{val} = [];
+
+  $self->add(@_);
+}
+
+sub descend
+{
+  my $self = shift;
+  my $d1 = shift;
+
+  my $d2 = $self->{val};
+
+  my $IgnoreDupes = $self->{IgnoreDupes};
+
+  my $data = $self->data;
+
+  my $SubSup = $self->{SubSup};
+
+  my $type = $IgnoreDupes ? "Set" : "Bag";
+
+  my $diag;
+
+  if (ref $d1 ne 'ARRAY')
+  {
+    my $got = Test::Deep::render_val($d1);
+    $diag = <<EOM;
+got    : $got
+expect : An array to use as a $type
+EOM
+  }
+
+  if (not $diag)
+  {
+    my @got = @$d1;
+    my @found;
+    my @missing;
+    foreach my $expect (@$d2)
+    {
+      my $found = 0;
+
+      for (my $i = $#got; $i >= 0; $i--)
+      {
+        if (Test::Deep::eq_deeply_cache($got[$i], $expect))
+        {
+          $found = 1;
+          push(@found, $expect);
+          splice(@got, $i, 1);
+
+          last unless $IgnoreDupes;
+        }
+      }
+
+      push(@missing, $expect) unless $found;
+    }
+
+    my @diags;
+    if (@missing and $SubSup ne "sub" && $SubSup ne "none")
+    {
+      push(@diags, "Missing: ".nice_list(\@missing));
+    }
+
+    if (@got and $SubSup ne "sup" && $SubSup ne "none")
+    {
+      my $got = __PACKAGE__->new($IgnoreDupes, "", @got);
+      push(@diags, "Extra: ".nice_list($got->{val}));
+    }
+
+    if (@found and $SubSup eq "none")
+    {
+      my $found = __PACKAGE__->new($IgnoreDupes, "", @found);
+      push(@diags, "Extra: ".nice_list($found->{val}));
+    }
+
+    $diag = join("\n", @diags);
+  }
+
+  if ($diag)
+  {
+    $data->{diag} = $diag;
+
+    return 0;
+  }
+  else
+  {
+    return 1;
+  }
+}
+
+sub diagnostics
+{
+  my $self = shift;
+  my ($where, $last) = @_;
+
+  my $type = $self->{IgnoreDupes} ? "Set" : "Bag";
+  $type = "Sub$type" if $self->{SubSup} eq "sub";
+  $type = "Super$type" if $self->{SubSup} eq "sup";
+        $type = "NoneOf" if $self->{SubSup} eq "none";
+
+  my $error = $last->{diag};
+  my $diag = <<EOM;
+Comparing $where as a $type
+$error
+EOM
+
+  return $diag;
+}
+
+sub add
+{
+  # this takes an array.
+
+  # For each element A of the array, it looks for an element, B, already in
+  # the set which are deeply equal to A. If no matching B is found then A is
+  # added to the set. If a B is found and IgnoreDupes is true, then A will
+  # be discarded, if IgnoreDupes is false, then B will be added to the set
+  # again.
+  
+  my $self = shift;
+
+  my @array = @_;
+
+  my $IgnoreDupes = $self->{IgnoreDupes};
+
+  my $already = $self->{val};
+
+  local $Test::Deep::Expects = 1;
+  foreach my $new_elem (@array)
+  {
+    my $want_push = 1;
+    my $push_this = $new_elem;
+    foreach my $old_elem (@$already)
+    {
+      if (Test::Deep::eq_deeply($new_elem, $old_elem))
+      {
+        $push_this = $old_elem;
+        $want_push = ! $IgnoreDupes;
+        last;
+      }
+    }
+    push(@$already, $push_this) if $want_push;
+  }
+
+  # so we can compare 2 Test::Deep::Set objects using array comparison
+
+  @$already = sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @$already;
+}
+
+sub nice_list
+{
+  my $list = shift;
+
+  my @scalars = grep ! ref $_, @$list;
+  my $refs = grep ref $_, @$list;
+
+  my @ref_string = "$refs reference" if $refs;
+  $ref_string[0] .= "s" if $refs > 1;
+
+  # sort them so we can predict the diagnostic output
+
+  return join(", ",
+    (map {Test::Deep::render_val($_)} sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @scalars),
+    @ref_string
+  );
+}
+
+sub compare
+{
+  my $self = shift;
+
+  my $other = shift;
+
+  return 0 if $self->{IgnoreDupes} != $other->{IgnoreDupes};
+
+  # this works (kind of) because the arrays are sorted
+
+  return Test::Deep::descend($self->{val}, $other->{val});
+}
+
+1;

database/perl/lib/Test/Deep/Shallow.pm

@@ -0,0 +1,51 @@
+use strict;
+use warnings;
+
+package Test::Deep::Shallow;
+
+use Test::Deep::Cmp;
+
+use Scalar::Util qw( refaddr );
+
+sub init
+{
+  my $self = shift;
+
+  my $val = shift;
+  $self->{val} = $val;
+}
+
+sub descend
+{
+  my $self = shift;
+
+  my $got = shift;
+  my $exp = $self->{val};
+
+  my $ok;
+
+  if (!defined $got and !defined $exp)
+  {
+    $ok = 1;
+  }
+  elsif (defined $got xor defined $exp)
+  {
+    $ok = 0;
+  }
+  elsif (ref $got and ref $exp)
+  {
+    $ok = refaddr($got) == refaddr($exp);
+  }
+  elsif (ref $got xor ref $exp)
+  {
+    $ok = 0;
+  }
+  else
+  {
+    $ok = $got eq $exp;
+  }
+
+  return $ok;
+}
+
+1;

database/perl/lib/Test/Deep/Stack.pm

@@ -0,0 +1,85 @@
+use strict;
+use warnings;
+
+package Test::Deep::Stack;
+
+use Carp qw( confess );
+use Scalar::Util;
+
+use Test::Deep::MM qw( new init Stack Arrow );
+
+sub init
+{
+  my $self = shift;
+
+  $self->SUPER::init(@_);
+
+  $self->setStack([]) unless $self->getStack;
+}
+
+sub push
+{
+  my $self = shift;
+
+  push(@{$self->getStack}, @_);
+}
+
+sub pop
+{
+  my $self = shift;
+
+  return pop @{$self->getStack};
+}
+
+sub render
+{
+  my $self = shift;
+  my $var = shift;
+
+  my $stack = $self->getStack;
+
+  $self->setArrow(0);
+
+  foreach my $data (@$stack)
+  {
+    my $exp = $data->{exp};
+    if (Scalar::Util::blessed($exp) and $exp->isa("Test::Deep::Cmp"))
+    {
+      $var = $exp->render_stack($var, $data);
+
+      $self->setArrow(0) if $exp->reset_arrow;
+    }
+    else
+    {
+      confess "Don't know how to render '$exp'";
+    }
+  }
+
+  return $var;
+}
+
+sub getLast
+{
+  my $self = shift;
+
+  return $self->getStack->[-1];
+}
+
+sub incArrow
+{
+  my $self = shift;
+
+  my $a = $self->getArrow;
+  $self->setArrow($a + 1);
+
+  return $a;
+}
+
+sub length
+{
+  my $self = shift;
+
+  return @{$self->getStack} + 0;
+}
+
+1;

database/perl/lib/Test/Deep/String.pm

@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+
+package Test::Deep::String;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+  my $self = shift;
+
+  $self->{val} = shift;
+}
+
+sub descend
+{
+  my $self = shift;
+  my $got = shift()."";
+
+  $self->data->{got} = $got;
+
+  return $got eq $self->{val};
+}
+
+sub diag_message
+{
+  my $self = shift;
+
+  my $where = shift;
+
+  return "Comparing $where as a string";
+}
+
+1;