threads::shared 1.15

From: "Jerry D. Hedden" <jdhedden@cpan.org>
Message-ID: <1ff86f510712190717r379ffdbt9ed19b8a607b8931@mail.gmail.com>

p4raw-id: //depot/perl@32658

4 files changed, 177 insertions, 4 deletions

diff --git a/MANIFEST b/MANIFEST
index 24b441e669..69f358da6a 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 b1c0dfff9c..67346856f7 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<http://rt.cpan.org/NoAuth/Bugs.html?Dist=threads-shared>
+to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared>
 
 =head1 SEE ALSO
 
@@ -368,7 +368,7 @@ L<threads::shared> Discussion Forum on CPAN:
 L<http://www.cpanforum.com/dist/threads-shared>
 
 Annotated POD for L<threads::shared>:
-L<http://annocpan.org/~JDHEDDEN/threads-shared-1.14/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-shared-1.15/shared.pm>
 
 Source repository:
 L<http://code.google.com/p/threads-shared/>
diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs
index 39fa02d82a..9e66dfab66 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 0000000000..d244a313d7
--- /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