Skip to content
This repository
Fetching contributors…

Cannot retrieve contributors at this time

file 98 lines (73 sloc) 2.507 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98
#!/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();
Something went wrong with that request. Please try again.