fix C<local $tied{foo} = $tied{foo}>, add tests

p4raw-id: //depot/perl@1307

diff --git a/pp_hot.c b/pp_hot.c
index 6218f85..da2a41f 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -250,9 +250,13 @@ PP(pp_aelemfast)
 {
     djSP;
     AV *av = GvAV((GV*)cSVOP->op_sv);
-    SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD);
+    U32 lval = op->op_flags & OPf_MOD;
+    SV** svp = av_fetch(av, op->op_private, lval);
+    SV *sv = (svp ? *svp : &sv_undef);
     EXTEND(SP, 1);
-    PUSHs(svp ? *svp : &sv_undef);
+    if (!lval && SvGMAGICAL(sv))       /* see note in pp_helem() */
+       sv = sv_mortalcopy(sv);
+    PUSHs(sv);
     RETURN;
 }
 
@@ -1311,6 +1315,7 @@ PP(pp_helem)
     HV *hv = (HV*)POPs;
     U32 lval = op->op_flags & OPf_MOD;
     U32 defer = op->op_private & OPpLVAL_DEFER;
+    SV *sv;
 
     if (SvTYPE(hv) == SVt_PVHV) {
        he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
@@ -1347,7 +1352,16 @@ PP(pp_helem)
        else if (op->op_private & OPpDEREF)
            vivify_ref(*svp, op->op_private & OPpDEREF);
     }
-    PUSHs(svp ? *svp : &sv_undef);
+    sv = (svp ? *svp : &sv_undef);
+    /* This makes C<local $tied{foo} = $tied{foo}> possible.
+     * Pushing the magical RHS on to the stack is useless, since
+     * that magic is soon destined to be misled by the local(),
+     * and thus the later pp_sassign() will fail to mg_get() the
+     * old value.  This should also cure problems with delayed
+     * mg_get()s.  GSAR 98-07-03 */
+    if (!lval && SvGMAGICAL(sv))
+       sv = sv_mortalcopy(sv);
+    PUSHs(sv);
     RETURN;
 }
 
@@ -2320,6 +2334,7 @@ PP(pp_aelem)
     AV* av = (AV*)POPs;
     U32 lval = op->op_flags & OPf_MOD;
     U32 defer = (op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
+    SV *sv;
 
     if (elem > 0)
        elem -= curcop->cop_arybase;
@@ -2346,7 +2361,10 @@ PP(pp_aelem)
        else if (op->op_private & OPpDEREF)
            vivify_ref(*svp, op->op_private & OPpDEREF);
     }
-    PUSHs(svp ? *svp : &sv_undef);
+    sv = (svp ? *svp : &sv_undef);
+    if (!lval && SvGMAGICAL(sv))       /* see note in pp_helem() */
+       sv = sv_mortalcopy(sv);
+    PUSHs(sv);
     RETURN;
 }
 

diff --git a/t/op/local.t b/t/op/local.t
index 513e063..82a5cb9 100755 (executable)
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $
 
-print "1..47\n";
+print "1..58\n";
 
 sub foo {
     local($a, $b) = @_;
@@ -118,9 +118,9 @@ tie @a, 'TA';
 @a = ('a', 'b', 'c');
 {
     local($a[1]) = 'foo';
-    local($a[2]) = $a[1];  # XXX LHS == RHS doesn't work yet
+    local($a[2]) = $a[2];
     print +($a[1] eq 'foo') ? "" : "not ", "ok 37\n";
-    print +($a[2] eq 'foo') ? "" : "not ", "ok 38\n";
+    print +($a[2] eq 'c') ? "" : "not ", "ok 38\n";
     @a = ();
 }
 print +($a[1] eq 'b') ? "" : "not ", "ok 39\n";
@@ -142,9 +142,9 @@ tie %h, 'TH';
 
 {
     local($h{'a'}) = 'foo';
-    local($h{'b'}) = $h{'a'};  # XXX LHS == RHS doesn't work yet
+    local($h{'b'}) = $h{'b'};
     print +($h{'a'} eq 'foo') ? "" : "not ", "ok 42\n";
-    print +($h{'b'} eq 'foo') ? "" : "not ", "ok 43\n";
+    print +($h{'b'} == 2) ? "" : "not ", "ok 43\n";
     local($h{'c'});
     delete $h{'c'};
 }
@@ -159,3 +159,39 @@ print +($h{'c'} == 3) ? "" : "not ", "ok 46\n";
 }
 print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 47\n";
 
+# now try the same for %SIG
+
+$SIG{TERM} = 'foo';
+$SIG{INT} = \&foo;
+$SIG{__WARN__} = $SIG{INT};
+{
+    local($SIG{TERM}) = $SIG{TERM};
+    local($SIG{INT}) = $SIG{INT};
+    local($SIG{__WARN__}) = $SIG{__WARN__};
+    print +($SIG{TERM}         eq 'main::foo') ? "" : "not ", "ok 48\n";
+    print +($SIG{INT}          eq \&foo) ? "" : "not ", "ok 49\n";
+    print +($SIG{__WARN__}     eq \&foo) ? "" : "not ", "ok 50\n";
+    local($SIG{INT});
+    delete $SIG{__WARN__};
+}
+print +($SIG{TERM}     eq 'main::foo') ? "" : "not ", "ok 51\n";
+print +($SIG{INT}      eq \&foo) ? "" : "not ", "ok 52\n";
+print +($SIG{__WARN__} eq \&foo) ? "" : "not ", "ok 53\n";
+
+# and for %ENV
+
+$ENV{_X_} = 'a';
+$ENV{_Y_} = 'b';
+$ENV{_Z_} = 'c';
+{
+    local($ENV{_X_}) = 'foo';
+    local($ENV{_Y_}) = $ENV{_Y_};
+    print +($ENV{_X_} eq 'foo') ? "" : "not ", "ok 54\n";
+    print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 55\n";
+    local($ENV{_Z_});
+    delete $ENV{_Z_};
+}
+print +($ENV{_X_} eq 'a') ? "" : "not ", "ok 56\n";
+print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 57\n";
+print +($ENV{_Z_} eq 'c') ? "" : "not ", "ok 58\n";
+