In perl.git, the branch sprout/misc-post-5.16 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/97ca83f971e6173484e08cec505237f1d91cc399?hp=3723f8ceacbe2b2d30f71843e05dc3c6f3e79c03>
- Log ----------------------------------------------------------------- commit 97ca83f971e6173484e08cec505237f1d91cc399 Author: Father Chrysostomos <[email protected]> Date: Wed Apr 25 18:29:12 2012 -0700 Make lvalue subs copy returned PADTMPs in rvalue cx I was trying to write a JAPH, but did not get what I expected: $ ./perl -Ilib -e '@UNIVERSAL::ISA = CORE; print "just another "->ucfirst, "perl hacker,\n"->ucfirst' Perl hacker, Perl hacker, This happened because coresubs use leavesublv, to avoid copying the return value wastefully. But since this is exactly the same ucfirst op being called each time (the one in &CORE::ucfirstâs op tree), and since ucfirst uses TARG, we end up with the same scalar. We have the same problem with lvalue subs: $ ./perl -Ilib -e 'sub UNIVERSAL::ucfirst :lvalue { ucfirst $_[0] } print "just another "->ucfirst, "perl hacker,\n"->ucfirst' Perl hacker, Perl hacker, (This is not a regression, as 5.14 gave âCan't modify ucfirst in lvalue subroutine returnâ.) So âfixingâ coresubs would not be a solution, but a workaround. The solution therefore is for leavesublv to copy PADTMPs in rvalue context. Commit 80422e24c fixed this for potential lvalue list context (i.e., for(lvsub()) {...}), but it wasnât sufficient. M pp_ctl.c M t/op/coresubs.t M t/op/sub_lval.t commit 50d6ee10fb1ea8f49d625491e5b586f94f5529ac Author: Father Chrysostomos <[email protected]> Date: Wed Apr 25 14:08:48 2012 -0700 scope.c: Simplify and clarify comment This comment seems to imply that this code is just working around a problem in gv.c, which we could simply correct there. Iâve already tried making the quoted code in gv.c handle *^H without a hash, but it doesnât actually solve the problem. The real problem is that rv2hv could also add a hash to *^H, via GvHVn, and that is simply not set up to deal with autovivifying magic at all, and probably shouldnât be. Also, quoting a piece of code that occurs elsewhere is just asking for it to drift apart. By this time, the code in gv.c that is quoted in scope.c is actually three times the length now, and looks completely different. M scope.c commit db2036fcd0869c5b735bd570a1f4a52ced96f8b8 Author: Dagfinn Ilmari MannsÃ¥ker <[email protected]> Date: Mon Apr 16 01:05:52 2012 +0100 Don't warn about "ambiguous without parens" for ctrl-glob This fixes the following bogus warning [perl #112456]: $ perl -e 'undef *^H' Warning: Use of "undef" without parentheses is ambiguous at -e line 1. Compare to the non-warning variant: $ perl -e 'undef *{^H}' M t/lib/warnings/toke M toke.c ----------------------------------------------------------------------- Summary of changes: pp_ctl.c | 19 +++++++++++++++---- scope.c | 17 ++--------------- t/lib/warnings/toke | 2 ++ t/op/coresubs.t | 5 +++++ t/op/sub_lval.t | 20 +++++++++++++++++++- toke.c | 4 ++-- 6 files changed, 45 insertions(+), 22 deletions(-) diff --git a/pp_ctl.c b/pp_ctl.c index 3aa0204..4e54bd3 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2370,13 +2370,24 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, if (MARK < SP) { copy_sv: if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { + if (!SvPADTMP(*SP)) { *++newsp = SvREFCNT_inc(*SP); FREETMPS; sv_2mortal(*newsp); + } + else { + /* FREETMPS could clobber it */ + SV *sv = SvREFCNT_inc(*SP); + FREETMPS; + *++newsp = sv_mortalcopy(sv); + SvREFCNT_dec(sv); + } } else *++newsp = - !SvTEMP(*SP) + SvPADTMP(*SP) + ? sv_mortalcopy(*SP) + : !SvTEMP(*SP) ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) : *SP; } @@ -2396,10 +2407,10 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, if (ref || !CxLVAL(cx)) while (++MARK <= SP) *++newsp = - SvTEMP(*MARK) - ? *MARK - : ref && SvFLAGS(*MARK) & SVs_PADTMP + SvFLAGS(*MARK) & SVs_PADTMP ? sv_mortalcopy(*MARK) + : SvTEMP(*MARK) + ? *MARK : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); else while (++MARK <= SP) { if (*MARK != &PL_sv_undef diff --git a/scope.c b/scope.c index ffd0552..a939f64 100644 --- a/scope.c +++ b/scope.c @@ -1038,21 +1038,8 @@ Perl_leave_scope(pTHX_ I32 base) GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR); } if (!GvHV(PL_hintgv)) { - /* Need to add a new one manually, else gv_fetchpv() can - add one in this code: - - if (SvTYPE(gv) == SVt_PVGV) { - if (add) { - GvMULTI_on(gv); - gv_init_sv(gv, sv_type); - if (*name=='!' && sv_type == SVt_PVHV && len==1) - require_errno(gv); - } - return gv; - } - - and it won't have the magic set. */ - + /* Need to add a new one manually, else rv2hv can + add one via GvHVn and it won't have the magic set. */ HV *const hv = newHV(); hv_magic(hv, NULL, PERL_MAGIC_hints); GvHV(PL_hintgv) = hv; diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke index dd8dc3d..a9106fb 100644 --- a/t/lib/warnings/toke +++ b/t/lib/warnings/toke @@ -662,6 +662,8 @@ yelp at foo line 30. ######## # toke.c my $a = rand + 4 ; +$a = rand *^H ; +$a = rand $^H ; EXPECT Warning: Use of "rand" without parentheses is ambiguous at - line 2. ######## diff --git a/t/op/coresubs.t b/t/op/coresubs.t index b0263ee..85084bb 100644 --- a/t/op/coresubs.t +++ b/t/op/coresubs.t @@ -125,6 +125,11 @@ $tests++; ok eval { *CORE::exit = \42 }, '[rt.cpan.org #74289] *CORE::foo is not accidentally made read-only'; +@UNIVERSAL::ISA = CORE; +is "just another "->ucfirst . "perl hacker,\n"->ucfirst, + "Just another Perl hacker,\n", 'coresubs do not return TARG'; +++$tests; + done_testing $tests; CORE::__END__ diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t index 7008caf..b2f56e3 100644 --- a/t/op/sub_lval.t +++ b/t/op/sub_lval.t @@ -3,7 +3,7 @@ BEGIN { @INC = '../lib'; require './test.pl'; } -plan tests=>187; +plan tests=>191; sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary sub b : lvalue { ${\shift} } @@ -944,3 +944,21 @@ package _102486 { ::like $@, qr/^Can't modify non-lvalue subroutine call at /, 'sub:lvalue{&$x}->() dies in true lvalue context'; } + +# TARG should be copied in rvalue context +sub ucf :lvalue { ucfirst $_[0] } +is ucf("just another ") . ucf("perl hacker,\n"), + "Just another Perl hacker,\n", 'TARG is copied in rvalue scalar cx'; +is join('',ucf("just another "), ucf "perl hacker,\n"), + "Just another Perl hacker,\n", 'TARG is copied in rvalue list cx'; +sub ucfr : lvalue { + @_ ? ucfirst $_[0] : do { + is ucfr("just another ") . ucfr("perl hacker,\n"), + "Just another Perl hacker,\n", + 'TARG is copied in recursive rvalue scalar cx'; + is join('',ucfr("just another "), ucfr("perl hacker,\n")), + "Just another Perl hacker,\n", + 'TARG is copied in recursive rvalue list cx'; + } +} +ucfr(); diff --git a/toke.c b/toke.c index 1d18550..6cc0336 100644 --- a/toke.c +++ b/toke.c @@ -8892,8 +8892,6 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL bracket = s; s++; } - else if (ck_uni) - check_uni(); if (s < send) { if (UTF) { const STRLEN skip = UTF8SKIP(s); @@ -8911,6 +8909,8 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL *d = toCTRL(*s); s++; } + else if (ck_uni && !bracket) + check_uni(); if (bracket) { if (isSPACE(s[-1])) { while (s < send) { -- Perl5 Master Repository
