From: Vincent Pit <vince@profvince.com>
Date: Fri, 23 Apr 2010 23:23:20 +0000 (+0200)
Subject: Make sure a_defined() calls get magic before testing for definedness
X-Git-Tag: rt56870^0
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fautovivification.git;a=commitdiff_plain;h=40b9bfe1115b33d2d5f88d57f983c2ddd7d3f5d2

Make sure a_defined() calls get magic before testing for definedness

Before this lvalues never appeared as defined, which caused bugs with multiple
nested tied arrays and hashes.

This fixes RT #56870.
---

diff --git a/MANIFEST b/MANIFEST
index 988f9cb..8d91622 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -10,9 +10,11 @@ samples/hash2array.pl
 t/00-load.t
 t/20-hash.t
 t/22-hash-kv.t
+t/23-hash-tied.t
 t/30-array.t
 t/31-array-fast.t
 t/32-array-kv.t
+t/33-array-tied.t
 t/40-scope.t
 t/41-padsv.t
 t/42-deparse.t
diff --git a/autovivification.xs b/autovivification.xs
index a8367a0..7e7c1f3 100644
--- a/autovivification.xs
+++ b/autovivification.xs
@@ -378,7 +378,9 @@ STATIC bool a_defined(pTHX_ SV *sv) {
     defined = TRUE;
    break;
   default:
-   defined = SvOK(sv);
+   SvGETMAGIC(sv);
+   if (SvOK(sv))
+    defined = TRUE;
  }
 
  return defined;
@@ -403,7 +405,7 @@ STATIC OP *a_pp_rv2av(pTHX) {
  flags = oi.flags;
 
  if (flags & A_HINT_DEREF) {
-  if (!SvOK(TOPs)) {
+  if (!a_defined(TOPs)) {
    /* We always need to push an empty array to fool the pp_aelem() that comes
     * later. */
    SV *av;
@@ -430,7 +432,7 @@ STATIC OP *a_pp_rv2hv_simple(pTHX) {
  flags = oi.flags;
 
  if (flags & A_HINT_DEREF) {
-  if (!SvOK(TOPs))
+  if (!a_defined(TOPs))
    RETURN;
  } else {
   PL_op->op_ppaddr = oi.old_pp;
@@ -448,7 +450,7 @@ STATIC OP *a_pp_rv2hv(pTHX) {
  flags = oi.flags;
 
  if (flags & A_HINT_DEREF) {
-  if (!SvOK(TOPs)) {
+  if (!a_defined(TOPs)) {
    SV *hv;
    POPs;
    hv = sv_2mortal((SV *) newHV());
@@ -484,7 +486,7 @@ deref:
 
   if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
    SPAGAIN;
-   if (!SvOK(TOPs)) {
+   if (!a_defined(TOPs)) {
     if (flags & A_HINT_STRICT)
      croak("Reference vivification forbidden");
     else if (flags & A_HINT_WARN)
diff --git a/t/23-hash-tied.t b/t/23-hash-tied.t
new file mode 100644
index 0000000..7fd0fc3
--- /dev/null
+++ b/t/23-hash-tied.t
@@ -0,0 +1,27 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ eval 'use Tie::Hash; scalar keys %Tie::StdHash::'
+                or plan skip_all => 'Tie::StdHash required to test tied hashes';
+ defined and diag "Using Tie::StdHash $_" for $Tie::Hash::VERSION;
+ plan tests => 1;
+}
+
+{
+ tie my %x, 'Tie::StdHash';
+ tie my %y, 'Tie::StdHash';
+
+ $x{key} = 'hlagh';
+ $y{x}   = \%x;
+
+ my $res = do {
+  no autovivification;
+  $y{x}{key};
+ };
+ is $res, 'hlagh', 'nested tied hashes';
+}
diff --git a/t/33-array-tied.t b/t/33-array-tied.t
new file mode 100644
index 0000000..93ab369
--- /dev/null
+++ b/t/33-array-tied.t
@@ -0,0 +1,27 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ eval 'use Tie::Array; scalar keys %Tie::StdArray::'
+               or plan skip_all => 'Tie::StdArray required to test tied arrays';
+ defined and diag "Using Tie::StdArray $_" for $Tie::Array::VERSION;
+ plan tests => 1;
+}
+
+{
+ tie my @a, 'Tie::StdArray';
+ tie my @b, 'Tie::StdArray';
+
+ $a[1] = 'hlagh';
+ $b[0] = \@a;
+
+ my $res = do {
+  no autovivification;
+  $b[0][1];
+ };
+ is $res, 'hlagh', 'nested tied arrays';
+}