The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;

use Test::More 0.88;

use Scalar::Util qw(refaddr);

{
    package Bar;
    use Moose;

    with qw(MooseX::Clone);

    has foo => (
        traits => [qw(Clone)],
        isa => "Foo|HashRef",
        is  => "rw",
        default => sub { Foo->new },
    );

    has same => (
        isa => "Foo",
        is  => "rw",
        default => sub { Foo->new },
    );

    has floo => (
        traits => [qw(NoClone)],
        isa => "Int",
        is  => "rw",
    );

    has flar => (
        traits => [qw(Copy)],
        isa    => "HashRef",
        is     => "rw",
        predicate => 'has_flar',
    );

    has blorg => (
        traits => [qw(StorableClone)],
        is     => "rw",
    );

    package Foo;
    use Moose;

    has copy_number => (
        isa => "Int",
        is  => "ro",
        default => 0,
    );

    has some_attr => ( is => "rw", default => "def" );

    sub clone {
        my ( $self, %params ) = @_;

        $self->meta->clone_object( $self, %params, copy_number => $self->copy_number + 1 );
    }
}


my $bar = Bar->new( floo => 3 );

isa_ok( $bar, "Bar" );
isa_ok( $bar->foo, "Foo" );
isa_ok( $bar->same, "Foo" );

is( $bar->floo, 3, "explicit init_arg" );

is( $bar->foo->copy_number, 0, "first copy" );
is( $bar->same->copy_number, 0, "first copy" );

is( $bar->foo->some_attr, 'def', "default value for other attr" );

my $copy = $bar->clone( flar => { blog => [1,2,3] } );

isnt( refaddr($bar), refaddr($copy), "copy" );

is( $copy->floo, undef, "NoClone" );

is( $copy->foo->copy_number, 1, "copy number incremented" );
is( $copy->same->copy_number, 0, "not incremented for uncloned attr" );

is( $copy->foo->some_attr, 'def', "default value for other attr" );

isnt( refaddr($bar->foo), refaddr($copy->foo), "copy" );
is( refaddr($bar->same), refaddr($copy->same), "copy" );

ok( $copy->has_flar, "flar was inserted" );

is( $copy->clone( foo => { some_attr => "laaa" } )->foo->some_attr, "laaa", "Value carried over to recursive call to clone" );

{
    my $hash = { foo => Foo->new };
    my $hash_copy = Bar->new( foo => $hash )->clone->foo;

    isnt( refaddr($hash), refaddr($hash_copy), "hash copied" );
    is_deeply( [ sort keys %$hash ], [ sort keys %$hash_copy ], "hash keys exist in clone" );
    isa_ok($hash_copy->{foo}, "Foo");
    isnt( refaddr($hash->{foo}), refaddr($hash_copy->{foo}), "foo inside hash cloned too" );
    is( $hash_copy->{foo}->copy_number, 1, "copy number" );
}

{
    my $hash = { foo => Foo->new, bar => []  };
    my $hash_copy = Bar->new( flar => $hash )->clone->flar;

    isnt( refaddr($hash), refaddr($hash_copy), "hash copied" );
    is_deeply( [ sort keys %$hash ], [ sort keys %$hash_copy ], "hash keys exist in clone" );
    isa_ok($hash_copy->{foo}, "Foo");
    is( refaddr($hash->{foo}), refaddr($hash_copy->{foo}), "foo inside hash not cloned" );
    is( refaddr($hash->{bar}), refaddr($hash_copy->{bar}), "array inside hash not cloned" );
}

{
    my $foo = Foo->new;
    my $foo_copy = Bar->new( blorg => $foo )->clone->blorg;

    isnt( refaddr($foo), refaddr($foo_copy), "foo copied" );
    is( $foo_copy->copy_number, $foo->copy_number, "but not using ->clone");
}

done_testing;