From f5b4df4d4bd28d083b2621ed5266a9fb57507d0e Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 3 Sep 2017 11:12:11 -0700 Subject: [PATCH 1/9] Add isGV_or_RVCV macro This will be useful for a few code paths that need to treat a sub ref in a stash the same way as a GV. --- sv.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/sv.h b/sv.h index a31bd73a5228..0fdb8c84bfd4 100644 --- a/sv.h +++ b/sv.h @@ -2146,6 +2146,10 @@ See also C> and C>. assert (!SvIOKp(sv)); \ (SvFLAGS(sv) &= ~SVpgv_GP); \ } STMT_END +#ifdef PERL_CORE +# define isGV_or_RVCV(kadawp) \ + (isGV(kadawp) || (SvROK(kadawp) && SvTYPE(SvRV(kadawp)) == SVt_PVCV)) +#endif #define isREGEXP(sv) \ (SvTYPE(sv) == SVt_REGEXP \ || (SvFLAGS(sv) & (SVTYPEMASK|SVpgv_GP|SVf_FAKE)) \ From 59a63b1b72b128736f53b046e6159d435a82f949 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 10 Sep 2017 13:59:47 -0700 Subject: [PATCH 2/9] [rt.cpan.org #123002] Fix NEXT.pm to work with GLOB stubs I need this in order to fix perl bug #129916. --- cpan/NEXT/lib/NEXT.pm | 6 ++++-- cpan/NEXT/t/next.t | 23 +++++++++++++++++------ 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/cpan/NEXT/lib/NEXT.pm b/cpan/NEXT/lib/NEXT.pm index cb87fb659b0c..74cd2b83a7de 100644 --- a/cpan/NEXT/lib/NEXT.pm +++ b/cpan/NEXT/lib/NEXT.pm @@ -64,17 +64,19 @@ sub NEXT::ELSEWHERE::buildAUTOLOAD last if shift @forebears eq $caller_class } no strict 'refs'; + # Use *{"..."} when first accessing the CODE slot, to make sure + # any typeglob stub is upgraded to a full typeglob. @{$NEXT::NEXT{$key,$wanted_method}} = map { my $stash = \%{"${_}::"}; - ($stash->{$caller_method} && (*{$stash->{$caller_method}}{CODE})) + ($stash->{$caller_method} && (*{"${_}::$caller_method"}{CODE})) ? *{$stash->{$caller_method}}{CODE} : () } @forebears unless $wanted_method eq 'AUTOLOAD'; @{$NEXT::NEXT{$key,$wanted_method}} = map { my $stash = \%{"${_}::"}; - ($stash->{AUTOLOAD} && (*{$stash->{AUTOLOAD}}{CODE})) + ($stash->{AUTOLOAD} && (*{"${_}::AUTOLOAD"}{CODE})) ? "${_}::AUTOLOAD" : () } @forebears unless @{$NEXT::NEXT{$key,$wanted_method}||[]}; diff --git a/cpan/NEXT/t/next.t b/cpan/NEXT/t/next.t index bdabd1486fed..fd9bea671c27 100644 --- a/cpan/NEXT/t/next.t +++ b/cpan/NEXT/t/next.t @@ -1,4 +1,4 @@ -BEGIN { print "1..26\n"; } +BEGIN { print "1..27\n"; } use NEXT; @@ -16,13 +16,13 @@ sub B::AUTOLOAD { return ( 9, $_[0]->NEXT::AUTOLOAD() ) sub B::DESTROY { $_[0]->NEXT::DESTROY() } package C; -sub C::DESTROY { print "ok 24\n"; $_[0]->NEXT::DESTROY() } +sub C::DESTROY { print "ok 25\n"; $_[0]->NEXT::DESTROY() } package D; @D::ISA = qw( B C E ); sub D::method { return ( 2, $_[0]->NEXT::method() ) } sub D::AUTOLOAD { return ( 8, $_[0]->NEXT::AUTOLOAD() ) } -sub D::DESTROY { print "ok 23\n"; $_[0]->NEXT::DESTROY() } +sub D::DESTROY { print "ok 24\n"; $_[0]->NEXT::DESTROY() } sub D::oops { $_[0]->NEXT::method() } sub D::secondary { return ( 17, 18, map { $_+10 } $_[0]->NEXT::secondary() ) } @@ -31,12 +31,12 @@ package E; sub E::method { return ( 4, $_[0]->NEXT::method(), $_[0]->NEXT::method() ) } sub E::AUTOLOAD { return ( 10, $_[0]->NEXT::AUTOLOAD() ) if $AUTOLOAD =~ /.*(missing_method|secondary)/ } -sub E::DESTROY { print "ok 25\n"; $_[0]->NEXT::DESTROY() } +sub E::DESTROY { print "ok 26\n"; $_[0]->NEXT::DESTROY() } package F; sub F::method { return ( 5 ) } sub F::AUTOLOAD { return ( 11 ) if $AUTOLOAD =~ /.*(missing_method|secondary)/ } -sub F::DESTROY { print "ok 26\n" } +sub F::DESTROY { print "ok 27\n" } package G; sub G::method { return ( 6 ) } @@ -104,4 +104,15 @@ eval { }; print "ok 22\n"; -# CAN REDISPATCH DESTRUCTORS (ok 23..26) +# TEST WITH CONSTANTS (23) + +package Hay; +@ISA = 'Bee'; +sub foo { return shift->NEXT::foo } +package Bee; +use constant foo => 3; +package main; +print "not " unless Hay->foo eq '3'; +print "ok 23\n"; + +# CAN REDISPATCH DESTRUCTORS (ok 24..27) From fba0c0a6c06a285db6583840a68940964bff1f87 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 10 Sep 2017 21:46:41 -0700 Subject: [PATCH 3/9] Make B::Concise handle subrefs in stashes The concise_stashref sub, for dumping all subroutines in a package, would assign the value of a stash element to *s, and then use *s to access the code ref in it. If you do *s = *foo and then later *s = \&bar, then you have assigned \&bar to *foo{CODE}, and even a localisation of *s beforehand will not help. That is exactly what B::Concise was doing when dumping a package with some subref elements. --- ext/B/B/Concise.pm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 6465a3c13135..a53e28f24fcc 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -145,13 +145,14 @@ sub concise_subref { sub concise_stashref { my($order, $h) = @_; - local *s; + my $name = svref_2object($h)->NAME; foreach my $k (sort keys %$h) { next unless defined $h->{$k}; - *s = $h->{$k}; - my $coderef = *s{CODE} or next; + my $coderef = ref $h->{$k} eq 'CODE' ? $h->{$k} + : ref\$h->{$k} eq 'GLOB' ? *{$h->{$k}}{CODE} || next + : next; reset_sequence(); - print "FUNC: ", *s, "\n"; + print "FUNC: *", $name, "::", $k, "\n"; my $codeobj = svref_2object($coderef); next unless ref $codeobj eq 'B::CV'; eval { concise_cv_obj($order, $codeobj, $k) }; From efec59086fbd10d2636e6f6d7c0c4d34edbe93ca Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 10 Sep 2017 21:49:14 -0700 Subject: [PATCH 4/9] Increase B::Concise::VERSION to 1.002 --- ext/B/B/Concise.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index a53e28f24fcc..86f773951440 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp use Exporter (); # use #5 -our $VERSION = "1.001"; +our $VERSION = "1.002"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main From 975601e92683a5f503e101106ecaa4f7c8b9d483 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 10 Sep 2017 21:51:50 -0700 Subject: [PATCH 5/9] Provisional version bump for NEXT.pm A patch ha- been submitted upstream already, so hopefully this version number will be short-lived. --- cpan/NEXT/lib/NEXT.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cpan/NEXT/lib/NEXT.pm b/cpan/NEXT/lib/NEXT.pm index 74cd2b83a7de..a2ad070f6512 100644 --- a/cpan/NEXT/lib/NEXT.pm +++ b/cpan/NEXT/lib/NEXT.pm @@ -5,7 +5,7 @@ use strict; use warnings; use overload (); -our $VERSION = '0.67'; +our $VERSION = '0.67_01'; sub NEXT::ELSEWHERE::ancestors { From a9cafc7854aa42b0323fc25662391f1e8d27a24b Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 24 Sep 2017 14:14:00 -0700 Subject: [PATCH 6/9] Deparse: Better constant-dumping heuristics MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Constants created via sub foo () { 1 } are stored in the stash as simple scalar references, under the CV-in-stash optimisation. That optimisation currently only applies to the main package, but will shortly be extended to other packages. This means B::Deparse’s heuristics for dumping the constants needs to be improved, to avoid dumping B::Deparse’s own constants for every program. The heuristic I am using (since CvFILE is not present on a scalar ref) is to record whether other subroutines in the same package as the con- stant are being dumped by virtue of having CvFILE pointing to a file that is being dumped. This assumption is that constants and subroutines in the same package are likely to be in the same file. --- lib/B/Deparse.pm | 13 +++++++++++++ lib/B/Deparse.t | 17 ++++++++++++++++- 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index fe4e24960d40..dc1b9c19fab3 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -512,6 +512,10 @@ sub todo { } else { $seq = 0; } + my $stash = $cv->STASH; + if (class($stash) eq 'HV') { + $self->{packs}{$stash->NAME}++; + } push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name]; } @@ -809,6 +813,14 @@ sub print_protos { my $ar; my @ret; foreach $ar (@{$self->{'protos_todo'}}) { + if (ref $ar->[1]) { + # Only print a constant if it occurs in the same package as a + # dumped sub. This is not perfect, but a heuristic that will + # hopefully work most of the time. Ideally we would use + # CvFILE, but a constant stub has no CvFILE. + my $pack = ($ar->[0] =~ /(.*)::/)[0]; + next if $pack and !$self->{packs}{$pack} + } my $body = defined $ar->[1] ? ref $ar->[1] ? " () {\n " . $self->const($ar->[1]->RV,0) . ";\n}" @@ -850,6 +862,7 @@ sub new { $self->{'ex_const'} = "'???'"; $self->{'expand'} = 0; $self->{'files'} = {}; + $self->{'packs'} = {}; $self->{'indent_size'} = 4; $self->{'linenums'} = 0; $self->{'parens'} = 0; diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index 62570edfa822..c61cfa2f6604 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -13,7 +13,7 @@ BEGIN { use warnings; use strict; -my $tests = 46; # not counting those in the __DATA__ section +my $tests = 49; # not counting those in the __DATA__ section use B::Deparse; my $deparse = B::Deparse->new(); @@ -152,6 +152,21 @@ $a =~ s/-e syntax OK\n//g; is($a, "use constant ('PI', 4);\n", "Proxy Constant Subroutines must not show up as (incorrect) prototypes"); +$a = `$^X $path "-MO=Deparse" -e "sub foo(){1}" 2>&1`; +$a =~ s/-e syntax OK\n//g; +is($a, "sub foo () {\n 1;\n}\n", + "Main prog consisting of just a constant (via empty proto)"); + +$a = readpipe qq|$^X $path "-MO=Deparse"| + .qq| -e "package F; sub f(){0} sub s{}"| + .qq| -e "#line 123 four-five-six"| + .qq| -e "package G; sub g(){0} sub s{}" 2>&1|; +$a =~ s/-e syntax OK\n//g; +like($a, qr/sub F::f \(\) \{\s*0;\s*}/, + "Constant is dumped in package in which other subs are dumped"); +unlike($a, qr/sub g/, + "Constant is not dumped in package in which other subs are not dumped"); + #Re: perlbug #35857, patch #24505 #handle warnings::register-ed packages properly. package B::Deparse::Wrapper; From d40d59b72ae37e2f89b98c8e1c4856c34c9242fd Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 24 Sep 2017 14:15:01 -0700 Subject: [PATCH 7/9] Increase $B::Deparse::VERSION to 1.43 --- lib/B/Deparse.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index dc1b9c19fab3..a1f7adcb6dfc 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -50,7 +50,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring MDEREF_SHIFT ); -$VERSION = '1.42'; +$VERSION = '1.43'; use strict; use vars qw/$AUTOLOAD/; use warnings (); From 6881372e19f63014452bb62329f9954deb042b2e Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Thu, 21 Sep 2017 07:06:05 -0700 Subject: [PATCH 8/9] [perl #129916] Allow sub-in-stash outside of main MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The sub-in-stash optimization introduced in 2eaf799e only applied to subs in the main stash, not in other stashes, due to a problem with the logic in newATTRSUB. This comment: Also, we may be called from load_module at run time, so PL_curstash (which sets CvSTASH) may not point to the stash the sub is stored in. explains why we need the PL_curstash != CopSTASH(PL_curcop) check. (Perl_load_module will fail without it.) But that logic does not work properly at compile time (when PL_curcop == &PL_compiling). The value of CopSTASH(&PL_compiling) is never actually used. It is always set to the main stash. So if we check that PL_curstash != CopSTASH(PL_curcop) and forego the optimization in that case, we will never optimize subs outside of the main stash. What we really need is to check IN_PERL_RUNTIME && PL_curstash != opSTASH(PL_curcop). I.e., forego the optimization at run time if the stashes differ. That is what this commit implements. One observable side effect of this change is that deleting a stash element no longer anonymizes the CV if the CV had no GV that it was depending on to provide its name. Since the main thing in such situa- tions is that we do not get a crash, I think this change (arguably an improvement) is acceptable.) ----------- A bit of explanation of various other changes: gv.c:require_tie_mod needed a bit of help, since it could not handle sub refs in stashes. To keep localisation of stash elements working the same way, local($Stash::{foo}) now upgrades a coderef to a full GV before the localisation. (Changes in two pp*.c files and in scope.c:save_gp.) t/op/stash.t contains a test that makes sure that perl does not crash when a GV with a CV pointing to it gets deleted. This commit tweaks the test so that it continues to test that. (There has to be a GV for the test to test what it is meant to test.) Similarly with t/uni/caller.t and t/uni/stash.t. op.c:rv2cv_op_cv with the _MAYBE_NAME_GV flag was returning the cal- ling GV in those cases where a GV-less sub is called via a GV. E.g., *main = \&Foo::foo; main(). This meant that errors like ‘Not enough arguments’ were giving the wrong sub name. newATTRSUB was not calling mro_method_changed_in when storing a sub as an RV. gv_init needs to arrange for the new GV to have the file and line num- ber corresponding to the sub in it. These are taken from CvSTART, which may be off by a few lines, but is the closest we have to the place the sub was declared. --- gv.c | 23 ++++++++++++++++++----- op.c | 24 ++++++++++++++++++++---- pad.c | 5 ++++- pp.c | 2 +- pp_hot.c | 2 +- scope.c | 11 +++++++++++ t/op/stash.t | 2 +- t/op/sub.t | 1 - t/uni/caller.t | 4 ++++ t/uni/stash.t | 2 +- 10 files changed, 61 insertions(+), 15 deletions(-) diff --git a/gv.c b/gv.c index eebf542e4720..5d963328e48e 100644 --- a/gv.c +++ b/gv.c @@ -373,6 +373,9 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag const U32 proto_utf8 = proto ? SvUTF8(gv) : 0; SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; + const bool really_sub = + has_constant && SvTYPE(has_constant) == SVt_PVCV; + COP * const old = PL_curcop; PERL_ARGS_ASSERT_GV_INIT_PVN; assert (!(proto && has_constant)); @@ -411,14 +414,19 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag SvIOK_off(gv); isGV_with_GP_on(gv); + if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant) + && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE + || CvSTART(has_constant)->op_type == OP_DBSTATE)) + PL_curcop = (COP *)CvSTART(has_constant); GvGP_set(gv, Perl_newGP(aTHX_ gv)); + PL_curcop = old; GvSTASH(gv) = stash; if (stash) Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 )); if (flags & GV_ADDMULTI || doproto) /* doproto means it */ GvMULTI_on(gv); /* _was_ mentioned */ - if (has_constant && SvTYPE(has_constant) == SVt_PVCV) { + if (really_sub) { /* Not actually a constant. Just a regular sub. */ CV * const cv = (CV *)has_constant; GvCV_set(gv,cv); @@ -1342,11 +1350,16 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, PUSHSTACKi(PERLSI_MAGIC); ENTER; -#define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0) +#define GET_HV_FETCH_TIE_FUNC \ + ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \ + && *gvp \ + && ( (isGV(*gvp) && GvCV(*gvp)) \ + || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \ + ) /* Load the module if it is not loaded. */ if (!(stash = gv_stashpvn(name, len, 0)) - || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) + || ! GET_HV_FETCH_TIE_FUNC) { SV * const module = newSVpvn(name, len); const char type = varname == '[' ? '$' : '%'; @@ -1358,12 +1371,12 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, if (!stash) Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", type, varname, name); - else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) + else if (! GET_HV_FETCH_TIE_FUNC) Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", type, varname, name); } /* Now call the tie function. It should be in *gvp. */ - assert(gvp); assert(*gvp); assert(GvCV(*gvp)); + assert(gvp); assert(*gvp); PUSHMARK(SP); XPUSHs((SV *)gv); PUTBACK; diff --git a/op.c b/op.c index 06ec00b1e935..c3e9f8085e3b 100644 --- a/op.c +++ b/op.c @@ -3769,6 +3769,13 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name, const char * oldp = SvPV(cSVOPx_sv(*proto), old_len); const char * newp = SvPV(cSVOPx_sv(new_proto), new_len); + if (curstash && svname == (SV *)name + && !memchr(SvPVX(svname), ':', SvCUR(svname))) { + svname = sv_2mortal(newSVsv(PL_curstname)); + sv_catpvs(svname, "::"); + sv_catsv(svname, (SV *)name); + } + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'" " in %" SVf, @@ -8583,7 +8590,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, sub is stored in. */ const I32 flags = ec ? GV_NOADD_NOINIT - : PL_curstash != CopSTASH(PL_curcop) + : IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop) || memchr(name, ':', namlen) || memchr(name, '\'', namlen) ? gv_fetch_flags : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL; @@ -8900,6 +8907,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, SvROK_on(gv); } SvRV_set(gv, (SV *)cv); + if (HvENAME_HEK(PL_curstash)) + mro_method_changed_in(PL_curstash); } } @@ -11598,11 +11607,18 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) } if (SvTYPE((SV*)cv) != SVt_PVCV) return NULL; - if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) { - if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv) - && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv))) + if (flags & RV2CVOPCV_RETURN_NAME_GV) { + if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv) gv = CvGV(cv); return (CV*)gv; + } + else if (flags & RV2CVOPCV_MAYBE_NAME_GV) { + if (CvLEXICAL(cv) || CvNAMED(cv)) + return NULL; + if (!CvANON(cv) || !gv) + gv = CvGV(cv); + return (CV*)gv; + } else { return cv; } diff --git a/pad.c b/pad.c index bbc835ab31d6..9c20d66e94e9 100644 --- a/pad.c +++ b/pad.c @@ -2295,7 +2295,10 @@ Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags) if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) sv_sethek(retsv, CvNAME_HEK(cv)); else { - sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv))); + if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv))) + sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv))); + else + sv_setpvs(retsv, "__ANON__"); sv_catpvs(retsv, "::"); sv_cathek(retsv, CvNAME_HEK(cv)); } diff --git a/pp.c b/pp.c index 46366c3bd2bd..822b6945b83d 100644 --- a/pp.c +++ b/pp.c @@ -5045,7 +5045,7 @@ PP(pp_hslice) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); } if (localizing) { - if (HvNAME_get(hv) && isGV(*svp)) + if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); else if (preeminent) save_helem_flags(hv, keysv, svp, diff --git a/pp_hot.c b/pp_hot.c index 40b850780c6e..f356d0935385 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2561,7 +2561,7 @@ PP(pp_helem) RETURN; } if (localizing) { - if (HvNAME_get(hv) && isGV(*svp)) + if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); else if (preeminent) save_helem_flags(hv, keysv, svp, diff --git a/scope.c b/scope.c index dfaab806aa4e..7da26a48fef1 100644 --- a/scope.c +++ b/scope.c @@ -330,6 +330,17 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty) { PERL_ARGS_ASSERT_SAVE_GP; + /* XXX For now, we just upgrade any coderef in the stash to a full GV + during localisation. Maybe at some point we could make localis- + ation work without needing the upgrade. (In which case our + callers should probably call a different function, not save_gp.) + */ + if (!isGV(gv)) { + assert(isGV_or_RVCV(gv)); + (void)CvGV(SvRV((SV *)gv)); /* CvGV does the upgrade */ + assert(isGV(gv)); + } + save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP); if (empty) { diff --git a/t/op/stash.t b/t/op/stash.t index c9634a370a86..a507c4239db1 100644 --- a/t/op/stash.t +++ b/t/op/stash.t @@ -179,7 +179,7 @@ SKIP: { package FOO3; sub named {}; my $anon = sub {}; - my $named = eval q[\&named]; + my $named = eval q[*named{CODE}]; # not \&named; we want a real GV package main; delete $FOO3::{named}; # make named anonymous diff --git a/t/op/sub.t b/t/op/sub.t index 5c501b181ee5..f73abb455f4f 100644 --- a/t/op/sub.t +++ b/t/op/sub.t @@ -423,7 +423,6 @@ is ref($main::{rt_129916}), 'CODE', 'simple sub stored as CV in stash (main::)'; sub foo { 42 } } { - local $TODO = "CV symbol table optimization only works in main:: [perl #129916]"; is ref($RT129916::{foo}), 'CODE', 'simple sub stored as CV in stash (non-main::)'; } diff --git a/t/uni/caller.t b/t/uni/caller.t index de314b0a3131..c48018c1ee55 100644 --- a/t/uni/caller.t +++ b/t/uni/caller.t @@ -26,6 +26,9 @@ sub { @c = caller(0) } -> (); # Bug 20020517.003 (#9367), used to dump core sub ｆｏｏ { @c = caller(0) } +# The subroutine only gets anonymised if it is relying on a real GV +# for its name. +() = *{"ｆｏｏ"}; # with quotes so that the op tree doesn’t reference the GV my $fooref = delete $ｍａｉｎ::{ｆｏｏ}; $fooref -> (); ::is( $c[3], "ｍａｉｎ::__ANON__", "deleted subroutine name" ); @@ -55,6 +58,7 @@ sub { ｆ() } -> (); ::ok( $c[4], "hasargs true with anon sub" ); sub ｆｏｏ2 { ｆ() } +() = *{"ｆｏｏ2"}; # see ｆｏｏ notes above my $fooref2 = delete $ｍａｉｎ::{ｆｏｏ2}; $fooref2 -> (); ::is( $c[3], "ｍａｉｎ::__ANON__", "deleted subroutine name" ); diff --git a/t/uni/stash.t b/t/uni/stash.t index 31d6c9d9b280..e329faab25bb 100644 --- a/t/uni/stash.t +++ b/t/uni/stash.t @@ -170,7 +170,7 @@ plan( tests => 49 ); package ＦŌŌ３; sub 남えㄉ {}; my $anon = sub {}; - my $남えㄉ = eval q[\&남えㄉ]; + my $남えㄉ = eval q[*남えㄉ{CODE}]; # not \&남えㄉ; need a real GV package main; delete $ＦŌŌ３::{남えㄉ}; # make named anonymous From a35c901808a982f357645ef262e94f60300ddd23 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sun, 24 Sep 2017 16:48:48 -0700 Subject: [PATCH 9/9] Make pp_multideref handle local $::{subref} Based on a patch by Nicholas R. --- pp_hot.c | 2 +- t/op/local.t | 20 +++++++++++++++++++- 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/pp_hot.c b/pp_hot.c index f356d0935385..ea918474fc96 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2997,7 +2997,7 @@ PP(pp_multideref) } else { if (localizing) { - if (HvNAME_get(hv) && isGV(sv)) + if (HvNAME_get(hv) && isGV_or_RVCV(sv)) save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL)); else if (preeminent) { diff --git a/t/op/local.t b/t/op/local.t index e88798a8ac9b..df1413a8a0d1 100644 --- a/t/op/local.t +++ b/t/op/local.t @@ -5,7 +5,7 @@ BEGIN { require './test.pl'; set_up_inc( qw(. ../lib) ); } -plan tests => 315; +plan tests => 319; my $list_assignment_supported = 1; @@ -670,6 +670,8 @@ is($@, ""); sub f1 { "f1" } sub f2 { "f2" } + sub f3 { "f3" } + sub f4 { "f4" } no warnings "redefine"; { @@ -682,6 +684,22 @@ is($@, ""); ::ok(f1() eq "h1", "localised sub via stash"); } ::ok(f1() eq "f1", "localised sub restored"); + # Do that test again, but with a different glob, to make sure that + # localisation via multideref can handle a subref in a stash. + # (The local *f1 above will have ensured that we have a full glob, + # not a sub ref.) + { + local $Other::{"f3"} = sub { "h1" }; + ::ok(f3() eq "h1", "localised sub via stash"); + } + ::ok(f3() eq "f3", "localised sub restored"); + # Also, we need to test pp_helem, which we can do by using a more + # complex subscript. + { + local $Other::{${\"f4"}} = sub { "h1" }; + ::ok(f4() eq "h1", "localised sub via stash"); + } + ::ok(f4() eq "f4", "localised sub restored"); { local @Other::{qw/ f1 f2 /} = (sub { "j1" }, sub { "j2" }); ::ok(f1() eq "j1", "localised sub via stash slice");