Make list assignment respect foreach aliasing

See ff2a62e0c8 for the explanation.  The bug fix in that commit did
not apply to foreach’s aliasing.

In short, ($a,$b)=($c,$d) needs to account for whether two of those
variable names could be referring to the same variable.

This commit causes the test suite to exercise a code path in scope.c
added by ff2a62e0c8, which turned out to be buggy.  (I forgot to test
it at the time.)

diff --git a/embed.fnc b/embed.fnc
index 5de2f83..7f759eb 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1242,6 +1242,7 @@ Ap        |void   |savestack_grow_cnt     |I32 need
 Amp    |void   |save_aelem     |NN AV* av|SSize_t idx|NN SV **sptr
 Ap     |void   |save_aelem_flags|NN AV* av|SSize_t idx|NN SV **sptr \
                                 |const U32 flags
+p      |void   |save_aliased_sv|NN GV* gv
 Ap     |I32    |save_alloc     |I32 size|I32 pad
 Ap     |void   |save_aptr      |NN AV** aptr
 Ap     |AV*    |save_ary       |NN GV* gv

diff --git a/embed.h b/embed.h
index ed04c7c..ebb1e9f 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1283,6 +1283,7 @@
 #define rsignal_restore(a,b)   Perl_rsignal_restore(aTHX_ a,b)
 #define rsignal_save(a,b,c)    Perl_rsignal_save(aTHX_ a,b,c)
 #define rxres_save(a,b)                Perl_rxres_save(aTHX_ a,b)
+#define save_aliased_sv(a)     Perl_save_aliased_sv(aTHX_ a)
 #define save_strlen(a)         Perl_save_strlen(aTHX_ a)
 #define sawparens(a)           Perl_sawparens(aTHX_ a)
 #define scalar(a)              Perl_scalar(aTHX_ a)

diff --git a/pp_ctl.c b/pp_ctl.c
index d72ec1c..3d02f3a 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2118,6 +2118,7 @@ PP(pp_enteriter)
        save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
        *svp = newSV(0);
        itervar = (void *)gv;
+       save_aliased_sv(gv);
     }
 
     if (PL_op->op_private & OPpITER_DEF)

diff --git a/proto.h b/proto.h
index bd6234f..632422d 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3670,6 +3670,11 @@ PERL_CALLCONV void       Perl_save_aelem_flags(pTHX_ AV* av, SSize_t idx, SV **sptr, c
 #define PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS      \
        assert(av); assert(sptr)
 
+PERL_CALLCONV void     Perl_save_aliased_sv(pTHX_ GV* gv)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SAVE_ALIASED_SV       \
+       assert(gv)
+
 PERL_CALLCONV I32      Perl_save_alloc(pTHX_ I32 size, I32 pad);
 PERL_CALLCONV void     Perl_save_aptr(pTHX_ AV** aptr)
                        __attribute__nonnull__(pTHX_1);

diff --git a/scope.c b/scope.c
index ada0a19..1084484 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -701,6 +701,16 @@ Perl_save_alloc(pTHX_ I32 size, I32 pad)
     return start;
 }
 
+void
+Perl_save_aliased_sv(pTHX_ GV *gv)
+{
+    dSS_ADD;
+    PERL_ARGS_ASSERT_SAVE_ALIASED_SV;
+    SS_ADD_PTR(gp_ref(GvGP(gv)));
+    SS_ADD_UV(SAVEt_GP_ALIASED_SV | cBOOL(GvALIASED_SV(gv)) << 8);
+    SS_ADD_END(2);
+}
+
 
 
 #define ARG0_SV  MUTABLE_SV(arg0.any_ptr)
@@ -1231,8 +1241,10 @@ Perl_leave_scope(pTHX_ I32 base)
            GP * const gp = (GP *)ARG0_PTR;
            if (gp->gp_refcnt == 1) {
                GV * const gv = (GV *)sv_2mortal(newSV_type(SVt_PVGV));
+               isGV_with_GP_on(gv);
                GvGP_set(gv,gp);
                gp_free(gv);
+               isGV_with_GP_off(gv);
            }
            else {
                gp->gp_refcnt--;

diff --git a/sv.c b/sv.c
index 5f29137..c3594b2 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4093,11 +4093,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
        }
        if (import_flag == GVf_IMPORTED_SV) {
            if (intro) {
-               dSS_ADD;
-               SS_ADD_PTR(gp_ref(GvGP(dstr)));
-               SS_ADD_UV(SAVEt_GP_ALIASED_SV
-                       | cBOOL(GvALIASED_SV(dstr)) << 8);
-               SS_ADD_END(2);
+               save_aliased_sv((GV *)dstr);
            }
            /* Turn off the flag if sref is not referenced elsewhere,
               even by weak refs.  (SvRMAGICAL is a pessimistic check for

diff --git a/t/op/for.t b/t/op/for.t
index 2ac0fc8..36af7fd 100644 (file)
--- a/t/op/for.t
+++ b/t/op/for.t
@@ -4,7 +4,7 @@ BEGIN {
     require "test.pl";
 }
 
-plan(106);
+plan(107);
 
 # A lot of tests to check that reversed for works.
 
@@ -579,3 +579,9 @@ SKIP: {
     }->($a[0]);
     is $@, "", 'vivify_defelem does not croak on &PL_sv_undef elements';
 }
+
+for $x ($y) {
+    $x = 3;
+    ($x, my $z) = (1, $y);
+    is $z, 3, 'list assignment after aliasing via foreach';
+}