In perl.git, the branch sprout/pn has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/b9dc24b126c1b98ee9cbf76c1cda55bada5e4f87?hp=2837eec05b4b27a00eb119827927dbfad781f224>

- Log -----------------------------------------------------------------
commit b9dc24b126c1b98ee9cbf76c1cda55bada5e4f87
Author: Father Chrysostomos <[email protected]>
Date:   Mon Nov 24 00:42:20 2014 -0800

    fetch_pad_names.t: Emit all test names
    
    They were defined in the structure passed to the general_tests func-
    tion, but not all of them were used.

M       ext/XS-APItest/t/fetch_pad_names.t

commit b0c75f9ad315de1bbd954ae29614a2ab6ec9ccdb
Author: Father Chrysostomos <[email protected]>
Date:   Mon Nov 24 00:33:35 2014 -0800

    ‘Subroutine (not var) "&x" will not stay shared’
    
    Another ‘variable’ warning about lexical subs that I missed.

M       pad.c
M       pod/perldiag.pod
M       t/op/lexsub.t

commit 44f3b6184e5879a4ab23c16d3d84d89f8f71e828
Author: Father Chrysostomos <[email protected]>
Date:   Mon Nov 24 00:27:12 2014 -0800

    diag.t: Allow multiline diag_listed_as

M       t/porting/diag.t

commit 4734113a6825feb4cc9da40cab8c7ea0d94372d1
Author: Father Chrysostomos <[email protected]>
Date:   Mon Nov 24 00:05:33 2014 -0800

    pad.c: Use UTF8f for ‘will not stay shared’
    
    This is more efficient than creating a temporary SV.

M       pad.c

commit b378bcff1f14e2278ec74aba25366948d8be4690
Author: Father Chrysostomos <[email protected]>
Date:   Mon Nov 24 00:00:51 2014 -0800

    Make pad names always UTF8
    
    Prior to 5.16, pad names never used the UTF8 flag, and all non-ASCII
    pad names were in UTF8.  Because the latter was consistently true,
    everything just worked anyway.
    
    In 5.16, UTF8 handling was done ‘properly’, so that non-ASCII UTF8
    strings were always accompanied by the UTF8 flag.
    
    Now, it is still the case that the only non-ASCII names to make their
    way into pad name code are in UTF8.  Since ASCII is a subset of UTF8,
    we effectively *always* have UTF8 pad names.  So the flag handling is
    actually redundant.
    
    If we just assume that all pad names are UTF8 (which is true), then
    we don’t need to bother with the flag checking.  There is actually
    no reason why we should have two different encodings for storing
    pad names.
    
    So this commit enforces what has always been the case and removes the
    extra code for converting between Latin-1 and UTF8.  Nothing on CPAN
    is using the UTF8 flag with pads, so nothing should break.  In fact,
    we never documented padadd_UTF8_NAME.

M       ext/XS-APItest/t/fetch_pad_names.t
M       op.c
M       pad.c
M       pad.h
M       toke.c

commit 891257c9747ea1529bb07e72142a92a7fe20e2b3
Author: Father Chrysostomos <[email protected]>
Date:   Sun Nov 23 23:41:45 2014 -0800

    Fix UTF8 lex sub names
    
    UTF8 lexical sub names were getting mangled, with extra junk on the end,
    due to a precedence problem.

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

commit c00fc996ae833012b4f91f7ec8bf39d8ca30ce87
Author: Father Chrysostomos <[email protected]>
Date:   Sun Nov 23 14:51:21 2014 -0800

    pad.c:padlist_dup: Remove refcnt check
    
    This was added by 6de654a5, and the assert that makes sure the
    reference count is exactly 1 was added in the same commit.  After
    several years, I think we can be sure now that the reference count
    is indeed always 1.  We don’t need to ‘play it safe’ for non-debug-
    ging builds.

M       pad.c
-----------------------------------------------------------------------

