Bug fix for storing shared objects in shared structures

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

(core patch only)

p4raw-id: //depot/perl@32241

12 files changed, 51 insertions, 1 deletions

diff --git a/embed.fnc b/embed.fnc
index 8e5c516156..2211eb6cb6 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1114,6 +1114,7 @@ ApR	|const char *	|custom_op_desc	|NN const OP* op
 
 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
diff --git a/embed.h b/embed.h
index eba13051de..deb30b3e94 100644
--- a/embed.h
+++ b/embed.h
@@ -1108,6 +1108,7 @@
 #define custom_op_name		Perl_custom_op_name
 #define custom_op_desc		Perl_custom_op_desc
 #define sv_nosharing		Perl_sv_nosharing
+#define sv_destroyable		Perl_sv_destroyable
 #ifdef NO_MATHOMS
 #else
 #define sv_nounlocking		Perl_sv_nounlocking
@@ -3386,6 +3387,7 @@
 #define custom_op_name(a)	Perl_custom_op_name(aTHX_ a)
 #define custom_op_desc(a)	Perl_custom_op_desc(aTHX_ a)
 #define sv_nosharing(a)		Perl_sv_nosharing(aTHX_ a)
+#define sv_destroyable(a)	Perl_sv_destroyable(aTHX_ a)
 #ifdef NO_MATHOMS
 #else
 #define sv_nounlocking(a)	Perl_sv_nounlocking(aTHX_ a)
diff --git a/embedvar.h b/embedvar.h
index 27623d0349..8eab8c8d63 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -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
diff --git a/global.sym b/global.sym
index 39cdaf293b..4a546c280c 100644
--- a/global.sym
+++ b/global.sym
@@ -693,6 +693,7 @@ Perl_custom_op_name
 Perl_custom_op_desc
 Perl_sv_nosharing
 Perl_sv_nolocking
+Perl_sv_destroyable
 Perl_sv_nounlocking
 Perl_nothreadhook
 Perl_Slab_Alloc
diff --git a/intrpvar.h b/intrpvar.h
index 5d583f06f0..373d181792 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -669,6 +669,9 @@ PERLVARI(Islabs, I32**, NULL)	/* Array of slabs that have been allocated */
 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.  */
 
diff --git a/perl.h b/perl.h
index e26e475bfb..b147654abd 100644
--- a/perl.h
+++ b/perl.h
@@ -4036,6 +4036,7 @@ typedef int (CPERLscope(*runops_proc_t)) (pTHX);
 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!@"
diff --git a/perlapi.h b/perlapi.h
index 42cac3591c..05479bf9d3 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -266,6 +266,8 @@ END_EXTERN_C
 #define PL_defstash		(*Perl_Idefstash_ptr(aTHX))
 #undef  PL_delaymagic
 #define PL_delaymagic		(*Perl_Idelaymagic_ptr(aTHX))
+#undef  PL_destroyhook
+#define PL_destroyhook		(*Perl_Idestroyhook_ptr(aTHX))
 #undef  PL_diehook
 #define PL_diehook		(*Perl_Idiehook_ptr(aTHX))
 #undef  PL_dirty
diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index e74fb85668..ab0463f9a3 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -2594,6 +2594,19 @@ wrapper for C<strncmp>).
 =for hackers
 Found in file handy.h
 
+=item sv_destroyable
+X<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.
+
+	bool	sv_destroyable(SV *sv)
+
+=for hackers
+Found in file util.c
+
 =item sv_nosharing
 X<sv_nosharing>
 
diff --git a/proto.h b/proto.h
index 7fee1dc0c6..a302ec43a3 100644
--- a/proto.h
+++ b/proto.h
@@ -2972,6 +2972,7 @@ PERL_CALLCONV const char *	Perl_custom_op_desc(pTHX_ const OP* op)
 
 PERL_CALLCONV void	Perl_sv_nosharing(pTHX_ SV *sv);
 /* PERL_CALLCONV void	Perl_sv_nolocking(pTHX_ SV *sv); */
+PERL_CALLCONV bool	Perl_sv_destroyable(pTHX_ SV *sv);
 #ifdef NO_MATHOMS
 /* PERL_CALLCONV void	Perl_sv_nounlocking(pTHX_ SV *sv); */
 #else
diff --git a/sv.c b/sv.c
index f125409ced..20595124ff 100644
--- a/sv.c
+++ b/sv.c
@@ -5098,7 +5098,9 @@ Perl_sv_clear(pTHX_ register SV *sv)
     }
 
     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 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     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;
diff --git a/sv.h b/sv.h
index f12780f04c..7098088463 100644
--- a/sv.h
+++ b/sv.h
@@ -2008,6 +2008,7 @@ Returns a pointer to the character buffer.
 #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
diff --git a/util.c b/util.c
index 670c823867..62fd7baaa5 100644
--- a/util.c
+++ b/util.c
@@ -5112,6 +5112,26 @@ Perl_sv_nosharing(pTHX_ SV *sv)
     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)
 {