Add ptable_delete to ptable.h

[perl/modules/Variable-Magic.git] / Magic.xs

diff --git a/Magic.xs b/Magic.xs
index c19b2f3cc04fe549a207266dbd417d506355c9b9..2de483fd63c10169fbb789cb5413ca231340ea26 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -12,6 +12,13 @@
 
 #define __PACKAGE__ "Variable::Magic"
 
+#undef VOID2
+#ifdef __cplusplus
+# define VOID2(T, P) static_cast<T>(P)
+#else
+# define VOID2(T, P) (P)
+#endif
+
 #ifndef VMG_PERL_PATCHLEVEL
 # ifdef PERL_PATCHNUM
 #  define VMG_PERL_PATCHLEVEL PERL_PATCHNUM
@@ -79,13 +86,25 @@
 
 STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 #define vmg_clone(P, O) vmg_clone(aTHX_ (P), (O))
+ SV *dupsv;
+
+#if VMG_HAS_PERL(5, 13, 2)
+ CLONE_PARAMS *param = Perl_clone_params_new(owner, aTHX);
+
+ dupsv = sv_dup(sv, param);
+
+ Perl_clone_params_del(param);
+#else
  CLONE_PARAMS param;
 
  param.stashes    = NULL; /* don't need it unless sv is a PVHV */
  param.flags      = 0;
  param.proto_perl = owner;
 
- return SvREFCNT_inc(sv_dup(sv, &param));
+ dupsv = sv_dup(sv, &param);
+#endif
+
+ return SvREFCNT_inc(dupsv);
 }
 
 #endif /* VMG_THREADSAFE */
@@ -148,9 +167,11 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
  * reverted to dev-5.11 as 9cdcb38b */
 #if VMG_HAS_PERL_MAINT(5, 8, 9, 28160) || VMG_HAS_PERL_MAINT(5, 9, 3, 25854) || VMG_HAS_PERL(5, 10, 0)
 # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN
-/* This branch should only apply for perls before the official 5.11.0 release.
- * Makefile.PL takes care of the higher ones. */
-#  define VMG_COMPAT_ARRAY_PUSH_NOLEN 1
+#  if VMG_HAS_PERL(5, 11, 0)
+#   define VMG_COMPAT_ARRAY_PUSH_NOLEN 0
+#  else
+#   define VMG_COMPAT_ARRAY_PUSH_NOLEN 1
+#  endif
 # endif
 # ifndef VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID
 #  define VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID 1
@@ -184,6 +205,12 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
 #endif
 
+#if VMG_HAS_PERL(5, 13, 2)
+# define VMG_COMPAT_GLOB_GET 1
+#else
+# define VMG_COMPAT_GLOB_GET 0
+#endif
+
 /* ... Bug-free mg_magical ................................................. */
 
 /* See the discussion at http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html. This version is specialized to our needs. */
