Fix segfaults when using get or uvar magic simultaneously with clear magic

diff --git a/Magic.xs b/Magic.xs
index 44d6c88202bc9e33377153cbdb6260953d0126f2..73536b861649b32eb497cc082f611ba15e567fdc 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -89,6 +89,10 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define Newx(v, n, c) New(0, v, n, c)
 #endif
 
+#ifndef NewOp
+# define NewOp(m, var, c, type) Newz(m, var, c, type)
+#endif
+
 #ifndef SvMAGIC_set
 # define SvMAGIC_set(sv, val) (SvMAGIC(sv) = (val))
 #endif
@@ -101,6 +105,10 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define PERL_MAGIC_ext '~'
 #endif
 
+#ifndef PERL_MAGIC_tied
+# define PERL_MAGIC_tied 'P'
+#endif
+
 #ifndef MGf_COPY
 # define MGf_COPY 0
 #endif
@@ -344,8 +352,11 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
   mg->mg_flags |= MGf_LOCAL;
 #endif /* MGf_LOCAL */
 
+ if (SvTYPE(sv) < SVt_PVHV)
+  goto done;
+
 #if VMG_UVAR
- if (w->uvar && SvTYPE(sv) >= SVt_PVHV) {
+ if (w->uvar) {
   MAGIC *prevmagic;
   int add_uvar = 1;
   struct ufuncs uf[2];
@@ -373,15 +384,20 @@ STATIC UV vmg_cast(pTHX_ SV *sv, SV *wiz, AV *args) {
     uf[1] = *olduf;
     vmg_uvar_del(sv, prevmagic, mg, moremagic);
    }
-  }
+  } else if (w->cb_get)
+   SvGMAGICAL_off(sv);
 
   if (add_uvar) {
    vmg_sv_magicuvar(sv, (const char *) &uf, sizeof(uf));
   }
 
  }
+#else
+ if (w->cb_get)
+  SvGMAGICAL_off(sv);
 #endif /* VMG_UVAR */
 
+done:
  return 1;
 }
 
@@ -636,10 +652,16 @@ STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
 #endif /* MGf_LOCAL */
 
 #if VMG_UVAR
+STATIC OP *vmg_pp_resetuvar(pTHX) {
+ SvRMAGICAL_on(cSVOP_sv);
+ return NORMAL;
+}
+
 STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
  struct ufuncs *uf;
  MAGIC *mg, *umg;
  SV *key = NULL, *newkey = NULL;
+ int tied = 0;
 
  umg = mg_find(sv, PERL_MAGIC_uvar);
  /* umg can't be NULL or we wouldn't be there. */
@@ -652,9 +674,17 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
  action &= HV_FETCH_ISSTORE | HV_FETCH_ISEXISTS | HV_FETCH_LVALUE | HV_DELETE;
  for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
   MGWIZ *w;
-  if ((mg->mg_type != PERL_MAGIC_ext)
-   || (mg->mg_private < SIG_MIN)
-   || (mg->mg_private > SIG_MAX)) { continue; }
+  switch (mg->mg_type) {
+   case PERL_MAGIC_ext:
+    break;
+   case PERL_MAGIC_tied:
+    ++tied;
+    continue;
+   default:
+    continue;
+  }
+  if (mg->mg_private < SIG_MIN || mg->mg_private > SIG_MAX)
+   continue;
   w = SV2MGWIZ(mg->mg_ptr);
   switch (w->uvar) {
    case 0:
@@ -681,6 +711,25 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
   }
  }
 
+ if (SvRMAGICAL(sv) && !tied) {
+  /* Temporarily hide the RMAGICAL flag of the hash so it isn't wrongly
+   * mistaken for a tied hash by the rest of hv_common. It will be reset by
+   * the op_ppaddr of a new fake op injected between the current and the next
+   * one. */
+  OP *o = PL_op;
+  if (!o->op_next || o->op_next->op_ppaddr != vmg_pp_resetuvar) {
+   SVOP *svop;
+   NewOp(1101, svop, 1, SVOP);
+   svop->op_type   = OP_STUB;
+   svop->op_ppaddr = vmg_pp_resetuvar;
+   svop->op_next   = o->op_next;
+   svop->op_flags  = 0;
+   svop->op_sv     = sv;
+   o->op_next      = (OP *) svop;
+  }
+  SvRMAGICAL_off(sv);
+ }
+
  return 0;
 }
 #endif /* VMG_UVAR */

diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm
index 1fea760102a7a9c0bf26a40835d7b0849a26b1ec..a94fbe377ca5c3c2956c68e4f1210544f07070ef 100644 (file)
--- a/lib/Variable/Magic.pm
+++ b/lib/Variable/Magic.pm
@@ -462,8 +462,6 @@ The only way to address this would be to return a reference.
 
 If you define a wizard with a C<free> callback and cast it on itself, this destructor won't be called because the wizard will be destroyed first.
 
-Using simultaneously C<get> and C<clear> magics on hashes may cause segfaults.
-
 =head1 DEPENDENCIES
 
 L<perl> 5.7.3.

diff --git a/t/32-hash.t b/t/32-hash.t
index 8803e35ac39c63d179bc95ff2df18892f92dbaf7..bf01b3dccfd522dda858c59b9a818677525257dd 100644 (file)
--- a/t/32-hash.t
+++ b/t/32-hash.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2 * 20 + 6 + 1;
+use Test::More tests => 2 * 21 + 7 + 1;
 
 use Variable::Magic qw/cast dispell MGf_COPY VMG_UVAR/;
 
@@ -11,7 +11,7 @@ use lib 't/lib';
 use Variable::Magic::TestWatcher;
 
 my $wiz = init
-        [ qw/get set len free copy dup local fetch store exists delete/ ], # clear
+        [ qw/get set len clear free copy dup local fetch store exists delete/ ],
         'hash';
 
 my %n = map { $_ => int rand 1000 } qw/foo bar baz qux/;
@@ -20,12 +20,13 @@ my %h = %n;
 check { cast %h, $wiz } { }, 'cast';
 
 my $s = check { $h{foo} } +{ (fetch => 1) x VMG_UVAR },
-                       # (copy => 1) x MGf_COPY # if clear magic
                        'assign element to';
 is $s, $n{foo}, 'hash: assign element to correctly';
 
-$s = check { exists $h{foo} } +{ (exists => 1) x VMG_UVAR }, 'exists';
-ok $s, 'hash: exists correctly';
+for (1 .. 2) {
+ $s = check { exists $h{foo} } +{ (exists => 1) x VMG_UVAR }, "exists ($_)";
+ ok $s, "hash: exists correctly ($_)";
+}
 
 my %b;
 check { %b = %h } { }, 'assign to';
@@ -35,17 +36,16 @@ $s = check { \%h } { }, 'reference';
 
 my @b = check { @h{qw/bar qux/} }
                   +{ (fetch => 2) x VMG_UVAR }, 'slice';
-                  # (copy => 2) x MGf_COPY # if clear magic
 is_deeply \@b, [ @n{qw/bar qux/} ], 'hash: slice correctly';
 
-check { %h = () } { }, 'empty in list context'; # clear => 1
+check { %h = () } { clear => 1 }, 'empty in list context';
 
 check { %h = (a => 1, d => 3); () }
-               +{ (store => 2, copy => 2) x VMG_UVAR }, # clear => 1
+               +{ (store => 2, copy => 2) x VMG_UVAR, clear => 1 },
                'assign from list in void context';
 
 check { %h = map { $_ => 1 } qw/a b d/; }
-               +{ (exists => 3, store => 3, copy => 3) x VMG_UVAR }, # clear =>1
+               +{ (exists => 3, store => 3, copy => 3) x VMG_UVAR, clear => 1 },
                'assign from map in list context';
 
 check { $h{d} = 2; () } +{ (store => 1) x VMG_UVAR },
@@ -69,6 +69,6 @@ check {
  check { cast %b, $wiz } { }, 'cast 2';
 } { free => 1 }, 'scope end';
 
-check { undef %h } { }, 'undef'; # clear => 1
+check { undef %h } { clear => 1 }, 'undef';
 
 check { dispell %h, $wiz } { }, 'dispell';