Make $class->method work when $class is tied
authorFather Chrysostomos <sprout@cpan.org>
Thu, 25 Aug 2011 01:04:26 +0000 (18:04 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 25 Aug 2011 01:04:26 +0000 (18:04 -0700)
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.

pp_hot.c
t/op/method.t
t/op/tie_fetch_count.t

index dd0b04d..fbe195f 100644 (file)
--- 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 */
index 3c00542..40d0c36 100644 (file)
@@ -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';
index 426addb..30e1c91 100644 (file)
@@ -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           #
 ###############################################