Reset the SV each time for the 'reset RMG flag' workaround

This bug caused the workaround to only update the flag of the first hash
that it was called for, regardless of subsequent calls with different
hashes.

diff --git a/Magic.xs b/Magic.xs
index 15164cc8adf8be638062352676565131b5433c47..1091f15dd71dd88d73b656e4149617d6f0423fc0 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -1450,8 +1450,12 @@ STATIC int vmg_svt_local(pTHX_ SV *nsv, MAGIC *mg) {
 
 #if VMG_UVAR
 
-STATIC OP *vmg_pp_resetuvar(pTHX) {
- SvRMAGICAL_on(cSVOP_sv);
+STATIC OP *vmg_pp_reset_rmg(pTHX) {
+ SVOP *o = cSVOPx(PL_op);
+
+ SvRMAGICAL_on(o->op_sv);
+ o->op_sv = NULL;
+
  return NORMAL;
 }
 
@@ -1532,17 +1536,24 @@ STATIC I32 vmg_svt_val(pTHX_ IV action, SV *sv) {
    * 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 *nop = PL_op->op_next;
-  if (!nop || nop->op_ppaddr != vmg_pp_resetuvar) {
-   SVOP *svop;
+  OP   *nop  = PL_op->op_next;
+  SVOP *svop = NULL;
+
+  if (nop && nop->op_ppaddr == vmg_pp_reset_rmg) {
+   svop = (SVOP *) nop;
+  } else {
    NewOp(1101, svop, 1, SVOP);
-   svop->op_type   = OP_STUB;
-   svop->op_ppaddr = vmg_pp_resetuvar;
-   svop->op_next   = nop;
-   svop->op_flags  = 0;
-   svop->op_sv     = sv;
-   PL_op->op_next  = (OP *) svop;
+   svop->op_type    = OP_STUB;
+   svop->op_ppaddr  = vmg_pp_reset_rmg;
+   svop->op_next    = nop;
+   svop->op_flags   = 0;
+   svop->op_private = 0;
+
+   PL_op->op_next = (OP *) svop;
   }
+
+  svop->op_sv = sv;
+
   SvRMAGICAL_off(sv);
  }
 

diff --git a/t/32-hash.t b/t/32-hash.t
index 703bcd3df82b5f4c30e1b7495fc24accfe5f1d46..df46de2fbac67a768fc96f3777e6df373fb61e09 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 * 27 + 9) + (2 * 5 + 5) + 1;
+use Test::More tests => (2 * 27 + 9) + 2 * (2 * 5 + 5) + 1;
 
 use Variable::Magic qw<
  cast dispell
@@ -112,40 +112,54 @@ SKIP: {
   $SKIP = 'uvar magic';
  } else {
   local $@;
-  unless (eval { require B::Deparse; 1 }) {
-   $SKIP = 'B::Deparse';
+  unless (eval { require B; require B::Deparse; 1 }) {
+   $SKIP = 'B and B::Deparse';
   }
  }
  if ($SKIP) {
   $SKIP .= ' required to test uvar/clear interaction fix';
-  skip $SKIP => 2 * 5 + 5;
+  skip $SKIP => 2 * ( 2 * 5 + 5);
  }
 
  my $bd = B::Deparse->new;
 
- my %h = (a => 13, b => 15);
- watch { cast %h, $wiz } { }, 'cast clear/uvar';
+ my %h1 = (a => 13, b => 15);
+ my %h2 = (a => 17, b => 19);
 
- my $code   = sub { my $x = $h{$_[0]}; ++$x; $x };
- my $before = $bd->coderef2text($code);
- my $res;
+ my @tests = (
+  [ \%h1 => 'first hash'  => (14, 16) ],
+  [ \%h2 => 'second hash' => (18, 20) ],
+ );
 
- watch { $res = $code->('a') } { fetch => 1 }, 'fixed fetch "a"';
- is $res, 14, 'uvar: fixed fetch "a" returned the right thing';
+ for my $test (@tests) {
+  my ($h, $desc, @exp) = @$test;
 
- my $after = $bd->coderef2text($code);
- is $before, $after, 'uvar: fixed fetch deparse correctly';
+  watch { &cast($h, $wiz) } { }, "cast clear/uvar on $desc";
 
- watch { $res = $code->('b') } { fetch => 1 }, 'fixed fetch "b"';
- is $res, 16, 'uvar: fixed fetch "b" returned the right thing';
+  my $code   = sub { my $x = $h->{$_[0]}; ++$x; $x };
+  my $before = $bd->coderef2text($code);
+  my $res;
 
- $after = $bd->coderef2text($code);
- is $before, $after, 'uvar: fixed fetch deparse correctly';
+  watch { $res = $code->('a') } { fetch => 1 }, "fetch constant 'a' from $desc";
+  is $res, $exp[0], "uvar: fetch constant 'a' from $desc was correct";
 
- watch { %h = () } { clear => 1 }, 'fixed clear';
+  my $after = $bd->coderef2text($code);
+  is $before, $after,
+                "uvar: code deparses correctly after constant fetch from $desc";
 
- watch { dispell %h, $wiz } { }, 'dispell clear/uvar';
+  my $key = 'b';
+  watch { $res = $code->($key) } { fetch => 1 },"fetch variable 'b' from $desc";
+  is $res, $exp[1], "uvar: fetch variable 'b' from $desc was correct";
 
- require B;
- ok(!(B::svref_2object(\%h)->FLAGS & B::SVs_RMG()), '%h no longer has the RMG flag set');
+  $after = $bd->coderef2text($code);
+  is $before, $after,
+                "uvar: code deparses correctly after variable fetch from $desc";
+
+  watch { %$h = () } { clear => 1 }, "fixed clear for $desc";
+
+  watch { &dispell($h, $wiz) } { }, "dispell clear/uvar from $desc";
+
+  ok(!(B::svref_2object($h)->FLAGS & B::SVs_RMG()),
+                               "$desc no longer has the RMG flag set");
+ }
 }