view release on metacpan or  search on metacpan

dist/threads-shared/t/object.t  view on Meta::CPAN

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);