In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/1369fd508410a5ab354672cedce158f1e9c653c9?hp=738f9dbfd2c2579147ef1010c651a0baeca1e5d4>
- Log -----------------------------------------------------------------
commit 1369fd508410a5ab354672cedce158f1e9c653c9
Merge: 738f9dbfd2 a35c901808
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 8 14:54:13 2017 -0700
[Merge] [perl #129916] Allow sub-in-stash outside of main
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 branch includes various commits to fix the issue and other prob-
lems that the fix uncovered.
commit a35c901808a982f357645ef262e94f60300ddd23
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Sep 24 16:48:48 2017 -0700
Make pp_multideref handle local $::{subref}
Based on a patch by Nicholas R.
M pp_hot.c
M t/op/local.t
commit 6881372e19f63014452bb62329f9954deb042b2e
Author: Father Chrysostomos <spr...@cpan.org>
Date: Thu Sep 21 07:06:05 2017 -0700
[perl #129916] Allow sub-in-stash outside of main
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.
M gv.c
M op.c
M pad.c
M pp.c
M pp_hot.c
M scope.c
M t/op/stash.t
M t/op/sub.t
M t/uni/caller.t
M t/uni/stash.t
commit d40d59b72ae37e2f89b98c8e1c4856c34c9242fd
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Sep 24 14:15:01 2017 -0700
Increase $B::Deparse::VERSION to 1.43
M lib/B/Deparse.pm
commit a9cafc7854aa42b0323fc25662391f1e8d27a24b
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Sep 24 14:14:00 2017 -0700
Deparse: Better constant-dumping heuristics
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.
M lib/B/Deparse.pm
M lib/B/Deparse.t
commit 975601e92683a5f503e101106ecaa4f7c8b9d483
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Sep 10 21:51:50 2017 -0700
Provisional version bump for NEXT.pm
A patch ha- been submitted upstream already, so hopefully this version
number will be short-lived.
M cpan/NEXT/lib/NEXT.pm
commit efec59086fbd10d2636e6f6d7c0c4d34edbe93ca
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Sep 10 21:49:14 2017 -0700
Increase B::Concise::VERSION to 1.002
M ext/B/B/Concise.pm
commit fba0c0a6c06a285db6583840a68940964bff1f87
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Sep 10 21:46:41 2017 -0700
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.
M ext/B/B/Concise.pm
commit 59a63b1b72b128736f53b046e6159d435a82f949
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Sep 10 13:59:47 2017 -0700
[rt.cpan.org #123002] Fix NEXT.pm to work with GLOB stubs
I need this in order to fix perl bug #129916.
M cpan/NEXT/lib/NEXT.pm
M cpan/NEXT/t/next.t
commit f5b4df4d4bd28d083b2621ed5266a9fb57507d0e
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Sep 3 11:12:11 2017 -0700
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.
M sv.h
-----------------------------------------------------------------------
Summary of changes:
cpan/NEXT/lib/NEXT.pm | 8 +++++---
cpan/NEXT/t/next.t | 23 +++++++++++++++++------
ext/B/B/Concise.pm | 11 ++++++-----
gv.c | 23 ++++++++++++++++++-----
lib/B/Deparse.pm | 15 ++++++++++++++-
lib/B/Deparse.t | 17 ++++++++++++++++-
op.c | 24 ++++++++++++++++++++----
pad.c | 5 ++++-
pp.c | 2 +-
pp_hot.c | 4 ++--
scope.c | 11 +++++++++++
sv.h | 4 ++++
t/op/local.t | 20 +++++++++++++++++++-
t/op/stash.t | 2 +-
t/op/sub.t | 1 -
t/uni/caller.t | 4 ++++
t/uni/stash.t | 2 +-
17 files changed, 143 insertions(+), 33 deletions(-)
diff --git a/cpan/NEXT/lib/NEXT.pm b/cpan/NEXT/lib/NEXT.pm
index cb87fb659b..a2ad070f65 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
{
@@ -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 bdabd1486f..fd9bea671c 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)
diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 6465a3c131..86f7739514 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
@@ -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) };
diff --git a/gv.c b/gv.c
index eebf542e47..5d963328e4 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/lib/B/Deparse.pm b/lib/B/Deparse.pm
index fe4e24960d..a1f7adcb6d 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 ();
@@ -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 62570edfa8..c61cfa2f66 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;
diff --git a/op.c b/op.c
index 06ec00b1e9..c3e9f8085e 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 bbc835ab31..9c20d66e94 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 46366c3bd2..822b6945b8 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 40b850780c..ea918474fc 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,
@@ -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/scope.c b/scope.c
index dfaab806aa..7da26a48fe 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/sv.h b/sv.h
index a31bd73a52..0fdb8c84bf 100644
--- a/sv.h
+++ b/sv.h
@@ -2146,6 +2146,10 @@ See also C<L</PL_sv_yes>> and C<L</PL_sv_no>>.
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)) \
diff --git a/t/op/local.t b/t/op/local.t
index e88798a8ac..df1413a8a0 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");
diff --git a/t/op/stash.t b/t/op/stash.t
index c9634a370a..a507c4239d 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 5c501b181e..f73abb455f 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 de314b0a31..c48018c1ee 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 31d6c9d9b2..e329faab25 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
--
Perl5 Master Repository
