xref: /openbsd-src/gnu/usr.bin/perl/dist/threads-shared/t/object.t (revision 898184e3e61f9129feb5978fad5a8c6865f00b92)

use strict;
use warnings;

BEGIN {
    use Config;
    if (! $Config{'useithreads'}) {
        print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
        exit(0);
    }
    if ($] < 5.010) {
        print("1..0 # SKIP Needs Perl 5.10.0 or later\n");
        exit(0);
    }
}

use ExtUtils::testlib;

BEGIN {
    $| = 1;
    print("1..28\n");   ### Number of tests that will be run ###
};

use threads;
use threads::shared;

my $TEST;
BEGIN {
    share($TEST);
    $TEST = 1;
}

sub ok {
    my ($ok, $name) = @_;

    lock($TEST);
    my $id = $TEST++;

    # You have to do it this way or VMS will get confused.
    if ($ok) {
        print("ok $id - $name\n");
    } else {
        print("not ok $id - $name\n");
        printf("# Failed test at line %d\n", (caller)[2]);
    }

    return ($ok);
}

ok(1, 'Loaded');

### Start of Testing ###

{ package Jar;
    my @jar :shared;

    sub new
    {
        bless(&threads::shared::share({}), shift);
    }

    sub store
    {
        my ($self, $cookie) = @_;
        push(@jar, $cookie);
        return $jar[-1];        # Results in destruction of proxy object
    }

    sub peek
    {
        return $jar[-1];
    }

    sub fetch
    {
        pop(@jar);
    }
}

{ package Cookie;

    sub new
    {
        my $self = bless(&threads::shared::share({}), shift);
        $self->{'type'} = shift;
        return $self;
    }

    sub DESTROY
    {
        delete(shift->{'type'});
    }
}

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

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

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

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

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

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

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

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

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

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

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

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

{ package Foo;

    my $ID = 1;
    threads::shared::share($ID);

    sub new
    {
        # Anonymous scalar with an internal ID
        my $obj = \do{ my $scalar = $ID++; };
        threads::shared::share($obj);   # Make it shared
        return (bless($obj, 'Foo'));    # Make it an object
    }
}

my $obj :shared;
$obj = Foo->new();
ok($$obj == 1, "Main: Object ID $$obj");

threads->create( sub {
        ok($$obj == 1, "Thread: Object ID $$obj");

        $$obj = 10;
        ok($$obj == 10, "Thread: Changed object ID $$obj");

        $obj = Foo->new();
        ok($$obj == 2, "Thread: New object ID $$obj");
    } )->join();

# Fixed by commit bb1bc619ea68d9703fbd3fe5bc65ae000f90151f
my $todo = ($] <= 5.013001) ? "  # TODO - should be 2" : "";
ok($$obj == 2, "Main: New object ID $$obj".$todo);

exit(0);

# EOF