This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_hot.c: method_common is UTF-8 aware.
authorBrian Fraser <fraserbn@gmail.com>
Mon, 26 Sep 2011 15:27:59 +0000 (08:27 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 6 Oct 2011 20:01:07 +0000 (13:01 -0700)
Not really useful yet, since named methods aren't correctly
flagged; that is to access a \x{30cb} method, you'd need
to do something like Obj->${\"\x{30cb}"}.

Committer’s note: I’m also including one piece of the ‘gv.c and
pp_ctl.c warnings’ patch so that the newly-added tests in this
commit pass.

gv.c
pp_hot.c
t/op/method.t

diff --git a/gv.c b/gv.c
index 30ffa0a..52846fa 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1046,8 +1046,10 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
                        return gv;
                }
                Perl_croak(aTHX_
-                          "Can't locate object method \"%s\" via package \"%.*s\"",
-                          name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
+                          "Can't locate object method \"%"SVf"\" via package \"%"SVf"\"",
+                                   SVfARG(newSVpvn_flags(name, nend - name,
+                                           SVs_TEMP | is_utf8)),
+                                    SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))));
            }
            else {
                STRLEN packlen;
index cd2b3f5..5926874 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2933,9 +2933,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
     SV* ob;
     GV* gv;
     HV* stash;
-    const char* packname = NULL;
     SV *packsv = NULL;
-    STRLEN packlen;
     SV * const sv = *(PL_stack_base + TOPMARK + 1);
 
     PERL_ARGS_ASSERT_METHOD_COMMON;
@@ -2949,6 +2947,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
        ob = MUTABLE_SV(SvRV(sv));
     else {
        GV* iogv;
+        STRLEN packlen;
+        const char * packname = NULL;
        bool packname_is_utf8 = FALSE;
 
        /* this isn't a reference */
@@ -2985,12 +2985,13 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
                                    : "on an undefined value");
            }
            /* assume it's a package name */
-           stash = gv_stashpvn(packname, packlen, 0);
+           stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
            if (!stash)
                packsv = sv;
             else {
                SV* const ref = newSViv(PTR2IV(stash));
-               (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
+               (void)hv_store(PL_stashcache, packname,
+                                packname_is_utf8 ? -packlen : packlen, ref, 0);
            }
            goto fetch;
        }
@@ -3029,9 +3030,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
        }
     }
 
-    gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
-                             SvPV_nolen_const(meth),
-                             GV_AUTOLOAD | GV_CROAK);
+    gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
+                                    meth, GV_AUTOLOAD | GV_CROAK);
 
     assert(gv);
 
index 40d0c36..8ed3dcf 100644 (file)
@@ -13,7 +13,7 @@ BEGIN {
 use strict;
 no warnings 'once';
 
-plan(tests => 80);
+plan(tests => 82);
 
 @A::ISA = 'B';
 @B::ISA = 'C';
@@ -327,3 +327,19 @@ sub bolgy { ++$kalled; }
 tie my $a, "";
 $a->bolgy;
 is $kalled, 1, 'calling a class method via a magic variable';
+
+{
+    package NulTest;
+    sub method { 1 }
+
+    package main;
+    eval {
+        NulTest->${ \"method\0Whoops" };
+    };
+    like $@, qr/Can't locate object method "method\0Whoops" via package "NulTest" at/,
+            "method lookup is nul-clean";
+
+    *NulTest::AUTOLOAD = sub { our $AUTOLOAD; return $AUTOLOAD };
+
+    like(NulTest->${ \"nul\0test" }, "nul\0test", "AUTOLOAD is nul-clean");
+}