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.

1 files changed, 11 insertions, 3 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 */