[perl #112966] Crash on delete local; other local bugs

Commit bee7c5743fa appears to have fixed this.  But what it does is
barely significant:

diff --git a/sv.c b/sv.c
index b96f7c1..a4994f5 100644
--- a/sv.c
+++ b/sv.c
@@ -9525,6 +9525,11 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
     SvUPGRADE(tmpRef, SVt_PVMG);
     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));

+    if (Gv_AMG(stash))
+	SvAMAGIC_on(sv);
+    else
+	(void)SvAMAGIC_off(sv);
+
     if(SvSMAGICAL(tmpRef))
         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
             mg_set(tmpRef);

The crash can still be triggered another way.  Instead of a blessing,
we need to modify a method (to turn on the potentially-overloaded
flag) and then use an operator that respects overloading.  This exam-
ple crashes before and after bee7c5743fa:

eval 'sub Sample::foo {}';
"".bless {},'Sample';
delete local $Sample::{ '()' };

It is the recalculation of overload caches before a localised deletion
that causes the crash.  And it only happens when the '()' key does
not exist.

Actually, it turns out that S_delete_local doesn’t behave correctly
for rmagical aggregates, except for %ENV:

$ ./perl -Ilib -MDevel::Peek -e 'delete local $ISA[0]'
Bus error
$ ./perl -XIlib -MDevel::Peek -e '??; delete local $::{foo}'
Bus error

It’s this line, which occurs twice in pp.c:S_do_delete_local, which
is at fault:

	const bool can_preserve = SvCANEXISTDELETE(osv)
				    || mg_find((const SV *)osv, PERL_MAGIC_env);

When can_preserve is true, the ‘preeminent’ variable is set based on
whether the element exists.  Otherwise it is set to true.

Why the term ‘preeminent’ was chosen I don’t know, but in this case it
means that the element already exists, so it has to be restored after-
wards.  We can’t just do save_delete.

The code for saving a hash element assumes it is non-null, and crashes
otherwise.

The logic for setting can_preserve is wrong.  SvCANEXISTDELETE returns
true for non-magical variables and for variables with those tie meth-
ods implemented.  For magical variables that are not tied, it returns
the wrong answer.  PERL_MAGIC_env seems to have been added as an
exception, to keep it working.  But other magical aggregates were not
accounted for.

This logic was copied from other functions (aslice, hslice, etc.),
which are similarly buggy, but they don’t crash:

$ ./perl -Ilib -le ' { local $::{foo} } print exists $::{foo}'

$ ./perl -Ilib -le 'm??; { local $::{foo} } print exists $::{foo}'
1

In all these cases, it is SvCANEXISTDELETE that is buggy.  So this
commit fixes it and adds tests for all the code paths that use it.
Now no exception needs to be made for PERL_MAGIC_env.

diff --git a/pp.c b/pp.c
index 0a6a115..d44b4ee 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -4402,8 +4402,7 @@ S_do_delete_local(pTHX)
        SV * const osv = POPs;
        const bool tied = SvRMAGICAL(osv)
                            && mg_find((const SV *)osv, PERL_MAGIC_tied);
-       const bool can_preserve = SvCANEXISTDELETE(osv)
-                                   || mg_find((const SV *)osv, PERL_MAGIC_env);
+       const bool can_preserve = SvCANEXISTDELETE(osv);
        const U32 type = SvTYPE(osv);
        if (type == SVt_PVHV) {                 /* hash element */
            HV * const hv = MUTABLE_HV(osv);
@@ -4491,8 +4490,7 @@ S_do_delete_local(pTHX)
        SV * const osv   = POPs;
        const bool tied = SvRMAGICAL(osv)
                            && mg_find((const SV *)osv, PERL_MAGIC_tied);
-       const bool can_preserve = SvCANEXISTDELETE(osv)
-                                   || mg_find((const SV *)osv, PERL_MAGIC_env);
+       const bool can_preserve = SvCANEXISTDELETE(osv);
        const U32 type = SvTYPE(osv);
        SV *sv = NULL;
        if (type == SVt_PVHV) {
@@ -4678,7 +4676,7 @@ PP(pp_hslice)
         MAGIC *mg;
         HV *stash;
 
-       if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
+       if (SvCANEXISTDELETE(hv))
            can_preserve = TRUE;
     }
 

diff --git a/pp.h b/pp.h
index deafed3..93aeb91 100644 (file)
--- a/pp.h
+++ b/pp.h
@@ -475,8 +475,8 @@ True if this op will be the return value of an lvalue subroutine
 
 #define SvCANEXISTDELETE(sv) \
  (!SvRMAGICAL(sv)            \
-  || ((mg = mg_find((const SV *) sv, PERL_MAGIC_tied))           \
-      && (stash = SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(sv), mg)))) \
+  || !(mg = mg_find((const SV *) sv, PERL_MAGIC_tied))           \
+  || (   (stash = SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(sv), mg)))) \
       && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)          \
       && gv_fetchmethod_autoload(stash, "DELETE", TRUE)          \
      )                       \

diff --git a/pp_hot.c b/pp_hot.c
index 24edbdc..675f2e5 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1792,7 +1792,7 @@ PP(pp_helem)
         * Try to preserve the existenceness of a tied hash
         * element by using EXISTS and DELETE if possible.
         * Fallback to FETCH and STORE otherwise. */
-       if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
+       if (SvCANEXISTDELETE(hv))
            preeminent = hv_exists_ent(hv, keysv, 0);
     }
 

diff --git a/t/op/local.t b/t/op/local.t
index d70feb7..3b9b021 100644 (file)
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = qw(. ../lib);
     require './test.pl';
 }
-plan tests => 305;
+plan tests => 310;
 
 my $list_assignment_supported = 1;
 
@@ -781,6 +781,27 @@ like( runperl(stderr => 1,
                       'index(q(a), foo);' .
                       'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]");
 
+# related to perl #112966
+# Magic should not cause elements not to be deleted after scope unwinding
+# when they did not exist before local()
+() = \$#squinch; # $#foo in lvalue context makes array magical
+{
+    local $squinch[0];
+    local @squinch[1..2];
+    package Flibbert;
+    m??; # makes stash magical
+    local $Flibbert::{foo};
+    local @Flibbert::{<bar baz>};
+}
+ok !exists $Flibbert::{foo},
+  'local helem on magic hash does not leave elems on scope exit';
+ok !exists $Flibbert::{bar},
+  'local hslice on magic hash does not leave elems on scope exit';
+ok !exists $squinch[0],
+  'local aelem on magic hash does not leave elems on scope exit';
+ok !exists $squinch[1],
+  'local aslice on magic hash does not leave elems on scope exit';
+
 # Keep these tests last, as they can SEGV
 {
     local *@;
@@ -793,3 +814,14 @@ like( runperl(stderr => 1,
     delete $::{$_} for 'nugguton','netgonch';
 }
 pass ('localised arrays and hashes do not crash if glob is deleted');
+
+# [perl #112966] Rmagic can cause delete local to crash
+package Grompits {
+local $SIG{__WARN__};
+    delete local $ISA[0];
+    delete local @ISA[1..10];
+    m??; # makes stash magical
+    delete local $Grompits::{foo};
+    delete local @Grompits::{<foo bar>};
+}
+pass 'rmagic does not cause delete local to crash on nonexistent elems';