Summary of changes:
 ext/XS-APItest/t/fetch_pad_names.t | 30 ++++++------
 op.c                               |  8 ++--
 pad.c                              | 96 +++++++++-----------------------------
 pad.h                              |  5 +-
 pod/perldiag.pod                   | 19 ++++++++
 t/op/lexsub.t                      | 24 +++++++++-
 t/porting/diag.t                   | 16 +++++++
 toke.c                             | 10 ++--
 8 files changed, 106 insertions(+), 102 deletions(-)

diff --git a/ext/XS-APItest/t/fetch_pad_names.t 
b/ext/XS-APItest/t/fetch_pad_names.t
index 3d42280..9e95d1b 100644
--- a/ext/XS-APItest/t/fetch_pad_names.t
+++ b/ext/XS-APItest/t/fetch_pad_names.t
@@ -41,8 +41,8 @@ general_tests( $cv->(), $names_av, {
                ],
     pad_size => {
                     total     => { cmp => 2, msg => 'Sub has two lexicals.' },
-                    utf8      => { cmp => 0, msg => 'Sub has no UTF-8 encoded 
vars.' },
-                    invariant => { cmp => 2, msg => 'Sub has two invariant 
vars.' },
+                    utf8      => { cmp => 2, msg => 'Sub has only UTF-8 vars.' 
},
+                    invariant => { cmp => 0, msg => 'Sub has no invariant 
vars.' },
                 },
     vars    => [
                 { name => '$zest', msg => 'Sub has [\$zest].', type => 'ok' },
@@ -79,8 +79,8 @@ general_tests( $cv->(), $names_av, {
                ],
     pad_size => {
                     total     => { cmp => 2, msg => 'Sub has two lexicals, 
including those it closed over.' },
-                    utf8      => { cmp => 1, msg => 'UTF-8 in the pad.' },
-                    invariant => { cmp => 1, msg => '' },
+                    utf8      => { cmp => 2, msg => 'UTF-8 in the pad.' },
+                    invariant => { cmp => 0, msg => '' },
                 },
     vars    => [
                 { name => '$ascii', msg => 'Sub has [$ascii].', type => 'ok' },
@@ -120,8 +120,8 @@ general_tests( $cv->(), $names_av, {
                ],
     pad_size => {
                     total     => { cmp => 2, msg => 'Sub has two lexicals' },
-                    utf8      => { cmp => 0, msg => 'Latin-1 not upgraded to 
UTF-8.' },
-                    invariant => { cmp => 2, msg => '' },
+                    utf8      => { cmp => 2, msg => 'Latin-1 got upgraded to 
UTF-8.' },
+                    invariant => { cmp => 0, msg => '' },
                 },
     vars    => [
                 { name => '$Leon', msg => 'Sub has [$Leon].', type => 'ok' },
@@ -153,8 +153,8 @@ END_EVAL
         results => [ ({ SKIP => 1 }) x 3 ],
         pad_size => {
                   total => { cmp => 1, msg => 'Sub has one lexical, which it 
closed over.' },
-                  utf8      => { cmp => 0, msg => '' },
-                  invariant => { cmp => 1, msg => '' },
+                  utf8      => { cmp => 1, msg => '' },
+                  invariant => { cmp => 0, msg => '' },
                     },
         vars    => [
                 { name => '$Ceon', msg => "Sub doesn't have [\$Ceon].", type 
=> 'not ok' },
@@ -189,8 +189,8 @@ general_tests( $cv->(), $names_av, {
                ],
     pad_size => {
                     total     => { cmp => 3, msg => 'Sub has three lexicals.' 
},
-                    utf8      => { cmp => 1, msg => 'Japanese stored as 
UTF-8.' },
-                    invariant => { cmp => 2, msg => '' },
+                    utf8      => { cmp => 3, msg => 'Japanese stored as 
UTF-8.' },
+                    invariant => { cmp => 0, msg => '' },
                 },
     vars    => [
                 { name => "\$\x{6226}\x{56fd}", msg => "Sub has 
[\$\x{6226}\x{56fd}].", type => 'ok' },
@@ -236,8 +236,8 @@ general_tests( $cv->(), $names_av, {
                ],
     pad_size => {
                     total     => { cmp => 1, msg => 'Sub has one lexical.' },
-                    utf8      => { cmp => 0, msg => '' },
-                    invariant => { cmp => 1, msg => '' },
+                    utf8      => { cmp => 1, msg => '' },
+                    invariant => { cmp => 0, msg => '' },
                 },
     vars    => [],
 });
@@ -307,8 +307,10 @@ sub general_tests {
     }
 
     is @$names_av, $tests->{pad_size}{total}{cmp}, 
$tests->{pad_size}{total}{msg};
-    is grep( Encode::is_utf8($_), @$names_av), $tests->{pad_size}{utf8}{cmp};
-    is grep( !Encode::is_utf8($_), @$names_av), 
$tests->{pad_size}{invariant}{cmp};
+    is grep( Encode::is_utf8($_), @$names_av),
+       $tests->{pad_size}{utf8}{cmp}, $tests->{pad_size}{utf8}{msg};
+    is grep( !Encode::is_utf8($_), @$names_av), 
$tests->{pad_size}{invariant}{cmp},
+       $tests->{pad_size}{invariant}{msg};
 
     for my $var (@{$tests->{vars}}) {
         no warnings 'experimental::smartmatch';
diff --git a/op.c b/op.c
index 304d82a..4d6f1d0 100644
--- a/op.c
+++ b/op.c
@@ -613,8 +613,7 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN 
len, const U32 flags)
 
     off = pad_add_name_pvn(name, len,
                       (is_our ? padadd_OUR :
-                       PL_parser->in_my == KEY_state ? padadd_STATE : 0)
-                            | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
+                       PL_parser->in_my == KEY_state ? padadd_STATE : 0),
                    PL_parser->in_my_stash,
                    (is_our
                        /* $_ is always in main::, even with our */
@@ -7919,7 +7918,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);
@@ -8076,7 +8076,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 92651e7..65365ff 100644
--- a/pad.c
+++ b/pad.c
@@ -155,33 +155,6 @@ Points directly to the body of the L</PL_comppad> array.
 #define PARENT_FAKELEX_FLAGS_set(sv,val)       \
   STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } 
STMT_END
 
-/*
-This is basically sv_eq_flags() in sv.c, but we avoid the magic
-and bytes checking.
-*/
-
-static bool
-padname_eq_pvn_flags(pTHX_ const PADNAME *pn, const char* pv, const STRLEN
-                           pvlen, const U32 flags) {
-    if ( !PadnameUTF8(pn) != !(flags & SVf_UTF8) ) {
-        const char *pv1 = PadnamePV(pn);
-        STRLEN cur1     = PadnameLEN(pn);
-        const char *pv2 = pv;
-        STRLEN cur2     = pvlen;
-        if (flags & SVf_UTF8)
-            return (bytes_cmp_utf8(
-                        (const U8*)pv1, cur1,
-                       (const U8*)pv2, cur2) == 0);
-        else
-            return (bytes_cmp_utf8(
-                        (const U8*)pv2, cur2,
-                       (const U8*)pv1, cur1) == 0);
-    }
-    else
-       return ((PadnamePV(pn) == pv)
-                   || memEQ(PadnamePV(pn), pv, pvlen));
-}
-
 #ifdef DEBUGGING
 void
 Perl_set_padlist(pTHX_ CV * cv, PADLIST *padlist){
@@ -628,29 +601,18 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN 
namelen,
 {
     PADOFFSET offset;
     PADNAME *name;
-    bool is_utf8;
 
     PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
 
-    if (flags & 
~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
+    if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK))
        Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
                   (UV)flags);
 
     name = (PADNAME *)
        newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
     
-    if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
-        namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
-    }
-
     sv_setpvn((SV *)name, namepv, namelen);
-
-    if (is_utf8) {
-        flags |= padadd_UTF8_NAME;
-        SvUTF8_on(name);
-    }
-    else
-        flags &= ~padadd_UTF8_NAME;
+    SvUTF8_on(name);
 
     if ((flags & padadd_NO_DUP_CHECK) == 0) {
        ENTER;
@@ -661,7 +623,7 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN 
namelen,
        LEAVE;
     }
 
-    offset = pad_alloc_name(name, flags & ~padadd_UTF8_NAME, typestash, 
ourstash);
+    offset = pad_alloc_name(name, flags, typestash, ourstash);
 
     /* not yet introduced */
     COP_SEQ_RANGE_LOW_set(name, PERL_PADSEQ_INTRO);
@@ -720,9 +682,7 @@ Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV 
*typestash, HV *ourstash)
     char *namepv;
     STRLEN namelen;
     PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
-    namepv = SvPV(name, namelen);
-    if (SvUTF8(name))
-        flags |= padadd_UTF8_NAME;
+    namepv = SvPVutf8(name, namelen);
     return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
 }
 
@@ -993,20 +953,10 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN 
namelen, U32 flags)
 
     pad_peg("pad_findmy_pvn");
 
-    if (flags & ~padadd_UTF8_NAME)
+    if (flags)
        Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
                   (UV)flags);
 
-    if (flags & padadd_UTF8_NAME) {
-        bool is_utf8 = TRUE;
-        namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
-
-        if (is_utf8)
-            flags |= padadd_UTF8_NAME;
-        else
-            flags &= ~padadd_UTF8_NAME;
-    }
-
     offset = pad_findlex(namepv, namelen, flags,
                 PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags);
     if ((PADOFFSET)offset != NOT_IN_PAD) 
@@ -1027,8 +977,8 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN 
namelen, U32 flags)
         if (name && PadnameLEN(name) == namelen
             && !PadnameOUTER(name)
             && (PadnameIsOUR(name))
-            && padname_eq_pvn_flags(aTHX_ name, namepv, namelen,
-                                flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
+            && (  PadnamePV(name) == namepv
+               || memEQ(PadnamePV(name), namepv, namelen)  )
             && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO
        )
            return offset;
@@ -1067,9 +1017,7 @@ Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
     char *namepv;
     STRLEN namelen;
     PERL_ARGS_ASSERT_PAD_FINDMY_SV;
-    namepv = SvPV(name, namelen);
-    if (SvUTF8(name))
-        flags |= padadd_UTF8_NAME;
+    namepv = SvPVutf8(name, namelen);
     return pad_findmy_pvn(namepv, namelen, flags);
 }
 
@@ -1193,10 +1141,10 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, 
U32 flags, const CV* cv,
 
     PERL_ARGS_ASSERT_PAD_FINDLEX;
 
-    if (flags & ~(padadd_UTF8_NAME|padadd_STALEOK))
+    flags &= ~ padadd_STALEOK; /* one-shot flag */
+    if (flags)
        Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
                   (UV)flags);
-    flags &= ~ padadd_STALEOK; /* one-shot flag */
 
     *out_flags = 0;
 
@@ -1215,8 +1163,8 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, 
U32 flags, const CV* cv,
        for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
             const PADNAME * const name = name_p[offset];
             if (name && PadnameLEN(name) == namelen
-                     && padname_eq_pvn_flags(aTHX_ name, namepv, namelen,
-                                    flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
+                     && (  PadnamePV(name) == namepv
+                        || memEQ(PadnamePV(name), namepv, namelen)  ))
            {
                if (PadnameOUTER(name)) {
                    fake_offset = offset; /* in case we don't find a real one */
@@ -1279,8 +1227,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, 
U32 flags, const CV* cv,
                    if (warn)
                        S_unavailable(aTHX_
                                        newSVpvn_flags(namepv, namelen,
-                                           SVs_TEMP |
-                                           (flags & padadd_UTF8_NAME ? 
SVf_UTF8 : 0)));
+                                                      SVs_TEMP|SVf_UTF8));
 
                    *out_capture = NULL;
                }
@@ -1292,11 +1239,12 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, 
U32 flags, const CV* cv,
                         && !PadnameIsSTATE(name_p[offset])
                         && warn && ckWARN(WARN_CLOSURE)) {
                        newwarn = 0;
+                       /* diag_listed_as: Variable "%s" will not stay
+                                          shared */
                        Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
-                           "Variable \"%"SVf"\" will not stay shared",
-                            SVfARG(newSVpvn_flags(namepv, namelen,
-                                SVs_TEMP |
-                                (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))));
+                           "%se \"%"UTF8f"\" will not stay shared",
+                            *namepv == '&' ? "Subroutin" : "Variabl",
+                            UTF8fARG(1, namelen, namepv));
                    }
 
                    if (fake_offset && CvANON(cv)
@@ -1327,8 +1275,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, 
U32 flags, const CV* cv,
                    {
                        S_unavailable(aTHX_
                                        newSVpvn_flags(namepv, namelen,
-                                           SVs_TEMP |
-                                           (flags & padadd_UTF8_NAME ? 
SVf_UTF8 : 0)));
+                                                      SVs_TEMP|SVf_UTF8));
                        *out_capture = NULL;
                    }
                }
@@ -2118,7 +2065,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)
                        );
@@ -2500,8 +2447,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS 
*param)
 
     PERL_ARGS_ASSERT_PADLIST_DUP;
 
-    cloneall = param->flags & CLONEf_COPY_STACKS
-       || SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
+    cloneall = param->flags & CLONEf_COPY_STACKS;
     assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
 
     max = cloneall ? PadlistMAX(srcpad) : 1;
diff --git a/pad.h b/pad.h
index deb30b7..c359072 100644
--- a/pad.h
+++ b/pad.h
@@ -143,7 +143,6 @@ typedef enum {
 #define padadd_NO_DUP_CHECK    0x04       /* skip warning on dups. */
 #define padadd_STALEOK         0x08       /* allow stale lexical in active
                                            * sub, but only one level up */
-#define padadd_UTF8_NAME       SVf_UTF8   /* name is UTF-8 encoded. */
 
 /* ASSERT_CURPAD_LEGAL and ASSERT_CURPAD_ACTIVE respectively determine
  * whether PL_comppad and PL_curpad are consistent and whether they have
@@ -234,7 +233,7 @@ GV slot.
 The length of the name.
 
 =for apidoc Amx|bool|PadnameUTF8|PADNAME pn
-Whether PadnamePV is in UTF8.
+Whether PadnamePV is in UTF8.  Currently, this is always true.
 
 =for apidoc Amx|SV *|PadnameSV|PADNAME pn
 Returns the pad name as an SV.  This is currently just C<pn>.  It will
@@ -315,7 +314,7 @@ Restore the old pad saved into the local variable opad by 
PAD_SAVE_LOCAL()
 
 #define PadnamePV(pn)          (SvPOKp(pn) ? SvPVX_const(pn) : NULL)
 #define PadnameLEN(pn)         ((SV*)(pn) == &PL_sv_undef ? 0 : SvCUR(pn))
-#define PadnameUTF8(pn)                !!SvUTF8(pn)
+#define PadnameUTF8(pn)                (assert_(SvUTF8(pn)) 1)
 #define PadnameSV(pn)          pn
 #define PadnameIsOUR(pn)       !!SvPAD_OUR(pn)
 #define PadnameOURSTASH(pn)    SvOURSTASH(pn)
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index a369a70..f9a56fa 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -5438,6 +5438,25 @@ the previous instance.  This is almost always a 
typographical error.
 Note that the earlier subroutine will still exist until the end of
 the scope or until all closure references to it are destroyed.
 
+=item Subroutine "%s" will not stay shared
+
+(W closure) An inner (nested) I<named> subroutine is referencing a "my"
+subroutine defined in an outer named subroutine.
+
+When the inner subroutine is called, it will see the value of the outer
+subroutine's lexical subroutine as it was before and during the *first*
+call to the outer subroutine; in this case, after the first call to the
+outer subroutine is complete, the inner and outer subroutines will no
+longer share a common value for the lexical subroutine.  In other words,
+it will no longer be shared.  This will especially make a difference
+if the lexical subroutines accesses lexical variables declared in its
+surrounding scope.
+
+This problem can usually be solved by making the inner subroutine
+anonymous, using the C<sub {}> syntax.  When inner anonymous subs that
+reference lexical subroutines in outer subroutines are created, they
+are automatically rebound to the current values of such lexical subs.
+
 =item Subroutine %s redefined
 
 (W redefine) You redefined a subroutine.  To suppress this warning, say
diff --git a/t/op/lexsub.t b/t/op/lexsub.t
index e170555..f43285f 100644
--- a/t/op/lexsub.t
+++ b/t/op/lexsub.t
@@ -7,7 +7,7 @@ BEGIN {
     *bar::is = *is;
     *bar::like = *like;
 }
-plan 144;
+plan 147;
 
 # -------------------- 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,21 @@ 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';
+}
+{
+  my $w;
+  local $SIG{__WARN__} = sub { $w = shift };
+  use warnings 'closure';
+  eval 'sub stayshared { my sub x; sub notstayshared { x } } 1' or die;
+  like $w, qr/^Subroutine "&x" will not stay shared at /,
+          'Subroutine will not stay shared';
+}
 
 # -------------------- Interactions (and misc tests) -------------------- #
 
diff --git a/t/porting/diag.t b/t/porting/diag.t
index b53dacd..a2ef15c 100644
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -244,6 +244,22 @@ sub check_file {
       $listed_as = $1;
       $listed_as_line = $.+1;
     }
+    elsif (m</\*\s*diag_listed_as: (.*?)\s*\z>) {
+      $listed_as = $1;
+      my $finished;
+      while (<$codefh>) {
+        if (m<\*/>) {
+          $listed_as .= $` =~ s/^\s*/ /r =~ s/\s+\z//r;
+          $listed_as_line = $.+1;
+          $finished = 1;
+          last;
+        }
+        else {
+          $listed_as .= s/^\s*/ /r =~ s/\s+\z//r;
+        }
+      }
+      if (!$finished) { $listed_as = undef }
+    }
     next if /^#/;
 
     my $multiline = 0;
diff --git a/toke.c b/toke.c
index e20c93f..5c23ae8 100644
--- a/toke.c
+++ b/toke.c
@@ -6392,7 +6392,7 @@ Perl_yylex(pTHX)
            char tmpbuf[sizeof PL_tokenbuf + 1];
            *tmpbuf = '&';
            Copy(PL_tokenbuf, tmpbuf+1, len, char);
-           off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
+           off = pad_findmy_pvn(tmpbuf, len+1, 0);
            if (off != NOT_IN_PAD) {
                assert(off); /* we assume this is boolean-true below */
                if (PAD_COMPNAME_FLAGS_isOUR(off)) {
@@ -7881,7 +7881,7 @@ Perl_yylex(pTHX)
                    *PL_tokenbuf = '&';
                    if (memchr(tmpbuf, ':', len) || key != KEY_sub
                     || pad_findmy_pvn(
-                           PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
+                           PL_tokenbuf, len + 1, 0
                        ) != NOT_IN_PAD)
                        sv_setpvn(PL_subname, tmpbuf, len);
                    else {
@@ -8182,7 +8182,7 @@ S_pending_ident(pTHX)
     if (!has_colon) {
        if (!PL_in_my)
            tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
-                                    UTF ? SVf_UTF8 : 0);
+                                 0);
         if (tmp != NOT_IN_PAD) {
             /* might be an "our" variable" */
             if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
@@ -8300,7 +8300,7 @@ S_checkcomma(pTHX_ const char *s, const char *name, const 
char *what)
                char tmpbuf[256];
                Copy(w, tmpbuf+1, s - w, char);
                *tmpbuf = '&';
-               off = pad_findmy_pvn(tmpbuf, s-w+1, UTF ? SVf_UTF8 : 0);
+               off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
                if (off != NOT_IN_PAD) return;
            }
            Perl_croak(aTHX_ "No comma allowed after %s", what);
@@ -9450,7 +9450,7 @@ S_scan_inputsymbol(pTHX_ char *start)
            /* try to find it in the pad for this block, otherwise find
               add symbol table ops
            */
-           const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
+           const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
            if (tmp != NOT_IN_PAD) {
                if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
                    HV * const stash = PAD_COMPNAME_OURSTASH(tmp);

--
Perl5 Master Repository

Reply via email to