Fixes the case of $a = \$#{[]}; and then accessing $$a

(but not \$#a after local @a or my @a leave a block)

p4raw-id: //depot/perl@24783

diff --git a/av.c b/av.c
index 695ebc7..e5cbe2f 100644 (file)
--- a/av.c
+++ b/av.c
@@ -504,10 +504,8 @@ Perl_av_undef(pTHX_ register AV *av)
     AvALLOC(av) = 0;
     SvPV_set(av, (char*)0);
     AvMAX(av) = AvFILLp(av) = -1;
-    if (AvARYLEN(av)) {
-       SvREFCNT_dec(AvARYLEN(av));
-       AvARYLEN(av) = 0;
-    }
+    /* It's in magic - it must already be gone.  */
+    assert (!AvARYLEN(av));
 }
 
 /*
@@ -949,6 +947,14 @@ Perl_av_arylen_p(pTHX_ AV *av) {
        }
        /* sv_magicext won't set this for us because we pass in a NULL obj  */
        mg->mg_flags |= MGf_REFCOUNTED;
+
+       /* This is very naughty, but we don't want SvRMAGICAL() set on the
+          hash, because it slows down all accesses.  If we pass in a vtable
+          to sv_magicext then it is (correctly) set for us.  However, the only
+          entry in our vtable is for free, and mg_free always calls the free
+          vtable entry irrespective of the flags, so it doesn't actually
+          matter that the R flag is off.  */
+       mg->mg_virtual = &PL_vtbl_arylen_p;
     }
     return &(mg->mg_obj);
 }

diff --git a/dump.c b/dump.c
index bfa6727..fed067d 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -970,6 +970,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
            else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
            else if (v == &PL_vtbl_backref)    s = "backref";
            else if (v == &PL_vtbl_utf8)       s = "utf8";
+            else if (v == &PL_vtbl_arylen_p)   s = "arylen_p";
            if (s)
                Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
            else

diff --git a/embed.fnc b/embed.fnc
index 408e44f..2ad5e07 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -411,6 +411,7 @@ pr  |int    |magic_regdatum_set|SV* sv|MAGIC* mg
 p      |int    |magic_set      |SV* sv|MAGIC* mg
 p      |int    |magic_setamagic|SV* sv|MAGIC* mg
 p      |int    |magic_setarylen|SV* sv|MAGIC* mg
+p      |int    |magic_freearylen_p|SV* sv|MAGIC* mg
 p      |int    |magic_setbm    |SV* sv|MAGIC* mg
 p      |int    |magic_setdbline|SV* sv|MAGIC* mg
 p      |int    |magic_setdefelem|SV* sv|MAGIC* mg

diff --git a/embed.h b/embed.h
index 7b39af5..dacff84 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -421,6 +421,7 @@
 #define magic_set              Perl_magic_set
 #define magic_setamagic                Perl_magic_setamagic
 #define magic_setarylen                Perl_magic_setarylen
+#define magic_freearylen_p     Perl_magic_freearylen_p
 #define magic_setbm            Perl_magic_setbm
 #define magic_setdbline                Perl_magic_setdbline
 #define magic_setdefelem       Perl_magic_setdefelem
@@ -2420,6 +2421,7 @@
 #define magic_set(a,b)         Perl_magic_set(aTHX_ a,b)
 #define magic_setamagic(a,b)   Perl_magic_setamagic(aTHX_ a,b)
 #define magic_setarylen(a,b)   Perl_magic_setarylen(aTHX_ a,b)
+#define magic_freearylen_p(a,b)        Perl_magic_freearylen_p(aTHX_ a,b)
 #define magic_setbm(a,b)       Perl_magic_setbm(aTHX_ a,b)
 #define magic_setdbline(a,b)   Perl_magic_setdbline(aTHX_ a,b)
 #define magic_setdefelem(a,b)  Perl_magic_setdefelem(aTHX_ a,b)

diff --git a/mg.c b/mg.c
index 4b31e4b..4c01018 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1647,14 +1647,42 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
 {
-    sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
+    AV *obj = (AV*)mg->mg_obj;
+    if (obj) {
+       sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
+    } else {
+       SvOK_off(sv);
+    }
     return 0;
 }
 
 int
 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
 {
-    av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
+    AV *obj = (AV*)mg->mg_obj;
+    if (obj) {
+       av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
+    } else {
+       if (ckWARN(WARN_MISC))
+           Perl_warner(aTHX_ packWARN(WARN_MISC),
+                       "Attempt to set length of freed array");
+    }
+    return 0;
+}
+
+int
+Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
+{
+    mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
+
+    if (mg) {
+       /* arylen scalar holds a pointer back to the array, but doesn't own a
+          reference. Hence the we (the array) are about to go away with it
+          still pointing at us. Clear its pointer, else it would be pointing
+          at free memory. See the comment in sv_magic about reference loops,
+          and why it can't own a reference to us.  */
+       mg->mg_obj = 0;
+    }
     return 0;
 }
 

diff --git a/perl.h b/perl.h
index 3df67eb..5eff7de 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -3805,7 +3805,8 @@ enum {            /* pass one of these to get_vtbl */
     want_vtbl_regdatum,
     want_vtbl_backref,
     want_vtbl_utf8,
-    want_vtbl_symtab
+    want_vtbl_symtab,
+    want_vtbl_arylen_p
 };
 
                                /* Note: the lowest 8 bits are reserved for
@@ -4165,6 +4166,17 @@ MGVTBL_SET(
 );
 
 MGVTBL_SET(
+    PL_vtbl_arylen_p,
+    NULL,
+    NULL,
+    NULL,
+    NULL,
+    MEMBER_TO_FPTR(Perl_magic_freearylen_p),
+    NULL,
+    NULL
+);
+
+MGVTBL_SET(
     PL_vtbl_glob,
     MEMBER_TO_FPTR(Perl_magic_getglob),
     MEMBER_TO_FPTR(Perl_magic_setglob),

diff --git a/proto.h b/proto.h
index 6ac3d69..64adf53 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -762,6 +762,7 @@ PERL_CALLCONV int   Perl_magic_regdatum_set(pTHX_ SV* sv, MAGIC* mg)
 PERL_CALLCONV int      Perl_magic_set(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int      Perl_magic_setamagic(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int      Perl_magic_setarylen(pTHX_ SV* sv, MAGIC* mg);
+PERL_CALLCONV int      Perl_magic_freearylen_p(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int      Perl_magic_setbm(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int      Perl_magic_setdbline(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int      Perl_magic_setdefelem(pTHX_ SV* sv, MAGIC* mg);

diff --git a/t/op/array.t b/t/op/array.t
index c003ffe..16a3df5 100755 (executable)
--- a/t/op/array.t
+++ b/t/op/array.t
@@ -7,7 +7,7 @@ BEGIN {
 
 require 'test.pl';
 
-plan (85);
+plan (88);
 
 #
 # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
@@ -277,3 +277,13 @@ is ($got, '');
     like($@, qr/Modification of non-creatable array value attempted, subscript -1/, "\$a[-1] = 0");
 }
 
+{
+    local $^W = 1;
+    my $a = \$#{[]};
+    is ($$a, undef, "\$# on freed array is undef");
+    my @warn;
+    local $SIG{__WARN__} = sub {push @warn, "@_"};
+    $$a = 1000;
+    is (scalar @warn, 1);
+    like ($warn[0], qr/^Attempt to set length of freed array/);
+}