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

use Config;
BEGIN {
    if ($] < 5.008009) {
        print("1..0 # Skip Needs Perl 5.8.9 or later\n");
        exit(0);
    }
    if (! $Config{useithreads}) {
        print("1..0 # Skip Threads not supported\n");
        exit(0);
    }
}

use threads;
use threads::shared;

BEGIN {
    if ($threads::shared::VERSION lt '1.15') {
        print("1..0 # Skip Needs threads::shared 1.15 or later\n");
        exit(0);
    }
}

use Test::More 'tests' => 29;

package Container; {
    use Object::InsideOut qw(:SHARED);

    my @contents :Field;

    sub store
    {
        my ($self, $item) = @_;
        if (exists($contents[$$self])) {
            push(@{$contents[$$self]}, $item);
        } else {
            $self->set(\@contents, [ $item ]);
        }
        return $contents[$$self][-1];
    }

    sub peek
    {
        my $self = shift;
        return $contents[$$self][-1];
    }

    sub fetch
    {
        my $self = shift;
        pop(@{$contents[$$self]});
    }
}

package Jar; {
    use Object::InsideOut qw(Container :SHARED);
}

package Baggie; {
    use Object::InsideOut qw(Container :SHARED);
}

# Foreign hash-based class
package Foo; {
    sub new
    {
        my $class = shift;
        threads::shared::share(my %self);
        return (bless(\%self, $class));
    }

    sub set_foo
    {
        my ($self, $key, $value) = @_;
        $self->{$key} = $value;
    }

    sub get_foo
    {
        my ($self, $data) = @_;
        return ($self->{$data});
    }
}

package Cookie; {
    use Object::InsideOut qw(Foo :SHARED);

    my @kind :Field :All(kind);

    sub init :Init
    {
        my ($self, $args) = @_;

        $self->inherit(Foo->new());
    }
}


package main;

MAIN:
{
    my $C1 = 'chocolate chip';
    my $C2 = 'oatmeal raisin';
    my $C3 = 'vanilla wafer';

    my $cookie = Cookie->new('kind' => $C1);
    ok($cookie->kind() eq $C1, 'Have cookie');

    my $jar = Jar->new();
    $jar->store($cookie);

    ok($cookie->kind()      eq $C1, 'Still have cookie');
    ok($jar->peek()->kind() eq $C1, 'Still have cookie');
    ok($cookie->kind()      eq $C1, 'Still have cookie');

    threads->create(sub {
        ok($cookie->kind()      eq $C1, 'Have cookie in thread');
        ok($jar->peek()->kind() eq $C1, 'Still have cookie in thread');
        ok($cookie->kind()      eq $C1, 'Still have cookie in thread');

        $jar->store(Cookie->new('kind' => $C2));
        ok($jar->peek()->kind() eq $C2, 'Added cookie in thread');
    })->join();

    ok($cookie->kind()      eq $C1, 'Still have original cookie after thread');
    ok($jar->peek()->kind() eq $C2, 'Still have added cookie after thread');

    $cookie = $jar->fetch();
    ok($cookie->kind()      eq $C2, 'Fetched cookie from jar');
    ok($jar->peek()->kind() eq $C1, 'Cookie still in jar');

    $cookie = $jar->fetch();
    ok($cookie->kind()      eq $C1, 'Fetched cookie from jar');
    undef($cookie);

    share($cookie);
    $cookie = $jar->store(Cookie->new('kind' => $C3));
    ok($jar->peek()->kind() eq $C3, 'New cookie in jar');
    ok($cookie->kind()      eq $C3, 'Have cookie');

    threads->create(sub {
        ok($cookie->kind()      eq $C3, 'Have cookie in thread');
        $cookie = Cookie->new('kind' => $C1);
        ok($cookie->kind()      eq $C1, 'Change cookie in thread');
        ok($jar->peek()->kind() eq $C3, 'Still have cookie in jar');
    })->join();

    ok($cookie->kind()      eq $C1, 'Have changed cookie after thread');
    ok($jar->peek()->kind() eq $C3, 'Still have cookie in jar');
    undef($cookie);
    ok($jar->peek()->kind() eq $C3, 'Still have cookie in jar');
    $cookie = $jar->fetch();
    ok($cookie->kind()      eq $C3, 'Fetched cookie from jar');

    # Multiple levels of shared objects
    my $baggie = Baggie->new();
    $baggie->store($cookie);
    $jar->store($baggie);
    ok($jar->peek()->peek()->kind() eq $C3, 'Cookie in baggie in jar');

    # Inheritance with shared objects
    $cookie->set_foo('bar' => 99);
    threads->create(sub {
        ok($jar->peek()->peek()->get_foo('bar') == 99, 'Cookie foo in thread');
        $cookie->set_foo('insider' => Cookie->new('kind' => $C2));
        # New cookie
        $cookie = Cookie->new('kind' => $C1);
        # Old cookie in jar
        ok($jar->peek()->peek()->kind() eq $C3, 'Cookie in baggie in jar');
        ok($jar->peek()->peek()->get_foo('bar') == 99, 'Cookie foo in thread');
    })->join();

    ok($jar->peek()->peek()->get_foo('bar') == 99, 'Cookie foo in thread');
    ok($cookie->kind()      eq $C1, 'Have changed cookie after thread');
    ok($jar->peek()->peek()->get_foo('insider')->kind() eq $C2, 'Wow');
}

exit(0);

# EOF