From: Vincent Pit <vince@profvince.com>
Date: Sun, 12 Aug 2012 17:11:01 +0000 (+0200)
Subject: Reset the SV each time for the 'reset RMG flag' workaround
X-Git-Tag: v0.51~5
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=982fc8481dd6fa6e256a6b829f13a26a9e703271

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 15164cc..1091f15 100644
--- 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 703bcd3..df46de2 100644
--- 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");
+ }
 }