diff -ruN perl-current/MANIFEST perl-patched/MANIFEST --- perl-current/MANIFEST 2007-11-06 12:56:42.969535800 -0500 +++ perl-patched/MANIFEST 2007-11-06 12:56:48.282613800 -0500 @@ -1116,6 +1116,7 @@ ext/threads/shared/t/hv_refs.t Test shared hashes containing references ext/threads/shared/t/hv_simple.t Tests for basic shared hash functionality. ext/threads/shared/t/no_share.t Tests for disabled share on variables. +ext/threads/shared/t/object.t Tests shared objects in shared structures ext/threads/shared/t/shared_attr.t Test :shared attribute ext/threads/shared/t/stress.t Stress test ext/threads/shared/t/sv_refs.t thread shared variables diff -ruN perl-current/ext/threads/shared/shared.pm perl-patched/ext/threads/shared/shared.pm --- perl-current/ext/threads/shared/shared.pm 2007-11-06 12:56:42.875775600 -0500 +++ perl-patched/ext/threads/shared/shared.pm 2007-11-06 12:56:43.688364000 -0500 @@ -5,7 +5,7 @@ use strict; use warnings; -our $VERSION = '1.14'; +our $VERSION = '1.15'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -73,7 +73,7 @@ =head1 VERSION -This document describes threads::shared version 1.14 +This document describes threads::shared version 1.15 =head1 SYNOPSIS @@ -368,7 +368,7 @@ L Annotated POD for L: -L +L Source repository: L diff -ruN perl-current/ext/threads/shared/shared.xs perl-patched/ext/threads/shared/shared.xs --- perl-current/ext/threads/shared/shared.xs 2007-11-06 12:56:42.875775600 -0500 +++ perl-patched/ext/threads/shared/shared.xs 2007-11-06 12:56:43.688364000 -0500 @@ -1108,6 +1108,24 @@ } +/* Can a shared object be destroyed? + * True if not a shared, + * or if detroying last proxy on a shared object + */ +#ifdef PL_destroyhook +bool +Perl_shared_object_destroy(pTHX_ SV *sv) +{ + SV *ssv; + + if (SvROK(sv)) + sv = SvRV(sv); + ssv = Perl_sharedsv_find(aTHX_ sv); + return (!ssv || (SvREFCNT(ssv) <= 1)); +} +#endif + + /* Saves a space for keeping SVs wider than an interpreter. */ void @@ -1121,6 +1139,9 @@ recursive_lock_init(aTHX_ &PL_sharedsv_lock); PL_lockhook = &Perl_sharedsv_locksv; PL_sharehook = &Perl_sharedsv_share; +#ifdef PL_destroyhook + PL_destroyhook = &Perl_shared_object_destroy; +#endif } #endif /* USE_ITHREADS */ diff -ruN perl-current/ext/threads/shared/t/object.t perl-patched/ext/threads/shared/t/object.t --- perl-current/ext/threads/shared/t/object.t 1969-12-31 19:00:00.000000000 -0500 +++ perl-patched/ext/threads/shared/t/object.t 2007-11-06 12:56:43.907137800 -0500 @@ -0,0 +1,151 @@ +use strict; +use warnings; + +BEGIN { + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + 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..23\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]; # Reaults 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 cooke 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'); + +# EOF