From f226e9be7c69188b9b91606ccfca77843eaf9a31 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Tue, 15 May 2012 12:52:13 -0700
Subject: [PATCH] =?utf8?q?Don=E2=80=99t=20let=20method-BLOCK=20read=20beyo?=
 =?utf8?q?nd=20the=20stack?=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

$ ./perl -Ilib -e 'use B::Deparse; warn for new{}'
Can't call method "new" on an undefined value at -e line 1.
$ ./perl -Ilib -e 'use B::Deparse; warn for "foo", new{}'
Can't call method "new" without a package or object reference at -e line 1.

Now, why did adding "foo" there change the error message?  Because
new{} looks one past the end of the stack.  Adding "foo" just caused
it to look at the next dropping left behind by B::Deparse, which just
happened to be some non-ref that was not recognised as a package name.

In fact, I can even do this to control what value it picks up:

$ ./perl -Ilib -e '@_ = ("foo"); new{}'
Can't locate object method "new" via package "foo" (perhaps you forgot to load "foo"?) at -e line 1.

And then it calls a method with literally no arguments in @_:

$ ./perl -Ilib -we 'use B::Deparse; @_ = "B::Deparse"; warn new{}'
Use of uninitialized value $class in bless at lib/B/Deparse.pm line 569.
Explicit blessing to '' (assuming package main) at lib/B/Deparse.pm line 569.
Can't locate object method "init" via package "main" at lib/B/Deparse.pm line 588.

And the ultimate:

$ ./perl -Ilib -we 'for(1..1000000) {eval " warn +(1)x$_, new{}"}'
Bus error
$ ./perl -Ilib -we 'for(866..1018) { eval { warn +(1)x$_, new{} }}'
Bus error

OK, that’s enough fun.

With this commit, I’m making it an error to call a method this way
with no arguments.  I’m using the ‘without a package or object refer-
ence’ error message, as opposed to ‘on an undefined value’, because
there isn’t any undefined value; there’s nothing at all.
---
 pp_hot.c      |  6 +++++-
 t/op/method.t | 15 ++++++++++++++-
 2 files changed, 19 insertions(+), 2 deletions(-)

diff --git a/pp_hot.c b/pp_hot.c
index d0cf006..1a5b76c 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2949,7 +2949,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
     GV* gv;
     HV* stash;
     SV *packsv = NULL;
-    SV * const sv = *(PL_stack_base + TOPMARK + 1);
+    SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
+	? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
+			    "package or object reference", SVfARG(meth)),
+	   (SV *)NULL)
+	: *(PL_stack_base + TOPMARK + 1);
 
     PERL_ARGS_ASSERT_METHOD_COMMON;
 
diff --git a/t/op/method.t b/t/op/method.t
index 3339dde..09f6ee3 100644
--- a/t/op/method.t
+++ b/t/op/method.t
@@ -13,7 +13,7 @@ BEGIN {
 use strict;
 no warnings 'once';
 
-plan(tests => 95);
+plan(tests => 98);
 
 @A::ISA = 'B';
 @B::ISA = 'C';
@@ -404,3 +404,16 @@ is $kalled, 1, 'calling a class method via a magic variable';
    }
    { bless {}, "NoSub"; }
 }
+
+eval { () = 3; new {} };
+like $@,
+     qr/^Can't call method "new" without a package or object reference/,
+    'Err msg from new{} when stack contains a number';
+eval { () = "foo"; new {} };
+like $@,
+     qr/^Can't call method "new" without a package or object reference/,
+    'Err msg from new{} when stack contains a word';
+eval { () = undef; new {} };
+like $@,
+     qr/^Can't call method "new" without a package or object reference/,
+    'Err msg from new{} when stack contains undef';
-- 
2.7.4