In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/0740a29d60ebd4ff72090340b0140ec2210e90c7?hp=28ef70489d76deb9024de42a0571162f323148c8>
- Log -----------------------------------------------------------------
commit 0740a29d60ebd4ff72090340b0140ec2210e90c7
Author: Zefram <zef...@fysh.org>
Date: Tue Dec 5 06:13:27 2017 +0000
stop using &PL_sv_yes as no-op method
Method lookup yields a fake method for ->import or ->unimport if there's
no actual method, for historical reasons so that "use" doesn't barf
if there's no import method. This fake method used to be &PL_sv_yes
being used as a magic placeholder, recognised specially by pp_entersub.
But &PL_sv_yes is a string, which we'd expect to serve as a symbolic
CV ref. Change method lookup to yield an actual CV with a body in this
case, and remove the special case from pp_entersub. This fixes the
remaining part of [perl #126042].
-----------------------------------------------------------------------
Summary of changes:
ext/XS-APItest/APItest.xs | 10 +++++++++-
ext/XS-APItest/t/call.t | 2 +-
gv.c | 7 ++++---
pp_hot.c | 10 ----------
t/op/method.t | 47 +++++++++++++++++++++++++++++------------------
t/op/sub.t | 26 +-------------------------
6 files changed, 44 insertions(+), 58 deletions(-)
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 5ceb7fe939..891b7e71d4 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -2339,9 +2339,17 @@ CODE:
only current internal behavior, these tests can be changed in the
future if necessery */
PUSHMARK(SP);
- retcnt = call_sv(&PL_sv_yes, 0); /* does nothing */
+ retcnt = call_sv(&PL_sv_yes, G_EVAL);
SPAGAIN;
SP -= retcnt;
+ errsv = ERRSV;
+ errstr = SvPV(errsv, errlen);
+ if(memBEGINs(errstr, errlen, "Undefined subroutine &main::1 called at")) {
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
+ SPAGAIN;
+ SP -= retcnt;
+ }
PUSHMARK(SP);
retcnt = call_sv(&PL_sv_no, G_EVAL);
SPAGAIN;
diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index 355e49886e..8192b9bd36 100644
--- a/ext/XS-APItest/t/call.t
+++ b/ext/XS-APItest/t/call.t
@@ -33,7 +33,7 @@ sub i {
$call_sv_count++;
}
call_sv_C();
-is($call_sv_count, 6, "call_sv_C passes");
+is($call_sv_count, 7, "call_sv_C passes");
sub d {
die "its_dead_jim\n";
diff --git a/gv.c b/gv.c
index bc5b388588..00adb8995c 100644
--- a/gv.c
+++ b/gv.c
@@ -1091,9 +1091,10 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const
char *name, const STRLEN le
/* This is the special case that exempts Foo->import and
Foo->unimport from being an error even if there's no
import/unimport subroutine */
- if (strEQ(name,"import") || strEQ(name,"unimport"))
- gv = MUTABLE_GV(&PL_sv_yes);
- else if (autoload)
+ if (strEQ(name,"import") || strEQ(name,"unimport")) {
+ gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
+ NULL, 0, 0, NULL));
+ } else if (autoload)
gv = gv_autoload_pvn(
ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
);
diff --git a/pp_hot.c b/pp_hot.c
index 7609638b8f..87e60970d6 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -5007,16 +5007,6 @@ PP(pp_entersub)
if (UNLIKELY(!SvOK(sv)))
DIE(aTHX_ PL_no_usym, "a subroutine");
- if (UNLIKELY(sv == &PL_sv_yes)) { /* unfound import, ignore */
- if (PL_op->op_flags & OPf_STACKED) /* hasargs */
- SP = PL_stack_base + POPMARK;
- else
- (void)POPMARK;
- if (GIMME_V == G_SCALAR)
- PUSHs(&PL_sv_undef);
- RETURN;
- }
-
sym = SvPV_nomg_const(sv, len);
if (PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a
subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
diff --git a/t/op/method.t b/t/op/method.t
index 82f8263a10..d0fc321804 100644
--- a/t/op/method.t
+++ b/t/op/method.t
@@ -13,7 +13,35 @@ BEGIN {
use strict;
no warnings 'once';
-plan(tests => 151);
+plan(tests => 162);
+
+{
+ # RT #126042 &{1==1} * &{1==1} would crash
+ # There are two issues here. Method lookup yields a fake method for
+ # ->import or ->unimport if there's no actual method, for historical
+ # reasons so that "use" doesn't barf if there's no import method.
+ # The first bug, the one which caused the crash, is that the fake
+ # method was broken in scalar context, messing up the stack. We test
+ # for that on its own.
+ foreach my $meth (qw(import unimport)) {
+ is join(",", map { $_ // "u" } "a", "b", "Unknown"->$meth, "c", "d"),
"a,b,c,d", "Unknown->$meth in list context";
+ is join(",", map { $_ // "u" } "a", "b", scalar("Unknown"->$meth), "c",
"d"), "a,b,u,c,d", "Unknown->$meth in scalar context";
+ }
+ # The second issue is that the fake method wasn't actually a CV or
+ # anything referencing a CV, but was &PL_sv_yes being used as a magic
+ # placeholder. That's inconsistent with &PL_sv_yes being a string,
+ # which we'd expect to serve as a symbolic CV ref. This test must
+ # come before AUTOLOAD gets set up below.
+ foreach my $one (1, !!1) {
+ my @res = eval { no strict "refs"; &$one() };
+ like $@, qr/\AUndefined subroutine \&main::1 called at /;
+ @res = eval { no strict "refs"; local *1 = sub { 123 }; &$one() };
+ is $@, "";
+ is "@res", "123";
+ @res = eval { &$one() };
+ like $@, qr/\ACan't use string \("1"\) as a subroutine ref while
"strict refs" in use at /;
+ }
+}
@A::ISA = 'BB';
@BB::ISA = 'C';
@@ -687,23 +715,6 @@ SKIP: {
like ($@, qr/Modification of a read-only value attempted/, 'RT #123619');
}
-{
- # RT #126042 &{1==1} * &{1==1} would crash
-
- # pp_entersub and pp_method_named cooperate to prevent calls to an
- # undefined import() or unimport() method from croaking.
- # If pp_method_named can't find the method it pushes &PL_sv_yes, and
- # pp_entersub checks for that specific SV to avoid croaking.
- # Ideally they wouldn't use that hack but...
- # Unfortunately pp_entersub's handling of that case is broken in scalar
context.
-
- # Rather than using the test case from the ticket, since &{1==1}
- # isn't documented (and may not be supported in future perls) test
- # calls to undefined import method, which also crashes.
- fresh_perl_is('Unknown->import() * Unknown->unimport(); print "ok\n"',
"ok\n", {},
- "check unknown import() methods don't corrupt the stack");
-}
-
# RT#130496: assertion failure when looking for a method of undefined name
# on an unblessed reference
fresh_perl_is('eval { {}->$x }; print $@;',
diff --git a/t/op/sub.t b/t/op/sub.t
index f73abb455f..5de358ebf3 100644
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -6,7 +6,7 @@ BEGIN {
set_up_inc('../lib');
}
-plan(tests => 65);
+plan(tests => 61);
sub empty_sub {}
@@ -17,30 +17,6 @@ is(scalar(@test), 0, 'Didnt return anything');
@test = empty_sub(1,2,3);
is(scalar(@test), 0, 'Didnt return anything');
-# RT #63790: calling PL_sv_yes as a sub is special-cased to silently
-# return (so Foo->import() silently fails if import() doesn't exist),
-# But make sure it correctly pops the stack and mark stack before returning.
-
-{
- my @a;
- push @a, 4, 5, main->import(6,7);
- ok(eq_array(\@a, [4,5]), "import with args");
-
- @a = ();
- push @a, 14, 15, main->import;
- ok(eq_array(\@a, [14,15]), "import without args");
-
- my $x = 1;
-
- @a = ();
- push @a, 24, 25, &{$x == $x}(26,27);
- ok(eq_array(\@a, [24,25]), "yes with args");
-
- @a = ();
- push @a, 34, 35, &{$x == $x};
- ok(eq_array(\@a, [34,35]), "yes without args");
-}
-
# [perl #91844] return should always copy
{
$foo{bar} = 7;
--
Perl5 Master Repository
