The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Test::More tests => 7;
use Data::Dump::Streamer 'Dump';
use Carp ();
use Symbol 'gensym';
use strict;
use warnings;
require overload;

#$Id: overload.t 26 2006-04-16 15:18:52Z demerphq $#

# imports same()
(my $helper=$0)=~s/\w+\.\w+$/test_helper.pl/;
require $helper;

sub dump_obj {
    my $obj = shift;
    my $error;
    if ( not eval { my @list = Dump( $obj ); 1 } ) {
        $error = $@;
        diag( $error );
    }
    return ! defined $error;
}

ok( dump_obj( bless( do{ my $v="FooBar"; \ $v }, 'T' ) ),
    '${} overloading' );
{
    my $h={a=>'b'};
    ok( dump_obj( [ bless( [ 1, 2, 3, 4, $h ], 'T' ),$h ] ),
        '@{} overloading' );
}
ok( dump_obj( bless( {a=>'b',c=>[1,2,3,4]}, 'T' ) ),
    '%{} overloading' );
ok( dump_obj( bless( sub{}, 'T' ) ),
    '&{} overloading' );
ok( dump_obj( bless( gensym(), 'T' ) ),
    '*{} overloading' );
our @foofoo=qw(foo foo);
our $foofoo=bless \@foofoo,'T';
my $x=bless \*foofoo,'T';
ok( dump_obj( $x ),'containing glob' );

{
    my ($r1,$r2);
    $r1 = \$r2;
    $r2 = \$r1;
    my $c= sub {die};
    my $fh= gensym();
    my $gv= \*foofoo ;
    my $h={a=>'b',r1=>$r1,r2=>$r2,c=>$c,gv=>$gv};
    my $a1=[ 0..4, $h, $r1, $r2,$c,$fh,$gv ];
    $h->{array}=$a1;
    my $a2=[$a1,$h];

    bless $_,'T' for $r1,$r2,$c,$fh,$gv,$h,$a1,$a2;

    my $o=Dump();
    test_dump( {name=>'overloading madness',no_dumper=>1}, $o, $a2, <<'EXPECT');
$T1 = [
        [
          0,
          1,
          2,
          3,
          4,
          'V: $T1->[1]',
          \do { my $v = 'V: $T1->[0][7]' },
          \do { my $v = 'V: $T1->[0][6]' },
          sub {
            die;
          },
          do{ require Symbol; Symbol::gensym },
          \*::foofoo
        ],
        {
          a     => 'b',
          array => 'V: $T1->[0]',
          c     => 'V: $T1->[0][8]',
          gv    => 'V: $T1->[0][10]',
          r1    => 'V: $T1->[0][6]',
          r2    => 'V: $T1->[0][7]'
        }
      ];
$T1->[0][5] = $T1->[1];
${$T1->[0][6]} = $T1->[0][7];
${$T1->[0][7]} = $T1->[0][6];
$T1->[1]{array} = $T1->[0];
$T1->[1]{c} = $T1->[0][8];
$T1->[1]{gv} = $T1->[0][10];
$T1->[1]{r1} = $T1->[0][6];
$T1->[1]{r2} = $T1->[0][7];
*::foofoo = \do { my $v = 'V: *::foofoo{ARRAY}' };
*::foofoo = [
              ( 'foo' ) x 2
            ];
${*::foofoo} = *::foofoo{ARRAY};
bless( $T1->[0][6], 'T' );
bless( $T1->[0][7], 'T' );
bless( $T1->[0][8], 'T' );
bless( $T1->[0][9], 'T' );
bless( $T1->[0][10], 'T' );
bless( $T1->[0], 'T' );
bless( $T1->[1], 'T' );
bless( $T1, 'T' );
bless( *::foofoo{ARRAY}, 'T' );
EXPECT
}


package T;
BEGIN {
    overload->import(
        map { my $operation = $_;
              $operation => sub { Carp::confess( "The overloaded method $operation was called" ) } }
        map { split( ' ' ) }
        values %overload::ops
    );
}