From: Vincent Pit <vince@profvince.com>
Date: Mon, 15 Jun 2009 14:41:17 +0000 (+0200)
Subject: Don't vivify when aliasing
X-Git-Tag: v0.02~13
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fautovivification.git;a=commitdiff_plain;h=ddbfd527f4c54458985145aae3a837a8f5868551

Don't vivify when aliasing
---

diff --git a/autovivification.xs b/autovivification.xs
index 64fbc2e..b6b3c33 100644
--- a/autovivification.xs
+++ b/autovivification.xs
@@ -259,6 +259,8 @@ STATIC OP *a_pp_rv2av(pTHX) {
  dSP;
 
  if (!SvOK(TOPs)) {
+  /* We always need to push an empty array to fool the pp_aelem() that comes
+   * later. */
   SV *av;
   POPs;
   av = sv_2mortal((SV *) newAV());
@@ -278,11 +280,18 @@ STATIC OP *a_pp_rv2hv(pTHX) {
  UV hint;
  dSP;
 
- if (!SvOK(TOPs))
-  RETURN;
-
  a_map_fetch(PL_op, &oi);
 
+ if (!SvOK(TOPs)) {
+  if (oi.root->op_flags & OPf_MOD) {
+   SV *hv;
+   POPs;
+   hv = sv_2mortal((SV *) newHV());
+   PUSHs(hv);
+  }
+  RETURN;
+ }
+
  return CALL_FPTR(oi.old_pp)(aTHX);
 }
 
@@ -325,11 +334,11 @@ deref:
  } else if (flags && (PL_op->op_private & OPpDEREF || PL_op == oi.root)) {
   oi.flags = flags & A_HINT_NOTIFY;
 
-  if (oi.root->op_flags & OPf_MOD) {
-   if (flags & A_HINT_STORE)
+  if ((oi.root->op_flags & (OPf_MOD|OPf_REF)) != (OPf_MOD|OPf_REF)) {
+   if (flags & A_HINT_FETCH)
+    oi.flags |= (A_HINT_FETCH|A_HINT_DEREF);
+  } else if (flags & A_HINT_STORE)
     oi.flags |= (A_HINT_STORE|A_HINT_DEREF);
-  } else if (flags & A_HINT_FETCH)
-   oi.flags |= (A_HINT_FETCH|A_HINT_DEREF);
 
   if (PL_op == oi.root)
    oi.flags &= ~A_HINT_DEREF;
diff --git a/t/20-hash.t b/t/20-hash.t
index c4fb680..867152a 100644
--- a/t/20-hash.t
+++ b/t/20-hash.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 6 * 3 * 240;
+use Test::More tests => 6 * 3 * 260;
 
 sub testcase {
  my ($var, $init, $code, $exp, $use, $global) = @_;
@@ -148,6 +148,31 @@ $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1,     { a => { b => 1 } }
 $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } }                # +strict +store
 $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } }      # +strict +store
 
+--- aliasing ---
+
+$x # 1 for $x->{a}; () # '', undef, { a => undef }
+$x # 1 for $x->{a}; () # '', undef, undef          #
+$x # 1 for $x->{a}; () # '', undef, undef          # +fetch
+$x # 1 for $x->{a}; () # '', undef, { a => undef } # +exists
+$x # 1 for $x->{a}; () # '', undef, { a => undef } # +delete
+$x # 1 for $x->{a}; () # '', undef, { a => undef } # +store
+
+$x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 }
+$x # $_ = 1 for $x->{a}; () # '', undef, undef      #
+$x # $_ = 1 for $x->{a}; () # '', undef, undef      # +fetch
+$x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # +exists
+$x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # +delete
+$x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # +store
+
+$x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 }             # +fetch
+$x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +fetch
+$x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 }             # +exists
+$x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +exists
+$x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 }             # +delete
+$x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +delete
+$x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 }             # +store
+$x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +store
+
 --- exists ---
 
 $x # exists $x->{a} # '', '', { }
diff --git a/t/21-array.t b/t/21-array.t
index 95bb8ff..dae28a4 100644
--- a/t/21-array.t
+++ b/t/21-array.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 6 * 3 * 240;
+use Test::More tests => 6 * 3 * 260;
 
 sub testcase {
  my ($var, $init, $code, $exp, $use, $global) = @_;
@@ -148,6 +148,31 @@ $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +store
 $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +store 
 $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +store 
  
+--- aliasing --- 
+ 
+$x # 1 for $x->[0]; () # '', undef, [ undef ] 
+$x # 1 for $x->[0]; () # '', undef, undef # 
+$x # 1 for $x->[0]; () # '', undef, undef # +fetch 
+$x # 1 for $x->[0]; () # '', undef, [ undef ] # +exists 
+$x # 1 for $x->[0]; () # '', undef, [ undef ] # +delete 
+$x # 1 for $x->[0]; () # '', undef, [ undef ] # +store 
+ 
+$x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] 
+$x # $_ = 1 for $x->[0]; () # '', undef, undef # 
+$x # $_ = 1 for $x->[0]; () # '', undef, undef # +fetch 
+$x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # +exists 
+$x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # +delete 
+$x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # +store 
+ 
+$x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +fetch 
+$x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +fetch 
+$x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +exists 
+$x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +exists 
+$x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +delete 
+$x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +delete 
+$x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +store 
+$x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +store 
+ 
 --- exists --- 
  
 $x # exists $x->[0] # '', '', [ ]