diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | op.c | 57 | ||||
| -rw-r--r-- | pad.c | 19 | ||||
| -rw-r--r-- | proto.h | 2 | ||||
| -rw-r--r-- | t/op/sub.t | 21 |
6 files changed, 26 insertions, 77 deletions
@@ -302,7 +302,7 @@ ApdR |SV* |gv_const_sv |NN GV* gv ApdR |SV* |cv_const_sv |NULLOK const CV *const cv pR |SV* |cv_const_sv_or_av|NULLOK const CV *const cv : Used in pad.c -pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv +pR |SV* |op_const_sv |NULLOK const OP* o Apd |void |cv_undef |NN CV* cv p |void |cv_forget_slab |NN CV *cv Ap |void |cx_dump |NN PERL_CONTEXT* cx @@ -1183,7 +1183,7 @@ #define nextargv(a) Perl_nextargv(aTHX_ a) #define oopsAV(a) Perl_oopsAV(aTHX_ a) #define oopsHV(a) Perl_oopsHV(aTHX_ a) -#define op_const_sv(a,b) Perl_op_const_sv(aTHX_ a,b) +#define op_const_sv(a) Perl_op_const_sv(aTHX_ a) #define op_unscope(a) Perl_op_unscope(aTHX_ a) #define package_version(a) Perl_package_version(aTHX_ a) #define pad_block_start(a) Perl_pad_block_start(aTHX_ a) @@ -6886,28 +6886,10 @@ Perl_cv_const_sv_or_av(pTHX_ const CV * const cv) } /* op_const_sv: examine an optree to determine whether it's in-lineable. - * Can be called in 3 ways: - * - * !cv - * look for a single OP_CONST with attached value: return the value - * - * cv && CvCLONE(cv) && !CvCONST(cv) - * - * examine the clone prototype, and if contains only a single - * OP_CONST referencing a pad const, or a single PADSV referencing - * an outer lexical, return a non-zero value to indicate the CV is - * a candidate for "constizing" at clone time - * - * cv && CvCONST(cv) - * - * We have just cloned an anon prototype that was marked as a const - * candidate. Try to grab the current value, and in the case of - * PADSV, ignore it if it has multiple references. In this case we - * return a newly created *copy* of the value. */ SV * -Perl_op_const_sv(pTHX_ const OP *o, CV *cv) +Perl_op_const_sv(pTHX_ const OP *o) { dVAR; SV *sv = NULL; @@ -6940,27 +6922,6 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv) return NULL; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; - else if (cv && type == OP_CONST) { - sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); - if (!sv) - return NULL; - } - else if (cv && type == OP_PADSV) { - if (CvCONST(cv)) { /* newly cloned anon */ - sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); - /* the candidate should have 1 ref from this pad and 1 ref - * from the parent */ - if (!sv || SvREFCNT(sv) != 2) - return NULL; - sv = newSVsv(sv); - SvREADONLY_on(sv); - return sv; - } - else { - if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) - sv = &PL_sv_undef; /* an arbitrary non-null value */ - } - } else { return NULL; } @@ -7129,7 +7090,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) ) const_sv = NULL; else - const_sv = op_const_sv(block, NULL); + const_sv = op_const_sv(block); if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7301,12 +7262,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); - if (CvCLONE(cv)) { - assert(!CvCONST(cv)); - if (ps && !*ps && op_const_sv(block, cv)) - CvCONST_on(cv); - } - attrs: if (attrs) { /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */ @@ -7504,7 +7459,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, ) const_sv = NULL; else - const_sv = op_const_sv(block, NULL); + const_sv = op_const_sv(block); if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7665,12 +7620,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); - if (CvCLONE(cv)) { - assert(!CvCONST(cv)); - if (ps && !*ps && op_const_sv(block, cv)) - CvCONST_on(cv); - } - attrs: if (attrs) { /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */ @@ -2183,25 +2183,6 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) cv_dump(cv, "To"); ); - if (CvCONST(cv)) { - /* Constant sub () { $x } closing over $x - see lib/constant.pm: - * The prototype was marked as a candiate for const-ization, - * so try to grab the current const value, and if successful, - * turn into a const sub: - */ - SV* const const_sv = op_const_sv(CvSTART(cv), cv); - if (const_sv) { - SvREFCNT_dec_NN(cv); - /* For this calling case, op_const_sv returns a *copy*, which we - donate to newCONSTSUB. Yes, this is ugly, and should be killed. - Need to fix how lib/constant.pm works to eliminate this. */ - cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); - } - else { - CvCONST_off(cv); - } - } - return cv; } @@ -3003,7 +3003,7 @@ PERL_CALLCONV void Perl_op_clear(pTHX_ OP* o) #define PERL_ARGS_ASSERT_OP_CLEAR \ assert(o) -PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o, CV* cv) +PERL_CALLCONV SV* Perl_op_const_sv(pTHX_ const OP* o) __attribute__warn_unused_result__; PERL_CALLCONV OP* Perl_op_contextualize(pTHX_ OP* o, I32 context) diff --git a/t/op/sub.t b/t/op/sub.t index 3546880157..56bbaaec66 100644 --- a/t/op/sub.t +++ b/t/op/sub.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan( tests => 23 ); +plan( tests => 26 ); sub empty_sub {} @@ -142,3 +142,22 @@ eval { ${\not_constantm}++ }; is $@, "", 'my sub (){42} returns a mutable value'; eval { ${\not_constantmr}++ }; is $@, "", 'my sub (){ return 42 } returns a mutable value'; + +# [perl #79908] +{ + my $x = 5; + *_79908 = sub (){$x}; + $x = 7; + is eval "_79908", 7, 'sub(){$x} does not break closures'; + isnt eval '\_79908', \$x, 'sub(){$x} returns a copy'; + + # Test another thing that was broken by $x inlinement + my $y; + no warnings 'once'; + local *time = sub():method{$y}; + my $w; + local $SIG{__WARN__} = sub { $w .= shift }; + eval "()=time"; + is $w, undef, + '*keyword = sub():method{$y} does not cause ambiguity warnings'; +} |