From: Vincent Pit <vince@profvince.com>
Date: Fri, 25 Jun 2010 20:05:22 +0000 (+0200)
Subject: Always use a safe version of call_sv()
X-Git-Tag: v0.43~5
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=9dce2bfe18bcd7d9914310c81b8832d40fb04fbb

Always use a safe version of call_sv()

All the relevant code has been factored out of vmg_cb_free() into a new
vmg_call_sv() function.
---

diff --git a/Magic.xs b/Magic.xs
index 0cfce8c..c19b2f3 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -136,16 +136,6 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
 #endif
 
-#if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser)
-# ifndef PL_error_count
-#  define PL_error_count PL_parser->error_count
-# endif
-#else
-# ifndef PL_error_count
-#  define PL_error_count PL_Ierror_count
-# endif
-#endif
-
 /* uvar magic and Hash::Util::FieldHash were commited with 28419, but we only
  * enable them on 5.10 */
 #if VMG_HAS_PERL(5, 10, 0)
@@ -194,9 +184,12 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 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. */
+
 #if VMG_UVAR
 
-/* Bug-free mg_magical - see http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00036.html - but specialized to our needs. */
 STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) {
 #define vmg_sv_magicuvar(S, U, L) vmg_sv_magicuvar(aTHX_ (S), (U), (L))
  const MAGIC* mg;
@@ -218,6 +211,75 @@ STATIC void vmg_sv_magicuvar(pTHX_ SV *sv, const char *uf, I32 len) {
 
 #endif /* VMG_UVAR */
 
+/* ... Safe version of call_sv() ........................................... */
+
+#define VMG_SAVE_LAST_CX (!VMG_HAS_PERL(5, 8, 4) || VMG_HAS_PERL(5, 9, 5))
+
+STATIC I32 vmg_call_sv(pTHX_ SV *sv, I32 flags, I32 destructor) {
+#define vmg_call_sv(S, F, D) vmg_call_sv(aTHX_ (S), (F), (D))
+ I32 ret, cxix = 0, in_eval = 0;
+#if VMG_SAVE_LAST_CX
+ PERL_CONTEXT saved_cx;
+#endif
+ SV *old_err = NULL;
+
+ if (SvTRUE(ERRSV)) {
+  old_err = ERRSV;
+  ERRSV   = newSV(0);
+ }
+
+ if (cxstack_ix < cxstack_max) {
+  cxix = cxstack_ix + 1;
+  if (destructor && CxTYPE(cxstack + cxix) == CXt_EVAL)
+   in_eval = 1;
+ }
+
+#if VMG_SAVE_LAST_CX
+ /* The last popped context will be reused by call_sv(), but our callers may
+  * still need its previous value. Back it up so that it isn't clobbered. */
+ saved_cx = cxstack[cxix];
+#endif
+
+ ret = call_sv(sv, flags | G_EVAL);
+
+#if VMG_SAVE_LAST_CX
+ cxstack[cxix] = saved_cx;
+#endif
+
+ if (SvTRUE(ERRSV)) {
+  if (old_err) {
+   sv_setsv(old_err, ERRSV);
+   SvREFCNT_dec(ERRSV);
+   ERRSV = old_err;
+  }
+  if (IN_PERL_COMPILETIME) {
+   if (!PL_in_eval) {
+    if (PL_errors)
+     sv_catsv(PL_errors, ERRSV);
+    else
+     Perl_warn(aTHX_ "%s", SvPV_nolen(ERRSV));
+    SvCUR_set(ERRSV, 0);
+   }
+#if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser)
+   if (PL_parser)
+    ++PL_parser->error_count;
+#elif defined(PL_error_count)
+   ++PL_error_count;
+#else
+   ++PL_Ierror_count;
+#endif
+   } else if (!in_eval)
+    croak(NULL);
+ } else {
+  if (old_err) {
+   SvREFCNT_dec(ERRSV);
+   ERRSV = old_err;
+  }
+ }
+
+ return ret;
+}
+
 /* --- Stolen chunk of B --------------------------------------------------- */
 
 typedef enum {
@@ -632,7 +694,7 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, SV **args, I32 items) {
   PUSHs(args[i]);
  PUTBACK;
 
- call_sv(ctor, G_SCALAR);
+ vmg_call_sv(ctor, G_SCALAR, 0);
 
  SPAGAIN;
  nsv = POPs;
@@ -943,7 +1005,7 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) {
   XPUSHs(vmg_op_info(opinfo));
  PUTBACK;
 
- call_sv(cb, G_SCALAR);
+ vmg_call_sv(cb, G_SCALAR, 0);
 
  SPAGAIN;
  svr = POPs;
@@ -1016,7 +1078,7 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
   XPUSHs(vmg_op_info(opinfo));
  PUTBACK;
 
- call_sv(w->cb_len, G_SCALAR);
+ vmg_call_sv(w->cb_len, G_SCALAR, 0);
 
  SPAGAIN;
  svr = POPs;
@@ -1038,12 +1100,8 @@ STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
 
 STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
  const MGWIZ *w;
- I32 cxix = 0, in_eval = 0;
-#if VMG_HAS_PERL(5, 9, 5)
- PERL_CONTEXT saved_cx;
-#endif
  int ret = 0;
- SV *svr, *old_err = NULL;
+ SV *svr;
 
  dSP;
 
@@ -1075,56 +1133,7 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
   XPUSHs(vmg_op_info(w->opinfo));
  PUTBACK;
 
- if (SvTRUE(ERRSV)) {
-  old_err = ERRSV;
-  ERRSV   = newSV(0);
- }
-
- if (cxstack_ix < cxstack_max) {
-  cxix = cxstack_ix + 1;
-  if (CxTYPE(cxstack + cxix) == CXt_EVAL)
-   in_eval = 1;
- }
-
-#if VMG_HAS_PERL(5, 9, 5)
- /* This context should not be used anymore, but since we croak in places the
-  * core doesn't even dare to, some pointers to it may remain in the upper call
-  * stack. Make sure call_sv() doesn't clobber it. */
- saved_cx = cxstack[cxix];
-#endif
-
- call_sv(w->cb_free, G_SCALAR | G_EVAL);
-
-#if VMG_HAS_PERL(5, 9, 5)
- cxstack[cxix] = saved_cx;
-#endif
-
- if (SvTRUE(ERRSV)) {
-  if (old_err) {
-   sv_setsv(old_err, ERRSV);
-   SvREFCNT_dec(ERRSV);
-   ERRSV = old_err;
-  }
-  if (IN_PERL_COMPILETIME) {
-   if (!PL_in_eval) {
-    if (PL_errors)
-     sv_catsv(PL_errors, ERRSV);
-    else
-     Perl_warn(aTHX_ "%s", SvPV_nolen(ERRSV));
-    SvCUR_set(ERRSV, 0);
-   }
-#ifdef PL_parser
-   if (PL_parser)
-#endif
-    ++PL_error_count;
-  } else if (!in_eval)
-   croak(NULL);
- } else {
-  if (old_err) {
-   SvREFCNT_dec(ERRSV);
-   ERRSV = old_err;
-  }
- }
+ vmg_call_sv(w->cb_free, G_SCALAR, 1);
 
  SPAGAIN;
  svr = POPs;
diff --git a/t/14-callbacks.t b/t/14-callbacks.t
index c599b2f..91ee3bd 100644
--- a/t/14-callbacks.t
+++ b/t/14-callbacks.t
@@ -59,20 +59,20 @@ cast $b, $wiz;
 
 my $u = $b;
 is_deeply(\@callers, [
- [ 'main', $0, __LINE__-2 ],
+ ([ 'main', $0, __LINE__-2 ]) x 2,
 ], 'caller into callback returns the right thing');
 
 @callers = ();
 $u = $b;
 is_deeply(\@callers, [
- [ 'main', $0, __LINE__-2 ],
+ ([ 'main', $0, __LINE__-2 ]) x 2,
 ], 'caller into callback returns the right thing (second time)');
 
 {
  @callers = ();
  my $u = $b;
  is_deeply(\@callers, [
-  [ 'main', $0, __LINE__-2 ],
+  ([ 'main', $0, __LINE__-2 ]) x 2,
  ], 'caller into callback into block returns the right thing');
 }
 
@@ -80,6 +80,6 @@ is_deeply(\@callers, [
 eval { my $u = $b };
 is($@, '', 'caller into callback doesn\'t croak');
 is_deeply(\@callers, [
- ([ 'main', $0, __LINE__-3 ]) x 2,
+ ([ 'main', $0, __LINE__-3 ]) x 3,
 ], 'caller into callback into eval returns the right thing');
 
diff --git a/t/30-scalar.t b/t/30-scalar.t
index 839cf58..f6faea4 100644
--- a/t/30-scalar.t
+++ b/t/30-scalar.t
@@ -106,8 +106,6 @@ SKIP: {
 
  unless (MGf_COPY) {
   $SKIP = 'No copy magic for this perl';
- } elsif ($Config{useithreads} and $] le 5.008003) {
-  $SKIP = 'Causes havoc during global destruction for old threaded perls';
  } else {
   eval "use Tie::Array";
   $SKIP = 'Tie::Array required to test clear magic on tied array values' if $@;