The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;
use blib;
use Data::Structure::Util qw(unbless get_blessed has_circular_ref);
use Data::Dumper;

my $WEAKEN;

eval q{ use Scalar::Util qw(weaken isweak) };
if ( !$@ and defined &Scalar::Util::weaken ) {
    $WEAKEN = 1;
}

use Test::More;

plan tests => 14 + 6 * $WEAKEN;

ok( 1, "we loaded fine..." );

my $obj = bless {
    key1 => [ 1, 2, 3, bless {} => 'Tagada' ],
    key2 => undef,
    key3 => {
        key31 => {},
        key32 => bless { bla => [] } => 'Tagada',
    },
    key5 => bless [] => 'Ponie',
} => 'Scoobidoo';
$obj->{key4} = \$obj;
$obj->{key3}->{key33} = $obj->{key3}->{key31};

my $thing = { var1 => {} };
$thing->{var2} = [ $thing->{var1}->{hello} ];
$thing->{var1}->{hello} = $thing->{var2};

my $obj2 = { key1 => [ sub { [] } ] };
$obj2->{key2} = $obj2->{key1};

my $obj3;
$obj3 = \$obj3;

my $obj4 = { key1 => $obj3 };

my @V1 = ( 1, 2, sub { } );
my $obj5 = {
    key1 => undef,
    key2 => sub { },
    key3 => \@V1,
    key4 => $obj2,
    key5 => {
        key51 => sub  { },
        key52 => \*STDERR,
        key53 => [ 0, \"hello" ],
    },
};
$obj5->{key5}->{key53}->[2] = $obj5->{key5};
$obj5->{key5}->{key54}      = $obj5->{key5}->{key53}->[2];
$obj5->{key6}               = $obj5->{key5}->{key53}->[2];
$obj5->{key5}->{key55}      = $obj5->{key5}->{key53}->[2];

my $obj6 = { key1 => undef };
$obj = $obj6;
my $V2 = [ 1, undef, \5, sub { } ];
for ( 1 .. 50 ) {
    $obj->{key2} = {};
    $obj->{key1} = $V2;
    $obj         = $obj->{key2};
}
$obj->{key3} = \$obj6;

ok( !has_circular_ref( $thing ), "Not a circular ref" );

my $ref = has_circular_ref( $obj );
ok( $ref, "Got a circular reference" );
is( $ref, $obj, "reference is correct" );

ok( !has_circular_ref( $obj2 ), "No circular reference" );
ok( has_circular_ref( $obj3 ),  "Got a circular reference" );
ok( has_circular_ref( $obj4 ),  "Got a circular reference" );
ok( has_circular_ref( $obj5 ),  "Got a circular reference" );
ok( has_circular_ref( $obj6 ),  "Got a circular reference" );
is( $obj6, has_circular_ref( $obj6 ), "Match reference" );

ok( !has_circular_ref(), "No circular reference" );
ok( !has_circular_ref( [] ), "No circular reference" );
ok( has_circular_ref( [ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\$ref ] ),
    "Has circular reference" );

if ( $WEAKEN ) {
    my $obj7 = { key1 => {} };
    $obj7->{key1}->{key11} = $obj7->{key1};
    ok( has_circular_ref( $obj7 ), "Got a circular reference" );
    weaken( $obj7->{key1}->{key11} );
    ok( isweak( $obj7->{key1}->{key11} ), "has weaken reference" );
    ok( !has_circular_ref( $obj7 ), "No more circular reference" );

    my $obj8
      = bless { key1 => bless { parent => undef, } => 'Bar', } => 'Foo';
    $obj8->{key1}->{parent} = $obj8;
    ok( has_circular_ref( $obj8 ), "Got circular" );
    my $obj81 = $obj8->{key1};
    weaken( $obj8->{key1} );
    ok( isweak( $obj8->{key1} ),    "is weak" );
    ok( !has_circular_ref( $obj8 ), "Got no circular" );

}
else {
    warn "Scalar::Util XS version not installed, some tests skipped\n";
}

my $a;
my $r;
$a->[1] = \$r;

ok( !has_circular_ref( $a ),
    "circular ref where av_fetch() returns 0 should not SEGV" );