diff options
| -rw-r--r-- | gv.c | 2 | ||||
| -rw-r--r-- | op.c | 10 | ||||
| -rw-r--r-- | pp.c | 2 | ||||
| -rw-r--r-- | t/uni/gv.t | 9 |
4 files changed, 14 insertions, 9 deletions
@@ -318,6 +318,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag const bool doproto = old_type > SVt_NULL; char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; const STRLEN protolen = proto ? SvCUR(gv) : 0; + const U32 proto_utf8 = proto ? SvUTF8(gv) : 0; SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; @@ -401,6 +402,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag if (proto) { sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, SV_HAS_TRAILING_NUL); + if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); } } } @@ -6421,6 +6421,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) GV *gv; const char *ps; STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */ + U32 ps_utf8 = 0; register CV *cv = NULL; SV *const_sv; /* If the subroutine has no body, no attributes, and no builtin attributes @@ -6439,6 +6440,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (proto) { assert(proto->op_type == OP_CONST); ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); + ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv); } else ps = NULL; @@ -6480,8 +6482,10 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } cv_ckproto_len((const CV *)gv, NULL, ps, ps_len); } - if (ps) + if (ps) { sv_setpvn(MUTABLE_SV(gv), ps, ps_len); + if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv)); + } else sv_setiv(MUTABLE_SV(gv), -1); @@ -6659,8 +6663,10 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE); } - if (ps) + if (ps) { sv_setpvn(MUTABLE_SV(cv), ps, ps_len); + if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); + } if (PL_parser && PL_parser->error_count) { op_free(block); @@ -457,7 +457,7 @@ PP(pp_prototype) } cv = sv_2cv(TOPs, &stash, &gv, 0); if (cv && SvPOK(cv)) - ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP); + ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv)); set: SETs(ret); RETURN; diff --git a/t/uni/gv.t b/t/uni/gv.t index df94efeabf..14d07acb56 100644 --- a/t/uni/gv.t +++ b/t/uni/gv.t @@ -320,8 +320,7 @@ EOPROG } } -TODO: { - local $TODO = "prototype() (and prototypes in general) not yet clean"; +{ # Possibly not the correct test file for these tests. # There are certain space optimisations implemented via promotion rules to # GVs @@ -496,8 +495,7 @@ is (ref \$::{ビfᶠ}, 'GLOB', "Symbol table has full typeglob"); is($ᕘf, 4); } -TODO: { -local $TODO = "Prototypes not yet clean"; +{ no warnings 'once'; format = . @@ -589,8 +587,7 @@ $::{Ḟ앜ɞ} = *ŚyṀ; is (eval 'local *::Ḟ앜ɞ = \"chuck"; $Ḟ앜ɞ', 'chuck', "Localized glob didn't coerce into a RV"); is ($@, '', "Can localize FAKE glob that's present in stash"); -TODO: { - local $TODO = q!$::{glob} = "something"; not yet clean.!; +{ is (scalar $::{Ḟ앜ɞ}, "*main::ŚyṀ", "Localized FAKE glob's value was correctly restored"); } |