diff options
| author | David Mitchell <davem@iabyn.com> | 2015-10-21 19:10:34 +0100 |
|---|---|---|
| committer | David Mitchell <davem@iabyn.com> | 2016-02-03 09:18:32 +0000 |
| commit | 86cc158350c1bc1d2159ec3dbf01e2800bca07dc (patch) | |
| tree | 4fe7484be7b99f9c50aada3ef0aa972d036e233b | |
| parent | b28bb06c3ca3128edebf1b46812096d79b69de97 (diff) | |
| download | perl-86cc158350c1bc1d2159ec3dbf01e2800bca07dc.tar.gz | |
extend magic copy test to all scope exit types
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.
| -rw-r--r-- | pp_ctl.c | 6 | ||||
| -rw-r--r-- | t/op/gmagic.t | 7 |
2 files changed, 11 insertions, 2 deletions
@@ -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 diff --git a/t/op/gmagic.t b/t/op/gmagic.t index 94e164e313..43f8fdbf59 100644 --- a/t/op/gmagic.t +++ b/t/op/gmagic.t @@ -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(); |