This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
extend magic copy test to all scope exit types
authorDavid Mitchell <davem@iabyn.com>
Wed, 21 Oct 2015 18:10:34 +0000 (19:10 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 3 Feb 2016 09:18:32 +0000 (09:18 +0000)
Commit v5.15.6-387-g6f48390 forced leavesub to copy returned items
if they were get-magical. Normally rvalue subs  are supposed to return a
copy of their return args, but that copy is sometimes skipped if leavesub
thinks the side-effects will never be visible. Tied elements was an
example where the implementation leaked.

However, this applies equally well to other leave types, such as
do { ....}, so test for get magic in those too.

pp_ctl.c
t/op/gmagic.t

index d1229af..c81df19 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2050,7 +2050,8 @@ S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme,
        if (MARK < SP) {
             SV *sv = *SP;
 
-           *++newsp = ((SvFLAGS(sv) & flags) && SvREFCNT(sv) == 1)
+           *++newsp = ((SvFLAGS(sv) & flags) && SvREFCNT(sv) == 1
+                         && !SvMAGICAL(sv))
                            ? sv 
                            : lvalue
                                ? sv_2mortal(SvREFCNT_inc_simple_NN(sv))
@@ -2065,7 +2066,8 @@ S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme,
        /* in case LEAVE wipes old return values */
        while (++MARK <= SP) {
             SV *sv = *MARK;
-           if ((SvFLAGS(sv) & flags) && SvREFCNT(sv) == 1)
+           if ((SvFLAGS(sv) & flags) && SvREFCNT(sv) == 1
+                         && !SvMAGICAL(sv))
                *++newsp = sv;
            else {
                *++newsp = lvalue
index 94e164e..43f8fdb 100644 (file)
@@ -181,6 +181,13 @@ ok($wgot == 0, 'a plain *foo causes no set-magic');
      'mortal magic var is explicitly returned to refgen';
   is tied $$x, undef,
      'mortal magic var is copied when explicitly returned';
+
+  $tied_to = tie $_{elem}, "Tie::Monitor";
+  $x = \do { 1; delete $_{elem} };
+  expected_tie_calls $tied_to, 1, 0,
+     'mortal magic var from do passed to refgen';
+  is tied $$x, undef,
+     'mortal magic var from do is copied';
 }
 
 done_testing();