@@ -429,26 +456,35 @@ STATIC void vmg_mgwiz_free(pTHX_ MGWIZ *w) {
  if (!w)
   return;
 
- if (w->cb_data)   SvREFCNT_dec(w->cb_data);
- if (w->cb_get)    SvREFCNT_dec(w->cb_get);
- if (w->cb_set)    SvREFCNT_dec(w->cb_set);
- if (w->cb_len)    SvREFCNT_dec(w->cb_len);
- if (w->cb_clear)  SvREFCNT_dec(w->cb_clear);
- if (w->cb_free)   SvREFCNT_dec(w->cb_free);
+ /* We reach this point in dirty state when ptable_free() is called from the
+  * atexit cleanup callback, and that the global table still holds a live
+  * wizard. This happens before all the SV bodies are freed, so all the wizard
+  * callbacks are still alive (as they are referenced by the undead wizard).
+  * Hence it is safe to decrement their refcount. Later on, the wizard free
+  * callback itself will trigger when the wizard body is reaped, but it will
+  * be skipped as it guards against dirty state - which is good since nothing
+  * has to be done anymore at that point. */
+
+ SvREFCNT_dec(w->cb_data);
+ SvREFCNT_dec(w->cb_get);
+ SvREFCNT_dec(w->cb_set);
+ SvREFCNT_dec(w->cb_len);
+ SvREFCNT_dec(w->cb_clear);
+ SvREFCNT_dec(w->cb_free);
 #if MGf_COPY
- if (w->cb_copy)   SvREFCNT_dec(w->cb_copy);
+ SvREFCNT_dec(w->cb_copy);
 #endif /* MGf_COPY */
 #if 0 /* MGf_DUP */
- if (w->cb_dup)    SvREFCNT_dec(w->cb_dup);
+ SvREFCNT_dec(w->cb_dup);
 #endif /* MGf_DUP */
 #if MGf_LOCAL
- if (w->cb_local)  SvREFCNT_dec(w->cb_local);
+ SvREFCNT_dec(w->cb_local);
 #endif /* MGf_LOCAL */
 #if VMG_UVAR
- if (w->cb_fetch)  SvREFCNT_dec(w->cb_fetch);
- if (w->cb_store)  SvREFCNT_dec(w->cb_store);
- if (w->cb_exists) SvREFCNT_dec(w->cb_exists);
- if (w->cb_delete) SvREFCNT_dec(w->cb_delete);
+ SvREFCNT_dec(w->cb_fetch);
+ SvREFCNT_dec(w->cb_store);
+ SvREFCNT_dec(w->cb_exists);
+ SvREFCNT_dec(w->cb_delete);
 #endif /* VMG_UVAR */
 
  Safefree(w->vtbl);
@@ -514,7 +550,7 @@ STATIC MGWIZ *vmg_mgwiz_clone(pTHX_ const MGWIZ *w) {
 #if VMG_THREADSAFE
 
 #define PTABLE_NAME        ptable
-#define PTABLE_VAL_FREE(V) vmg_mgwiz_free(V)
+#define PTABLE_VAL_FREE(V) vmg_mgwiz_free(VOID2(MGWIZ *, (V)))
 
 #define pPTBL  pTHX
 #define pPTBL_ pTHX_
@@ -544,13 +580,13 @@ START_MY_CXT
 #if VMG_THREADSAFE
 
 STATIC void vmg_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
- my_cxt_t *ud = ud_;
+ my_cxt_t *ud = VOID2(my_cxt_t *, ud_);
  MGWIZ *w;
 
  if (ud->owner == aTHX)
   return;
 
- w = vmg_mgwiz_clone(ent->val);
+ w = vmg_mgwiz_clone(VOID2(MGWIZ *, ent->val));
  if (w)
   ptable_store(ud->wizards, ent->key, w);
 }
@@ -643,7 +679,7 @@ STATIC const MGWIZ *vmg_wizard_mgwiz(pTHX_ const SV *wiz) {
 
  {
   dMY_CXT;
-  return ptable_fetch(MY_CXT.wizards, w);
+  return VOID2(const MGWIZ *, ptable_fetch(MY_CXT.wizards, w));
  }
 }
 
@@ -937,7 +973,7 @@ STATIC void vmg_op_info_init(pTHX_ unsigned int opinfo) {
   case VMG_OP_INFO_OBJECT: {
    dMY_CXT;
    if (!MY_CXT.b__op_stashes[0]) {
-    opclass c;
+    int c;
     require_pv("B.pm");
     for (c = OPc_NULL; c < OPc_MAX; ++c)
      MY_CXT.b__op_stashes[c] = gv_stashpv(vmg_opclassnames[c], 1);
@@ -1058,7 +1094,7 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  if (t < SVt_PVAV) {
   STRLEN l;
 #if VMG_HAS_PERL(5, 9, 3)
-  const U8 *s = SvPV_const(sv, l);
+  const U8 *s = VOID2(const U8 *, VOID2(const void *, SvPV_const(sv, l)));
 #else
   U8 *s = SvPV(sv, l);
 #endif
@@ -1345,6 +1381,7 @@ BOOT:
                     newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
  newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
                     newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
+ newCONSTSUB(stash, "VMG_COMPAT_GLOB_GET", newSVuv(VMG_COMPAT_GLOB_GET));
  newCONSTSUB(stash, "VMG_PERL_PATCHLEVEL", newSVuv(VMG_PERL_PATCHLEVEL));
  newCONSTSUB(stash, "VMG_THREADSAFE",      newSVuv(VMG_THREADSAFE));
  newCONSTSUB(stash, "VMG_FORKSAFE",        newSVuv(VMG_FORKSAFE));
@@ -1360,7 +1397,7 @@ PROTOTYPE: DISABLE
 PREINIT:
  ptable *t;
  U32     had_b__op_stash = 0;
- opclass c;
+ int     c;
 PPCODE:
  {
   my_cxt_t ud;