Skip to content

Commit 0740a29

Browse files
author
Zefram
committed
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].
1 parent 28ef704 commit 0740a29

File tree

6 files changed

+44
-58
lines changed

6 files changed

+44
-58
lines changed

‎ext/XS-APItest/APItest.xs

+9-1
Original file line numberDiff line numberDiff line change
@@ -2339,9 +2339,17 @@ CODE:
23392339
only current internal behavior, these tests can be changed in the
23402340
future if necessery */
23412341
PUSHMARK(SP);
2342-
retcnt = call_sv(&PL_sv_yes, 0); /* does nothing */
2342+
retcnt = call_sv(&PL_sv_yes, G_EVAL);
23432343
SPAGAIN;
23442344
SP -= retcnt;
2345+
errsv = ERRSV;
2346+
errstr = SvPV(errsv, errlen);
2347+
if(memBEGINs(errstr, errlen, "Undefined subroutine &main::1 called at")) {
2348+
PUSHMARK(SP);
2349+
retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2350+
SPAGAIN;
2351+
SP -= retcnt;
2352+
}
23452353
PUSHMARK(SP);
23462354
retcnt = call_sv(&PL_sv_no, G_EVAL);
23472355
SPAGAIN;

‎ext/XS-APItest/t/call.t

+1-1
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,7 @@ sub i {
3333
$call_sv_count++;
3434
}
3535
call_sv_C();
36-
is($call_sv_count, 6, "call_sv_C passes");
36+
is($call_sv_count, 7, "call_sv_C passes");
3737

3838
sub d {
3939
die "its_dead_jim\n";

‎gv.c

+4-3
Original file line numberDiff line numberDiff line change
@@ -1091,9 +1091,10 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
10911091
/* This is the special case that exempts Foo->import and
10921092
Foo->unimport from being an error even if there's no
10931093
import/unimport subroutine */
1094-
if (strEQ(name,"import") || strEQ(name,"unimport"))
1095-
gv = MUTABLE_GV(&PL_sv_yes);
1096-
else if (autoload)
1094+
if (strEQ(name,"import") || strEQ(name,"unimport")) {
1095+
gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL,
1096+
NULL, 0, 0, NULL));
1097+
} else if (autoload)
10971098
gv = gv_autoload_pvn(
10981099
ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags
10991100
);

‎pp_hot.c

-10
Original file line numberDiff line numberDiff line change
@@ -5007,16 +5007,6 @@ PP(pp_entersub)
50075007
if (UNLIKELY(!SvOK(sv)))
50085008
DIE(aTHX_ PL_no_usym, "a subroutine");
50095009

5010-
if (UNLIKELY(sv == &PL_sv_yes)) { /* unfound import, ignore */
5011-
if (PL_op->op_flags & OPf_STACKED) /* hasargs */
5012-
SP = PL_stack_base + POPMARK;
5013-
else
5014-
(void)POPMARK;
5015-
if (GIMME_V == G_SCALAR)
5016-
PUSHs(&PL_sv_undef);
5017-
RETURN;
5018-
}
5019-
50205010
sym = SvPV_nomg_const(sv, len);
50215011
if (PL_op->op_private & HINT_STRICT_REFS)
50225012
DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");

‎t/op/method.t

