X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Magic.xs;h=1349a9cf183144402a08efbe1aef84d548a43efb;hb=c77fbf03cffe6f4a24764ba311a9ac1650c08237;hp=9bdcca5b61643abb21f021890247bf1cf2e8b56e;hpb=7f3b1ec01ca3856b1d5670ab9795cf0e91ba8928;p=perl%2Fmodules%2FVariable-Magic.git

diff --git a/Magic.xs b/Magic.xs
index 9bdcca5..1349a9c 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -139,6 +139,12 @@
 # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
 #endif
 
+#if VMG_HAS_PERL(5, 17, 4)
+# define VMG_COMPAT_SCALAR_NOLEN 1
+#else
+# define VMG_COMPAT_SCALAR_NOLEN 0
+#endif
+
 /* Applied to dev-5.9 as 25854, integrated to maint-5.8 as 28160, partially
  * 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)
@@ -181,6 +187,12 @@
 # define VMG_COMPAT_HASH_DELETE_NOUVAR_VOID 0
 #endif
 
+#if VMG_HAS_PERL(5, 17, 0)
+# define VMG_COMPAT_CODE_COPY_CLONE 1
+#else
+# define VMG_COMPAT_CODE_COPY_CLONE 0
+#endif
+
 #if VMG_HAS_PERL(5, 13, 2)
 # define VMG_COMPAT_GLOB_GET 1
 #else
@@ -264,6 +276,35 @@ STATIC OP *vmg_trampoline_bump(pTHX_ vmg_trampoline *t, SV *sv, OP *o) {
 
 #endif /* VMG_NEEDS_TRAMPOLINE */
 
+/* --- Cleaner version of sv_magicext() ------------------------------------ */
+
+STATIC MAGIC *vmg_sv_magicext(pTHX_ SV *sv, SV *obj, const MGVTBL *vtbl, const void *ptr, I32 len) {
+#define vmg_sv_magicext(S, O, V, P, L) vmg_sv_magicext(aTHX_ (S), (O), (V), (P), (L))
+ MAGIC *mg;
+
+ mg = sv_magicext(sv, obj, PERL_MAGIC_ext, vtbl, ptr, len);
+ if (!mg)
+  return NULL;
+
+ mg->mg_private = 0;
+
+ if (vtbl->svt_copy)
+  mg->mg_flags |= MGf_COPY;
+#if MGf_DUP
+ if (vtbl->svt_dup)
+  mg->mg_flags |= MGf_DUP;
+#endif /* MGf_DUP */
+#if MGf_LOCAL
+ if (vtbl->svt_local)
+  mg->mg_flags |= MGf_LOCAL;
+#endif /* MGf_LOCAL */
+
+ if (mg->mg_flags & MGf_REFCOUNTED)
+  SvREFCNT_dec(obj);
+
+ return mg;
+}
+
 /* --- Safe version of call_sv() ------------------------------------------- */
 
 STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), void *ud) {
@@ -273,8 +314,8 @@ STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), vo
  SV *old_err = NULL;
 
  if (SvTRUE(ERRSV)) {
-  old_err = ERRSV;
-  ERRSV   = newSV(0);
+  old_err = newSVsv(ERRSV);
+  sv_setsv(ERRSV, &PL_sv_undef);
  }
 
  cxix     = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX);
@@ -287,11 +328,8 @@ STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), vo
  cxstack[cxix] = saved_cx;
 
  if (SvTRUE(ERRSV)) {
-  if (old_err) {
-   sv_setsv(old_err, ERRSV);
-   SvREFCNT_dec(ERRSV);
-   ERRSV = old_err;
-  }
+  SvREFCNT_dec(old_err);
+
   if (IN_PERL_COMPILETIME) {
    if (!PL_in_eval) {
     if (PL_errors)
@@ -314,8 +352,8 @@ STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), vo
   }
  } else {
   if (old_err) {
-   SvREFCNT_dec(ERRSV);
-   ERRSV = old_err;
+   sv_setsv(ERRSV, old_err);
+   SvREFCNT_dec(old_err);
   }
  }
 
