Fix UTF8 lex sub names blead
authorFather Chrysostomos <sprout@cpan.org>
Mon, 24 Nov 2014 07:41:45 +0000 (23:41 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 24 Nov 2014 07:48:42 +0000 (23:48 -0800)
UTF8 lexical sub names were getting mangled, with extra junk on the end,
due to a precedence problem.

op.c
pad.c
t/op/lexsub.t

index d44a7ea..0bb4140 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7935,7 +7935,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            CvNAME_HEK_set(*spot, hek =
                share_hek(
                    PadnamePV(name)+1,
-                   PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash
+                   (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
+                   hash
                )
            );
            CvLEXICAL_on(*spot);
@@ -8092,7 +8093,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            U32 hash;
            PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
            hek = share_hek(PadnamePV(name)+1,
-                     PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
+                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
                      hash);
        }
        CvNAME_HEK_set(cv, hek);
diff --git a/pad.c b/pad.c
index 9da5536..a9581f8 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -2128,7 +2128,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
                        CvNAME_HEK_set(
                            sv,
                            share_hek(SvPVX_const(namesv)+1,
-                                     SvCUR(namesv) - 1
+                                     (SvCUR(namesv) - 1)
                                         * (SvUTF8(namesv) ? -1 : 1),
                                      hash)
                        );
index e170555..32f8bc7 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
     *bar::is = *is;
     *bar::like = *like;
 }
-plan 144;
+plan 146;
 
 # -------------------- Errors with feature disabled -------------------- #
 
@@ -424,6 +424,13 @@ is runperl(switches => ['-lXMfeature=:all'],
        " - no 'No comma allowed' after state sub\n";
   curr_test(curr_test()+1);
 }
+{
+  use utf8;
+  state sub φου;
+  eval { φου };
+  like $@, qr/^Undefined subroutine &φου called at /,
+    'state sub with utf8 name';
+}
 
 # -------------------- my -------------------- #
 
@@ -793,6 +800,13 @@ is runperl(switches => ['-lXMfeature=:all'],
   my sub y :prototype() {$x};
   is y, 43, 'my sub that looks like constant closure';
 }
+{
+  use utf8;
+  my sub φου;
+  eval { φου };
+  like $@, qr/^Undefined subroutine &φου called at /,
+    'my sub with utf8 name';
+}
 
 # -------------------- Interactions (and misc tests) -------------------- #