Make $class->method work when $class is tied

This little script:

sub TIESCALAR{bless[]}
sub FETCH{warn "fetching"; "main"}
sub bolgy { warn 'bolgy' }
tie my $a, "";
$a->bolgy;

Gives these outputs with various versions of perl:

$ pbpaste|perl5.6.2
fetching at - line 2.
fetching at - line 2.
bolgy at - line 3.

$ pbpaste|perl5.8.8
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
Can't call method "bolgy" without a package or object reference at - line 5.

$ pbpaste|perl5.8.9
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
bolgy at - line 3.

$ pbpaste|perl5.10.0
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
Can't call method "bolgy" without a package or object reference at - line 5.

$ pbpaste|perl5.10.1 # also 5.12.x
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
bolgy at - line 3.

$ pbpaste|perl5.14.0
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
fetching at - line 2.
Can't locate object method "bolgy" via package "main" (perhaps you forgot to load "main"?) at - line 5.

It’s worse than ever in 5.14.

What’s happening is that S_method_common is hanging on to the pointer
returned by SvPV, while continuing to call get-magic again and again.
 So the pointer becomes invalid.  I think it’s only by accident that
it worked in some versions.

This commit stops S_method_common from calling get-magic so many
times, solving both problems.

I’m afraid this conflicts with ongoing work to make method lookup
UTF8-clean, but I wanted to make a patch that could be backported.

3 files changed, 25 insertions, 5 deletions

diff --git a/pp_hot.c b/pp_hot.c
index dd0b04d6cd..fbe195f324 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2935,10 +2935,16 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 	ob = MUTABLE_SV(SvRV(sv));
     else {
 	GV* iogv;
+	bool packname_is_utf8 = FALSE;
 
 	/* this isn't a reference */
-        if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
-          const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
+        if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) {
+          const HE* const he =
+	    (const HE *)hv_common_key_len(
+	      PL_stashcache, packname,
+	      packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
+	    );
+	  
           if (he) { 
             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
             goto fetch;
@@ -2947,7 +2953,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 
 	if (!SvOK(sv) ||
 	    !(packname) ||
-	    !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
+	    !(iogv = gv_fetchpvn_flags(
+	        packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
+	     )) ||
 	    !(ob=MUTABLE_SV(GvIO(iogv))))
 	{
 	    /* this isn't the name of a filehandle either */
diff --git a/t/op/method.t b/t/op/method.t
index 3c00542ba3..40d0c3678a 100644
--- a/t/op/method.t
+++ b/t/op/method.t
@@ -13,7 +13,7 @@ BEGIN {
 use strict;
 no warnings 'once';
 
-plan(tests => 79);
+plan(tests => 80);
 
 @A::ISA = 'B';
 @B::ISA = 'C';
@@ -319,3 +319,11 @@ EOT
     );
 }
 
+# Test for calling a method on a packag name return by a magic variable
+sub TIESCALAR{bless[]}
+sub FETCH{"main"}
+my $kalled;
+sub bolgy { ++$kalled; }
+tie my $a, "";
+$a->bolgy;
+is $kalled, 1, 'calling a class method via a magic variable';
diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t
index 426addbb1a..30e1c91b7f 100644
--- a/t/op/tie_fetch_count.t
+++ b/t/op/tie_fetch_count.t
@@ -7,7 +7,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan (tests => 217);
+    plan (tests => 218);
 }
 
 use strict;
@@ -202,6 +202,10 @@ $dummy  = &$var5        ; check_count '&{}';
     defined $$var7          ; check_count 'symbolic defined ${}';
 }
 
+tie my $var8 => 'main', 'main';
+sub bolgy {}
+$var8->bolgy            ; check_count '->method';
+
 ###############################################
 #        Tests for  $foo binop $foo           #
 ###############################################