#!/usr/bin/env perl
# Glassbox test of the internal are_equal function.
use perl5i::latest;
use Test::More;
# Load the latest version of equal.pm and alias are_equal() to equal
# for convenience
{
my $equal_class = perl5i::VERSION->latest . "::equal";
$equal_class->require;
# autobox hijacks can() to look at the autobox SCALAR class
$equal_class->UNIVERSAL::can("are_equal")->alias("equal");
}
{
package Number;
use overload
'0+' => sub { 42 },
fallback => 1;
sub new { bless {} }
}
{
package String;
use overload
'""' => sub { 'foo' },
fallback => 1;
sub new { bless {} }
}
# Minimal testing of overloaded classes
ok( Number->new == 42, "Number class" );
ok( String->new eq 'foo', "String class" );
my %reftype = (
array => [42],
hash => { 4 => 2 },
scalar => \42,
code => sub { 42 },
number => 42,
string => 'foo',
undef => undef,
object => bless({}, 'Object'),
ref => \\'lol',
glob => \*STDIN,
);
{
# Everything should be equal to itself
ok( equal( $reftype{$_}, $reftype{$_} ), "$_ equals itself" ) for keys %reftype;
# ... and different from everything else
for my $reftype ( keys %reftype ) {
my @other_refs = grep { $_ ne $reftype } keys %reftype;
ok( !equal( $reftype{$reftype}, $reftype{$_} ), $reftype . ' not equal ' . $_ )
for @other_refs;
}
}
# Nested data structures
{
my $nested1 = [ qw( foo bar baz ), { foo => { foo => $reftype{code} } } ];
my $nested2 = [ qw( foo bar baz ), { foo => { foo => $reftype{code} } } ];
my $nested3 = [ qw( foo baz ), { foo => { foo => $reftype{code} } } ];
ok equal($nested1, $nested2), "Two equivalent nested data structures";
ok !equal($nested1, $nested3), "Two non-equal nested data structures";
}
# Overloaded objects
{
my $number = Number->new;
ok equal($number, $number), "OBJ== equal OBJ==";
ok equal($number, $reftype{number}), "OBJ== equals number";
my @other_refs = grep { $_ ne 'number' } keys %reftype;
ok( !equal( $number, $reftype{$_} ), "OBJ== not equal to $_" ) for @other_refs;
my $string = String->new;
ok equal($string, $string), qq{OBJ"" equal OBJ""};
ok equal($string, $reftype{string}), qq{OBJ"" equal string};
@other_refs = grep { $_ ne 'string' } keys %reftype;
ok( !equal( $string, $reftype{$_} ), qq{OBJ"" not equal to $_} ) for @other_refs;
}
done_testing();