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

diff --git a/embed.fnc b/embed.fnc
index 8e5c516..2211eb6 100644 (file)
--- 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 eba1305..deb30b3 100644 (file)
--- 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 27623d0..8eab8c8 100644 (file)
--- 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 39cdaf2..4a546c2 100644 (file)
--- 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 5d583f0..373d181 100644 (file)
--- 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 e26e475..b147654 100644 (file)
--- 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 42cac35..05479bf 100644 (file)
--- 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 e74fb85..ab0463f 100644 (file)
--- 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 7fee1dc..a302ec4 100644 (file)
--- 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 f125409..2059512 100644 (file)
--- 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 f12780f..7098088 100644 (file)
--- 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 670c823..62fd7ba 100644 (file)
--- 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)
 {