@@ -325,19 +363,22 @@ STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, int (*cleanup)(pTHX_ void *), vo
 /* --- Stolen chunk of B --------------------------------------------------- */
 
 typedef enum {
- OPc_NULL   = 0,
- OPc_BASEOP = 1,
- OPc_UNOP   = 2,
- OPc_BINOP  = 3,
- OPc_LOGOP  = 4,
- OPc_LISTOP = 5,
- OPc_PMOP   = 6,
- OPc_SVOP   = 7,
- OPc_PADOP  = 8,
- OPc_PVOP   = 9,
- OPc_LOOP   = 10,
- OPc_COP    = 11,
- OPc_MAX    = 12
+ OPc_NULL,
+ OPc_BASEOP,
+ OPc_UNOP,
+ OPc_BINOP,
+ OPc_LOGOP,
+ OPc_LISTOP,
+ OPc_PMOP,
+ OPc_SVOP,
+ OPc_PADOP,
+ OPc_PVOP,
+ OPc_LOOP,
+ OPc_COP,
+#if VMG_HAS_PERL(5, 21, 5)
+ OPc_METHOP,
+#endif
+ OPc_MAX
 } opclass;
 
 STATIC const char *const vmg_opclassnames[] = {
@@ -352,7 +393,11 @@ STATIC const char *const vmg_opclassnames[] = {
  "B::PADOP",
  "B::PVOP",
  "B::LOOP",
- "B::COP"
+ "B::COP",
+#if VMG_HAS_PERL(5, 21, 5)
+ "B::METHOP",
+#endif
+ NULL
 };
 
 STATIC opclass vmg_opclass(const OP *o) {
@@ -424,6 +469,10 @@ STATIC opclass vmg_opclass(const OP *o) {
     return OPc_BASEOP;
    else
     return OPc_PVOP;
+#if VMG_HAS_PERL(5, 21, 5)
+  case OA_METHOP:
+   return OPc_METHOP;
+#endif
  }
 
  return OPc_BASEOP;
@@ -684,14 +733,8 @@ STATIC SV *vmg_wizard_sv_new(pTHX_ const vmg_wizard *w) {
  wiz = newSViv(PTR2IV(w));
 #endif
 
- if (w) {
-  MAGIC *mg = sv_magicext(wiz, NULL, PERL_MAGIC_ext, &vmg_wizard_sv_vtbl,
-                                     (const char *) w, 0);
-  mg->mg_private = 0;
-#if VMG_THREADSAFE
-  mg->mg_flags  |= MGf_DUP;
-#endif
- }
+ vmg_sv_magicext(wiz, NULL, &vmg_wizard_sv_vtbl, w, 0);
+
  SvREADONLY_on(wiz);
 
  return wiz;
@@ -880,22 +923,7 @@ STATIC UV vmg_cast(pTHX_ SV *sv, const vmg_wizard *w, const SV *wiz, SV **args,
  data = (w->cb_data) ? vmg_data_new(w->cb_data, sv, args, items) : NULL;
 
  t  = vmg_vtable_vtbl(w->vtable);
- mg = sv_magicext(sv, data, PERL_MAGIC_ext, t, (const char *) wiz, HEf_SVKEY);
- mg->mg_private = 0;
-
- /* sv_magicext() calls mg_magical and increments data's refcount */
- SvREFCNT_dec(data);
-
- if (t->svt_copy)
-  mg->mg_flags |= MGf_COPY;
-#if 0
- if (t->svt_dup)
-  mg->mg_flags |= MGf_DUP;
-#endif
-#if MGf_LOCAL
- if (t->svt_local)
-  mg->mg_flags |= MGf_LOCAL;
-#endif /* MGf_LOCAL */
+ mg = vmg_sv_magicext(sv, data, t, wiz, HEf_SVKEY);
 
  if (SvTYPE(sv) < SVt_PVHV)
   goto done;
@@ -1161,8 +1189,7 @@ STATIC SV *vmg_dispell_guard_new(pTHX_ MAGIC *root) {
  SV *guard;
 
  guard = sv_newmortal();
- sv_magicext(guard, NULL, PERL_MAGIC_ext, &vmg_dispell_guard_vtbl,
-                          (char *) root, 0);
+ vmg_sv_magicext(guard, NULL, &vmg_dispell_guard_vtbl, root, 0);
 
  return guard;
 }
@@ -1355,8 +1382,8 @@ STATIC OP *vmg_pp_propagate_errsv(pTHX) {
  SVOP *o = cSVOPx(PL_op);
 
  if (o->op_sv) {
-  SvREFCNT_dec(ERRSV);
-  ERRSV    = o->op_sv;
+  sv_setsv(ERRSV, o->op_sv);
+  SvREFCNT_dec(o->op_sv);
   o->op_sv = NULL;
  }
 
@@ -1366,11 +1393,8 @@ STATIC OP *vmg_pp_propagate_errsv(pTHX) {
 #endif /* VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */
 
 STATIC int vmg_propagate_errsv_free(pTHX_ SV *sv, MAGIC *mg) {
- if (mg->mg_obj) {
-  ERRSV         = mg->mg_obj;
-  mg->mg_obj    = NULL;
-  mg->mg_flags &= ~MGf_REFCOUNTED;
- }
+ if (mg->mg_obj)
+  sv_setsv(ERRSV, mg->mg_obj);
 
  return 0;
 }
@@ -1415,20 +1439,16 @@ STATIC int vmg_svt_free_cleanup(pTHX_ void *ud_) {
     PL_op = vmg_trampoline_bump(&MY_CXT.propagate_errsv, errsv, PL_op);
    } else if (optype == OP_LEAVEEVAL) {
     SV *guard = sv_newmortal();
-    sv_magicext(guard, errsv, PERL_MAGIC_ext, &vmg_propagate_errsv_vtbl,
-                              NULL, 0);
+    vmg_sv_magicext(guard, errsv, &vmg_propagate_errsv_vtbl, NULL, 0);
    }
 #else /* !VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */
 # if !VMG_HAS_PERL(5, 8, 9)
    {
     SV *guard = sv_newmortal();
-    sv_magicext(guard, errsv, PERL_MAGIC_ext, &vmg_propagate_errsv_vtbl,
-                              NULL, 0);
+    vmg_sv_magicext(guard, errsv, &vmg_propagate_errsv_vtbl, NULL, 0);
    }
 # else
-   sv_magicext(ERRSV, errsv, PERL_MAGIC_ext, &vmg_propagate_errsv_vtbl,
-                             NULL, 0);
-   SvREFCNT_dec(errsv);
+   vmg_sv_magicext(ERRSV, errsv, &vmg_propagate_errsv_vtbl, NULL, 0);
 # endif
 #endif /* VMG_PROPAGATE_ERRSV_NEEDS_TRAMPOLINE */
 
@@ -1554,6 +1574,9 @@ STATIC int vmg_svt_copy(pTHX_ SV *sv, MAGIC *mg, SV *nsv, const char *key, VMG_S
   keysv = newSVpvn(key, keylen);
  }
 
+ if (SvTYPE(sv) >= SVt_PVCV)
+  nsv = sv_2mortal(newRV_inc(nsv));
+
  ret = vmg_cb_call3(w->cb_copy, w->opinfo, sv, mg->mg_obj, keysv, nsv);
 
  if (keylen != HEf_SVKEY) {
@@ -1799,6 +1822,8 @@ BOOT:
  newCONSTSUB(stash, "VMG_UVAR",  newSVuv(VMG_UVAR));
  newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
                     newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
+ newCONSTSUB(stash, "VMG_COMPAT_SCALAR_NOLEN",
+                    newSVuv(VMG_COMPAT_SCALAR_NOLEN));
  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN",
                     newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN));
  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID",
@@ -1809,6 +1834,8 @@ BOOT:
                     newSVuv(VMG_COMPAT_ARRAY_UNDEF_CLEAR));
  newCONSTSUB(stash, "VMG_COMPAT_HASH_DELETE_NOUVAR_VOID",
                     newSVuv(VMG_COMPAT_HASH_DELETE_NOUVAR_VOID));
+ newCONSTSUB(stash, "VMG_COMPAT_CODE_COPY_CLONE",
+                    newSVuv(VMG_COMPAT_CODE_COPY_CLONE));
  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));