+29-18
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,35 @@ BEGIN {
1313
use strict;
1414
no warnings 'once';
1515

16-
plan(tests => 151);
16+
plan(tests => 162);
17+
18+
{
19+
# RT #126042 &{1==1} * &{1==1} would crash
20+
# There are two issues here. Method lookup yields a fake method for
21+
# ->import or ->unimport if there's no actual method, for historical
22+
# reasons so that "use" doesn't barf if there's no import method.
23+
# The first bug, the one which caused the crash, is that the fake
24+
# method was broken in scalar context, messing up the stack. We test
25+
# for that on its own.
26+
foreach my $meth (qw(import unimport)) {
27+
is join(",", map { $_ // "u" } "a", "b", "Unknown"->$meth, "c", "d"), "a,b,c,d", "Unknown->$meth in list context";
28+
is join(",", map { $_ // "u" } "a", "b", scalar("Unknown"->$meth), "c", "d"), "a,b,u,c,d", "Unknown->$meth in scalar context";
29+
}
30+
# The second issue is that the fake method wasn't actually a CV or
31+
# anything referencing a CV, but was &PL_sv_yes being used as a magic
32+
# placeholder. That's inconsistent with &PL_sv_yes being a string,
33+
# which we'd expect to serve as a symbolic CV ref. This test must
34+
# come before AUTOLOAD gets set up below.
35+
foreach my $one (1, !!1) {
36+
my @res = eval { no strict "refs"; &$one() };
37+
like $@, qr/\AUndefined subroutine \&main::1 called at /;
38+
@res = eval { no strict "refs"; local *1 = sub { 123 }; &$one() };
39+
is $@, "";
40+
is "@res", "123";
41+
@res = eval { &$one() };
42+
like $@, qr/\ACan't use string \("1"\) as a subroutine ref while "strict refs" in use at /;
43+
}
44+
}
1745

1846
@A::ISA = 'BB';
1947
@BB::ISA = 'C';
@@ -687,23 +715,6 @@ SKIP: {
687715
like ($@, qr/Modification of a read-only value attempted/, 'RT #123619');
688716
}
689717
690-
{
691-
# RT #126042 &{1==1} * &{1==1} would crash
692-
693-
# pp_entersub and pp_method_named cooperate to prevent calls to an
694-
# undefined import() or unimport() method from croaking.
695-
# If pp_method_named can't find the method it pushes &PL_sv_yes, and
696-
# pp_entersub checks for that specific SV to avoid croaking.
697-
# Ideally they wouldn't use that hack but...
698-
# Unfortunately pp_entersub's handling of that case is broken in scalar context.
699-
700-
# Rather than using the test case from the ticket, since &{1==1}
701-
# isn't documented (and may not be supported in future perls) test
702-
# calls to undefined import method, which also crashes.
703-
fresh_perl_is('Unknown->import() * Unknown->unimport(); print "ok\n"', "ok\n", {},
704-
"check unknown import() methods don't corrupt the stack");
705-
}
706-
707718
# RT#130496: assertion failure when looking for a method of undefined name
708719
# on an unblessed reference
709720
fresh_perl_is('eval { {}->$x }; print $@;',

‎t/op/sub.t

+1-25
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,7 @@ BEGIN {
66
set_up_inc('../lib');
77
}
88

9-
plan(tests => 65);
9+
plan(tests => 61);
1010

1111
sub empty_sub {}
1212

@@ -17,30 +17,6 @@ is(scalar(@test), 0, 'Didnt return anything');
1717
@test = empty_sub(1,2,3);
1818
is(scalar(@test), 0, 'Didnt return anything');
1919

20-
# RT #63790: calling PL_sv_yes as a sub is special-cased to silently
21-
# return (so Foo->import() silently fails if import() doesn't exist),
22-
# But make sure it correctly pops the stack and mark stack before returning.
23-
24-
{
25-
my @a;
26-
push @a, 4, 5, main->import(6,7);
27-
ok(eq_array(\@a, [4,5]), "import with args");
28-
29-
@a = ();
30-
push @a, 14, 15, main->import;
31-
ok(eq_array(\@a, [14,15]), "import without args");
32-
33-
my $x = 1;
34-
35-
@a = ();
36-
push @a, 24, 25, &{$x == $x}(26,27);
37-
ok(eq_array(\@a, [24,25]), "yes with args");
38-
39-
@a = ();
40-
push @a, 34, 35, &{$x == $x};
41-
ok(eq_array(\@a, [34,35]), "yes without args");
42-
}
43-
4420
# [perl #91844] return should always copy
4521
{
4622
$foo{bar} = 7;

0 commit comments

Comments
 (0)