diff options
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | op.c | 7 | ||||
| -rw-r--r-- | pad.c | 18 | ||||
| -rw-r--r-- | proto.h | 5 | ||||
| -rw-r--r-- | t/op/sub.t | 14 |
6 files changed, 42 insertions, 4 deletions
@@ -2552,6 +2552,7 @@ Apd |PADOFFSET|pad_add_name_sv|NN SV *name\ |NULLOK HV *ourstash AMpd |PADOFFSET|pad_alloc |I32 optype|U32 tmptype Apd |PADOFFSET|pad_add_anon |NN CV* func|I32 optype +p |void |pad_add_weakref|NN CV* func #if defined(PERL_IN_PAD_C) sd |void |pad_check_dup |NN PADNAME *name|U32 flags \ |NULLOK const HV *ourstash @@ -1261,6 +1261,7 @@ #define op_unscope(a) Perl_op_unscope(aTHX_ a) #define package(a) Perl_package(aTHX_ a) #define package_version(a) Perl_package_version(aTHX_ a) +#define pad_add_weakref(a) Perl_pad_add_weakref(aTHX_ a) #define pad_block_start(a) Perl_pad_block_start(aTHX_ a) #define pad_fixup_inner_anons(a,b,c) Perl_pad_fixup_inner_anons(aTHX_ a,b,c) #define pad_free(a) Perl_pad_free(aTHX_ a) @@ -8449,10 +8449,10 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); + bool special = FALSE; OP *start; #ifdef PERL_DEBUG_READONLY_OPS OPSLAB *slab = NULL; - bool special = FALSE; #endif if (o_is_gv) { @@ -8856,9 +8856,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (PL_parser && PL_parser->error_count) clear_special_blocks(name, gv, cv); else -#ifdef PERL_DEBUG_READONLY_OPS special = -#endif process_special_blocks(floor, name, gv, cv); } } @@ -8872,6 +8870,9 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (!special && slab) Slab_to_ro(slab); #endif + if (cv && name && (!special || *name != 'B') && CvOUTSIDE(cv) + && !CvEVAL(CvOUTSIDE(cv))) + pad_add_weakref(cv); return cv; } @@ -829,6 +829,24 @@ Perl_pad_add_anon(pTHX_ CV* func, I32 optype) return ix; } +void +Perl_pad_add_weakref(pTHX_ CV* func) +{ + const PADOFFSET ix = pad_alloc(OP_NULL, SVs_PADMY); + PADNAME * const name = newPADNAMEpvn("&", 1); + SV * const rv = newRV_inc((SV *)func); + + PERL_ARGS_ASSERT_PAD_ADD_WEAKREF; + + /* These two aren't used; just make sure they're not equal to + * PERL_PADSEQ_INTRO. They should be 0 by default. */ + assert(COP_SEQ_RANGE_LOW (name) != PERL_PADSEQ_INTRO); + assert(COP_SEQ_RANGE_HIGH(name) != PERL_PADSEQ_INTRO); + padnamelist_store(PL_comppad_name, ix, name); + sv_rvweaken(rv); + av_store(PL_comppad, ix, rv); +} + /* =for apidoc pad_check_dup @@ -3326,6 +3326,11 @@ PERL_CALLCONV PADOFFSET Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *type #define PERL_ARGS_ASSERT_PAD_ADD_NAME_SV \ assert(name) +PERL_CALLCONV void Perl_pad_add_weakref(pTHX_ CV* func) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_PAD_ADD_WEAKREF \ + assert(func) + PERL_CALLCONV PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype); PERL_CALLCONV void Perl_pad_block_start(pTHX_ int full); PERL_CALLCONV HV* Perl_pad_compname_type(pTHX_ const PADOFFSET po) diff --git a/t/op/sub.t b/t/op/sub.t index db61ac2e02..154ab1ec87 100644 --- a/t/op/sub.t +++ b/t/op/sub.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc('../lib'); } -plan( tests => 35 ); +plan( tests => 36 ); sub empty_sub {} @@ -233,3 +233,15 @@ package _122845 { }; is $_122845::ok, 1, '[perl #122845] no crash in closure recursion with our-vars'; + +() = *predeclared; # vivify the glob at compile time +sub predeclared; # now we have a CV stub with no body (incorporeal? :-) +sub predeclared { + CORE::state $x = 42; + sub inside_predeclared { + is eval '$x', 42, 'eval q/$var/ in named sub in predeclared sub'; + } +} +predeclared(); # set $x to 42 +$main::x = $main::x = "You should not see this."; +inside_predeclared(); # run test |