From: Jerry D. Hedden Date: Wed, 19 Dec 2007 10:17:46 +0000 (-0500) Subject: threads::shared 1.15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=794f4697121b50d7447d6309d7c9ada4bca913e2;p=p5sagit%2Fp5-mst-13.2.git threads::shared 1.15 From: "Jerry D. Hedden" Message-ID: <1ff86f510712190717r379ffdbt9ed19b8a607b8931@mail.gmail.com> p4raw-id: //depot/perl@32658 --- diff --git a/MANIFEST b/MANIFEST index 24b441e..69f358d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1119,6 +1119,7 @@ ext/threads/shared/t/disabled.t Test threads::shared when threads are disabled. 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 Shared objects tests 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 --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm index b1c0dff..6734685 100644 --- a/ext/threads/shared/shared.pm +++ b/ext/threads/shared/shared.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '1.14'; +our $VERSION = '1.15'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -73,7 +73,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.14 +This document describes threads::shared version 1.15 =head1 SYNOPSIS @@ -360,7 +360,7 @@ error "locking can only be used on shared values" to occur when you attempt to C<< lock($hasref->{key}) >>. View existing bug reports at, and submit any new bugs, problems, patches, etc. -to: L +to: L =head1 SEE ALSO @@ -368,7 +368,7 @@ L Discussion Forum on CPAN: L Annotated POD for L: -L +L Source repository: L diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index 39fa02d..9e66dfa 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -1108,6 +1108,24 @@ Perl_sharedsv_locksv(pTHX_ SV *sv) } +/* 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 @@ Perl_sharedsv_init(pTHX) 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 --git a/ext/threads/shared/t/object.t b/ext/threads/shared/t/object.t new file mode 100644 index 0000000..d244a31 --- /dev/null +++ b/ext/threads/shared/t/object.t @@ -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]; # 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'); + +# EOF