[PATCH] Bug fix for storing shared objects in shared structures

--- /var/tmp/perl-current/embed.fnc	2007-11-05 09:54:57.960224400 -0500
+++ perl-current/embed.fnc	2007-11-06 10:54:15.760124700 -0500
@@ -1114,6 +1114,7 @@
 
 Adp	|void	|sv_nosharing	|NULLOK SV *sv
 Adpbm	|void	|sv_nolocking	|NULLOK SV *sv
+Adp	|bool	|sv_destroyable	|NULLOK SV *sv
 #ifdef NO_MATHOMS
 Adpbm	|void	|sv_nounlocking	|NULLOK SV *sv
 #else
--- /var/tmp/perl-current/embedvar.h	2007-10-19 16:17:53.129568500 -0400
+++ perl-current/embedvar.h	2007-11-06 10:58:48.425178300 -0500
@@ -115,6 +115,7 @@
 #define PL_defoutgv		(vTHX->Idefoutgv)
 #define PL_defstash		(vTHX->Idefstash)
 #define PL_delaymagic		(vTHX->Idelaymagic)
+#define PL_destroyhook		(vTHX->Idestroyhook)
 #define PL_diehook		(vTHX->Idiehook)
 #define PL_dirty		(vTHX->Idirty)
 #define PL_doextract		(vTHX->Idoextract)
@@ -427,6 +428,7 @@
 #define PL_Idefoutgv		PL_defoutgv
 #define PL_Idefstash		PL_defstash
 #define PL_Idelaymagic		PL_delaymagic
+#define PL_Idestroyhook		PL_destroyhook
 #define PL_Idiehook		PL_diehook
 #define PL_Idirty		PL_dirty
 #define PL_Idoextract		PL_doextract
--- /var/tmp/perl-current/intrpvar.h	2007-10-19 16:18:19.813159500 -0400
+++ perl-current/intrpvar.h	2007-11-06 10:58:42.893432700 -0500
@@ -663,6 +663,9 @@
 PERLVARI(Islab_count, U32, 0)	/* Size of the array */
 #endif
 
+/* Can shared object be destroyed */
+PERLVARI(Idestroyhook, destroyable_proc_t, MEMBER_TO_FPTR(Perl_sv_destroyable))
+
 /* If you are adding a U8 or U16, check to see if there are 'Space' comments
  * above on where there are gaps which currently will be structure padding.  */
 
--- /var/tmp/perl-current/perl.h	2007-11-05 09:54:57.991513600 -0500
+++ perl-current/perl.h	2007-11-06 10:58:27.673319100 -0500
@@ -4036,6 +4036,7 @@
 typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv);
 typedef int  (CPERLscope(*thrhook_proc_t)) (pTHX);
 typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX);
+typedef bool (CPERLscope(*destroyable_proc_t)) (pTHX_ SV *sv);
 
 /* _ (for $_) must be first in the following list (DEFSV requires it) */
 #define THREADSV_NAMES "_123456789&`'+/.,\\\";^-%=|~:\001\005!@"
--- /var/tmp/perl-current/sv.c	2007-11-05 09:54:16.390226900 -0500
+++ perl-current/sv.c	2007-11-06 13:09:30.287385900 -0500
@@ -5098,7 +5098,9 @@
     }
 
     if (SvOBJECT(sv)) {
-	if (PL_defstash) {		/* Still have a symbol table? */
+	if (PL_defstash &&	/* Still have a symbol table? */
+	    SvDESTROYABLE(sv))
+	{
 	    dSP;
 	    HV* stash;
 	    do {	
@@ -11365,6 +11367,7 @@
     PL_lockhook		= proto_perl->Ilockhook;
     PL_unlockhook	= proto_perl->Iunlockhook;
     PL_threadhook	= proto_perl->Ithreadhook;
+    PL_destroyhook	= proto_perl->Idestroyhook;
 
 #ifdef THREADS_HAVE_PIDS
     PL_ppid		= proto_perl->Ippid;
--- /var/tmp/perl-current/sv.h	2007-10-19 16:18:23.913511900 -0400
+++ perl-current/sv.h	2007-11-05 12:42:48.390289600 -0500
@@ -2008,6 +2008,7 @@
 #define SvSHARE(sv) CALL_FPTR(PL_sharehook)(aTHX_ sv)
 #define SvLOCK(sv) CALL_FPTR(PL_lockhook)(aTHX_ sv)
 #define SvUNLOCK(sv) CALL_FPTR(PL_unlockhook)(aTHX_ sv)
+#define SvDESTROYABLE(sv) CALL_FPTR(PL_destroyhook)(aTHX_ sv)
 
 #define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
 #define SvSETMAGIC(x) STMT_START { if (SvSMAGICAL(x)) mg_set(x); } STMT_END
--- /var/tmp/perl-current/util.c	2007-10-25 09:07:11.210225100 -0400
+++ perl-current/util.c	2007-11-06 10:46:33.499959900 -0500
@@ -5112,6 +5112,26 @@
     PERL_UNUSED_ARG(sv);
 }
 
+/*
+
+=for apidoc sv_destroyable
+
+Dummy routine which reports that object can be destroyed when there is no
+sharing module present.  It ignores its single SV argument, and returns
+'true'.  Exists to avoid test for a NULL function pointer and because it
+could potentially warn under some level of strict-ness.
+
+=cut
+*/
+
+bool
+Perl_sv_destroyable(pTHX_ SV *sv)
+{
+    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(sv);
+    return TRUE;
+}
+
 U32
 Perl_parse_unicode_opts(pTHX_ const char **popt)
 {

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