X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/17008668bc1759e4a1ff55f42c3d738e5534b5dc..d0c0e7dd0ccf3d5c2f658529d3ee578a0bcb116e:/gv.c diff --git a/gv.c b/gv.c index cbbf326..24f4912 100644 --- a/gv.c +++ b/gv.c @@ -16,7 +16,7 @@ * history of Middle-earth and Over-heaven and of the Sundering Seas,' * laughed Pippin. * - * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"] + * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* @@ -59,11 +59,7 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) * if it walks like a dirhandle, then let's assume that * this is a dirhandle. */ - what = PL_op->op_type == OP_READDIR || - PL_op->op_type == OP_TELLDIR || - PL_op->op_type == OP_SEEKDIR || - PL_op->op_type == OP_REWINDDIR || - PL_op->op_type == OP_CLOSEDIR ? + what = OP_IS_DIRHOP(PL_op->op_type) ? "dirhandle" : "filehandle"; /* diag_listed_as: Bad symbol for filehandle */ } else if (type == SVt_PVHV) { @@ -252,18 +248,81 @@ Perl_cvstash_set(pTHX_ CV *cv, HV *st) Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); } +/* +=for apidoc gv_init_pvn + +Converts a scalar into a typeglob. This is an incoercible typeglob; +assigning a reference to it will assign to one of its slots, instead of +overwriting it as happens with typeglobs created by SvSetSV. Converting +any scalar that is SvOK() may produce unpredictable results and is reserved +for perl's internal use. + +C is the scalar to be converted. + +C is the parent stash/package, if any. + +C and C give the name. The name must be unqualified; +that is, it must not include the package name. If C is a +stash element, it is the caller's responsibility to ensure that the name +passed to this function matches the name of the element. If it does not +match, perl's internal bookkeeping will get out of sync. + +C can be set to SVf_UTF8 if C is a UTF8 string, or +the return value of SvUTF8(sv). It can also take the +GV_ADDMULTI flag, which means to pretend that the GV has been +seen before (i.e., suppress "Used once" warnings). + +=for apidoc gv_init + +The old form of gv_init_pvn(). It does not work with UTF8 strings, as it +has no flags parameter. If the C parameter is set, the +GV_ADDMULTI flag will be passed to gv_init_pvn(). + +=for apidoc gv_init_pv + +Same as gv_init_pvn(), but takes a nul-terminated string for the name +instead of separate char * and length parameters. + +=for apidoc gv_init_sv + +Same as gv_init_pvn(), but takes an SV * for the name instead of separate +char * and length parameters. C is currently unused. + +=cut +*/ + +void +Perl_gv_init_sv(pTHX_ GV *gv, HV *stash, SV* namesv, U32 flags) +{ + char *namepv; + STRLEN namelen; + PERL_ARGS_ASSERT_GV_INIT_SV; + namepv = SvPV(namesv, namelen); + if (SvUTF8(namesv)) + flags |= SVf_UTF8; + gv_init_pvn(gv, stash, namepv, namelen, flags); +} + +void +Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags) +{ + PERL_ARGS_ASSERT_GV_INIT_PV; + gv_init_pvn(gv, stash, name, strlen(name), flags); +} + void -Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) +Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags) { dVAR; const U32 old_type = SvTYPE(gv); 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; - PERL_ARGS_ASSERT_GV_INIT; + PERL_ARGS_ASSERT_GV_INIT_PVN; assert (!(proto && has_constant)); if (has_constant) { @@ -303,9 +362,9 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) GvSTASH(gv) = stash; if (stash) Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); - gv_name_set(gv, name, len, GV_ADD); - if (multi || doproto) /* doproto means it _was_ mentioned */ - GvMULTI_on(gv); + gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 )); + if (flags & GV_ADDMULTI || doproto) /* doproto means it */ + GvMULTI_on(gv); /* _was_ mentioned */ if (doproto) { /* Replicate part of newSUB here. */ CV *cv; ENTER; @@ -317,7 +376,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) name0 = savepvn(name,len); /* newCONSTSUB takes ownership of the reference from us. */ - cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant); + cv = newCONSTSUB_flags(stash, (name0 ? name0 : name), flags, has_constant); /* In case op.c:S_process_special_blocks stole it: */ if (!GvCV(gv)) GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv)); @@ -343,14 +402,15 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) if (proto) { sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, SV_HAS_TRAILING_NUL); + if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); } } } STATIC void -S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type) +S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type) { - PERL_ARGS_ASSERT_GV_INIT_SV; + PERL_ARGS_ASSERT_GV_INIT_SVTYPE; switch (sv_type) { case SVt_PVIO: @@ -378,9 +438,171 @@ S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type) } } +static void core_xsub(pTHX_ CV* cv); + +static GV * +S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, + const char * const name, const STRLEN len, + const char * const fullname, STRLEN const fullen) +{ + const int code = keyword(name, len, 1); + static const char file[] = __FILE__; + CV *cv, *oldcompcv = NULL; + int opnum = 0; + SV *opnumsv; + bool ampable = TRUE; /* &{}-able */ + COP *oldcurcop = NULL; + yy_parser *oldparser = NULL; + I32 oldsavestack_ix = 0; + + assert(gv || stash); + assert(name); + assert(stash || fullname); + + if (!fullname && !HvENAME(stash)) return NULL; /* pathological case + that would require + inlining newATTRSUB */ + if (code >= 0) return NULL; /* not overridable */ + switch (-code) { + /* no support for \&CORE::infix; + no support for funcs that take labels, as their parsing is + weird */ + case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump: + case KEY_eq: case KEY_ge: + case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne: + case KEY_or: case KEY_x: case KEY_xor: + return NULL; + case KEY_chdir: + case KEY_chomp: case KEY_chop: + case KEY_each: case KEY_eof: case KEY_exec: + case KEY_keys: + case KEY_lstat: + case KEY_pop: + case KEY_push: + case KEY_shift: + case KEY_splice: + case KEY_stat: + case KEY_system: + case KEY_truncate: case KEY_unlink: + case KEY_unshift: + case KEY_values: + ampable = FALSE; + } + if (!gv) { + gv = (GV *)newSV(0); + gv_init(gv, stash, name, len, TRUE); + } + if (ampable) { + ENTER; + oldcurcop = PL_curcop; + oldparser = PL_parser; + lex_start(NULL, NULL, 0); + oldcompcv = PL_compcv; + PL_compcv = NULL; /* Prevent start_subparse from setting + CvOUTSIDE. */ + oldsavestack_ix = start_subparse(FALSE,0); + cv = PL_compcv; + } + else { + /* Avoid calling newXS, as it calls us, and things start to + get hairy. */ + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + GvCV_set(gv,cv); + GvCVGEN(gv) = 0; + mro_method_changed_in(GvSTASH(gv)); + CvISXSUB_on(cv); + CvXSUB(cv) = core_xsub; + } + CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE + from PL_curcop. */ + (void)gv_fetchfile(file); + CvFILE(cv) = (char *)file; + /* XXX This is inefficient, as doing things this order causes + a prototype check in newATTRSUB. But we have to do + it this order as we need an op number before calling + new ATTRSUB. */ + (void)core_prototype((SV *)cv, name, code, &opnum); + if (stash && (fullname || !fullen)) + (void)hv_store(stash,name,len,(SV *)gv,0); + if (ampable) { + SV *tmpstr; + CvLVALUE_on(cv); + if (!fullname) { + tmpstr = newSVhek(HvENAME_HEK(stash)); + sv_catpvs(tmpstr, "::"); + sv_catpvn(tmpstr,name,len); + } + else tmpstr = newSVpvn_share(fullname,fullen,0); + newATTRSUB(oldsavestack_ix, + newSVOP(OP_CONST, 0, tmpstr), + NULL,NULL, + coresub_op( + opnum + ? newSVuv((UV)opnum) + : newSVpvn(name,len), + code, opnum + ) + ); + assert(GvCV(gv) == cv); + if (opnum != OP_VEC && opnum != OP_SUBSTR) + CvLVALUE_off(cv); /* Now *that* was a neat trick. */ + LEAVE; + PL_parser = oldparser; + PL_curcop = oldcurcop; + PL_compcv = oldcompcv; + } + opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; + cv_set_call_checker( + cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv + ); + SvREFCNT_dec(opnumsv); + return gv; +} + /* =for apidoc gv_fetchmeth +Like L, but lacks a flags parameter. + +=for apidoc gv_fetchmeth_sv + +Exactly like L, but takes the name string in the form +of an SV instead of a string/length pair. + +=cut +*/ + +GV * +Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) +{ + char *namepv; + STRLEN namelen; + PERL_ARGS_ASSERT_GV_FETCHMETH_SV; + namepv = SvPV(namesv, namelen); + if (SvUTF8(namesv)) + flags |= SVf_UTF8; + return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags); +} + +/* +=for apidoc gv_fetchmeth_pv + +Exactly like L, but takes a nul-terminated string +instead of a string/length pair. + +=cut +*/ + +GV * +Perl_gv_fetchmeth_pv(pTHX_ HV *stash, const char *name, I32 level, U32 flags) +{ + PERL_ARGS_ASSERT_GV_FETCHMETH_PV; + return gv_fetchmeth_pvn(stash, name, strlen(name), level, flags); +} + +/* +=for apidoc gv_fetchmeth_pvn + Returns the glob with the given C and a defined subroutine or C. The glob lives in the given C, or in the stashes accessible via @ISA and UNIVERSAL::. @@ -390,6 +612,8 @@ side-effect creates a glob with the given C in the given C which in the case of success contains an alias for the subroutine, and sets up caching info for this glob. +Currently, the only significant value for C is SVf_UTF8. + This function grants C<"SUPER"> token as a postfix of the stash name. The GV returned from C may be a method cache entry, which is not visible to Perl code. So when calling C, you should not use @@ -402,7 +626,7 @@ obtained from the GV with the C macro. /* NOTE: No support for tied ISA */ GV * -Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) +Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) { dVAR; GV** gvp; @@ -418,8 +642,9 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) I32 items; STRLEN packlen; U32 topgen_cmp; + U32 is_utf8 = flags & SVf_UTF8; - PERL_ARGS_ASSERT_GV_FETCHMETH; + PERL_ARGS_ASSERT_GV_FETCHMETH_PVN; /* UNIVERSAL methods should be callable without a stash */ if (!stash) { @@ -442,12 +667,13 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; /* check locally for a real method or a cache entry */ - gvp = (GV**)hv_fetch(stash, name, len, create); + gvp = (GV**)hv_fetch(stash, name, is_utf8 ? -(I32)len : (I32)len, create); if(gvp) { topgv = *gvp; + have_gv: assert(topgv); if (SvTYPE(topgv) != SVt_PVGV) - gv_init(topgv, stash, name, len, TRUE); + gv_init_pvn(topgv, stash, name, len, GV_ADDMULTI|is_utf8); if ((cand_cv = GvCV(topgv))) { /* If genuine method or valid cache entry, use it */ if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) { @@ -465,13 +691,18 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* cache indicates no such method definitively */ return 0; } + else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4 + && strnEQ(hvname, "CORE", 4) + && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1)) + goto have_gv; } packlen = HvNAMELEN_get(stash); if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { HV* basestash; packlen -= 7; - basestash = gv_stashpvn(hvname, packlen, GV_ADD); + basestash = gv_stashpvn(hvname, packlen, + GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0)); linear_av = mro_get_linear_isa(basestash); } else { @@ -486,18 +717,32 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) cstash = gv_stashsv(linear_sv, 0); if (!cstash) { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", - SVfARG(linear_sv), hvname); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Can't locate package %"SVf" for @%"HEKf"::ISA", + SVfARG(linear_sv), + HEKfARG(HvNAME_HEK(stash))); continue; } assert(cstash); - gvp = (GV**)hv_fetch(cstash, name, len, 0); - if (!gvp) continue; - candidate = *gvp; + gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0); + if (!gvp) { + if (len > 1 && HvNAMELEN_get(cstash) == 4) { + const char *hvname = HvNAME(cstash); assert(hvname); + if (strnEQ(hvname, "CORE", 4) + && (candidate = + S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0) + )) + goto have_candidate; + } + continue; + } + else candidate = *gvp; + have_candidate: assert(candidate); - if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE); + if (SvTYPE(candidate) != SVt_PVGV) + gv_init_pvn(candidate, cstash, name, len, GV_ADDMULTI|is_utf8); if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { /* * Found real method, cache method in topgv if: @@ -517,7 +762,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* Check UNIVERSAL without caching */ if(level == 0 || level == -1) { - candidate = gv_fetchmeth(NULL, name, len, 1); + candidate = gv_fetchmeth_pvn(NULL, name, len, 1, flags); if(candidate) { cand_cv = GvCV(candidate); if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { @@ -542,22 +787,66 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* =for apidoc gv_fetchmeth_autoload -Same as gv_fetchmeth(), but looks for autoloaded subroutines too. +This is the old form of L, which has no flags +parameter. + +=for apidoc gv_fetchmeth_sv_autoload + +Exactly like L, but takes the name string in the form +of an SV instead of a string/length pair. + +=cut +*/ + +GV * +Perl_gv_fetchmeth_sv_autoload(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) +{ + char *namepv; + STRLEN namelen; + PERL_ARGS_ASSERT_GV_FETCHMETH_SV_AUTOLOAD; + namepv = SvPV(namesv, namelen); + if (SvUTF8(namesv)) + flags |= SVf_UTF8; + return gv_fetchmeth_pvn_autoload(stash, namepv, namelen, level, flags); +} + +/* +=for apidoc gv_fetchmeth_pv_autoload + +Exactly like L, but takes a nul-terminated string +instead of a string/length pair. + +=cut +*/ + +GV * +Perl_gv_fetchmeth_pv_autoload(pTHX_ HV *stash, const char *name, I32 level, U32 flags) +{ + PERL_ARGS_ASSERT_GV_FETCHMETH_PV_AUTOLOAD; + return gv_fetchmeth_pvn_autoload(stash, name, strlen(name), level, flags); +} + +/* +=for apidoc gv_fetchmeth_pvn_autoload + +Same as gv_fetchmeth_pvn(), but looks for autoloaded subroutines too. Returns a glob for the subroutine. For an autoloaded subroutine without a GV, will create a GV even if C. For an autoloaded subroutine without a stub, GvCV() of the result may be zero. +Currently, the only significant value for C is SVf_UTF8. + =cut */ GV * -Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) +Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) { - GV *gv = gv_fetchmeth(stash, name, len, level); + GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags); - PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD; + PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD; if (!gv) { CV *cv; @@ -567,15 +856,16 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) return NULL; - if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) + if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) return NULL; /* Have an autoload */ if (level < 0) /* Cannot do without a stub */ - gv_fetchmeth(stash, name, len, 0); - gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); + gv_fetchmeth_pvn(stash, name, len, 0, flags); + gvp = (GV**)hv_fetch(stash, name, + (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0)); if (!gvp) return NULL; return *gvp; @@ -612,7 +902,7 @@ C apply equally to these functions. */ STATIC HV* -S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) +S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags) { AV* superisa; GV** gvp; @@ -621,13 +911,13 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) PERL_ARGS_ASSERT_GV_GET_SUPER_PKG; - stash = gv_stashpvn(name, namelen, 0); + stash = gv_stashpvn(name, namelen, flags); if(stash) return stash; /* If we must create it, give it an @ISA array containing the real package this SUPER is for, so that it's tied into the cache invalidation code correctly */ - stash = gv_stashpvn(name, namelen, GV_ADD); + stash = gv_stashpvn(name, namelen, GV_ADD | flags); gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); gv = *gvp; gv_init(gv, stash, "ISA", 3, TRUE); @@ -635,7 +925,10 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) GvMULTI_on(gv); sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); #ifdef USE_ITHREADS - av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0)); + av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop), + strlen(CopSTASHPV(PL_curcop)), + CopSTASH_flags(PL_curcop) + )); #else av_push(superisa, newSVhek(CopSTASH(PL_curcop) ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL)); @@ -652,10 +945,29 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0); } +GV * +Perl_gv_fetchmethod_sv_flags(pTHX_ HV *stash, SV *namesv, U32 flags) +{ + char *namepv; + STRLEN namelen; + PERL_ARGS_ASSERT_GV_FETCHMETHOD_SV_FLAGS; + namepv = SvPV(namesv, namelen); + if (SvUTF8(namesv)) + flags |= SVf_UTF8; + return gv_fetchmethod_pvn_flags(stash, namepv, namelen, flags); +} + +GV * +Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags) +{ + PERL_ARGS_ASSERT_GV_FETCHMETHOD_PV_FLAGS; + return gv_fetchmethod_pvn_flags(stash, name, strlen(name), flags); +} + /* Don't merge this yet, as it's likely to get a len parameter, and possibly even a U32 hash */ GV * -Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) +Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags) { dVAR; register const char *nend; @@ -666,8 +978,9 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) SV *const error_report = MUTABLE_SV(stash); const U32 autoload = flags & GV_AUTOLOAD; const U32 do_croak = flags & GV_CROAK; + const U32 is_utf8 = flags & SVf_UTF8; - PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS; + PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS; if (SvTYPE(stash) < SVt_PVHV) stash = NULL; @@ -677,7 +990,7 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) the error reporting code. */ } - for (nend = name; *nend; nend++) { + for (nend = name; *nend || nend != (origname + len); nend++) { if (*nend == '\'') { nsplit = nend; name = nend + 1; @@ -690,33 +1003,37 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) if (nsplit) { if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ - SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", - CopSTASHPV(PL_curcop))); + SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ + "%"HEKf"::SUPER", + HEKfARG(HvNAME_HEK((HV*)CopSTASH(PL_curcop))) + )); /* __PACKAGE__::SUPER stash should be autovivified */ - stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr)); + stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr)); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME_get(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ - stash = gv_stashpvn(origname, nsplit - origname, 0); + stash = gv_stashpvn(origname, nsplit - origname, is_utf8); /* however, explicit calls to Pkg::SUPER::method may happen, and may require autovivification to work */ if (!stash && (nsplit - origname) >= 7 && strnEQ(nsplit - 7, "::SUPER", 7) && - gv_stashpvn(origname, nsplit - origname - 7, 0)) - stash = gv_get_super_pkg(origname, nsplit - origname); + gv_stashpvn(origname, nsplit - origname - 7, is_utf8)) + stash = gv_get_super_pkg(origname, nsplit - origname, flags); } ostash = stash; } - gv = gv_fetchmeth(stash, name, nend - name, 0); + gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = MUTABLE_GV(&PL_sv_yes); else if (autoload) - gv = gv_autoload4(ostash, name, nend - name, TRUE); + gv = gv_autoload_pvn( + ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags + ); if (!gv && do_croak) { /* Right now this is exclusively for the benefit of S_method_common in pp_hot.c */ @@ -731,29 +1048,33 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) HV_FETCH_ISEXISTS, NULL, 0) ) { require_pv("IO/File.pm"); - gv = gv_fetchmeth(stash, name, nend - name, 0); + gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags); if (gv) 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 \"%"HEKf"\"", + SVfARG(newSVpvn_flags(name, nend - name, + SVs_TEMP | is_utf8)), + HEKfARG(HvNAME_HEK(stash))); } else { - STRLEN packlen; - const char *packname; + SV* packnamesv; if (nsplit) { - packlen = nsplit - origname; - packname = origname; + packnamesv = newSVpvn_flags(origname, nsplit - origname, + SVs_TEMP | is_utf8); } else { - packname = SvPV_const(error_report, packlen); + packnamesv = sv_2mortal(newSVsv(error_report)); } Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%.*s\"" - " (perhaps you forgot to load \"%.*s\"?)", - name, (int)packlen, packname, (int)packlen, packname); + "Can't locate object method \"%"SVf"\" via package \"%"SVf"\"" + " (perhaps you forgot to load \"%"SVf"\"?)", + SVfARG(newSVpvn_flags(name, nend - name, + SVs_TEMP | is_utf8)), + SVfARG(packnamesv), SVfARG(packnamesv)); } } } @@ -770,8 +1091,10 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) if (GvCV(stubgv) != cv) /* orphaned import */ stubgv = gv; } - autogv = gv_autoload4(GvSTASH(stubgv), - GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); + autogv = gv_autoload_pvn(GvSTASH(stubgv), + GvNAME(stubgv), GvNAMELEN(stubgv), + GV_AUTOLOAD_ISMETHOD + | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0)); if (autogv) gv = autogv; } @@ -781,7 +1104,26 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) } GV* -Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) +Perl_gv_autoload_sv(pTHX_ HV *stash, SV* namesv, U32 flags) +{ + char *namepv; + STRLEN namelen; + PERL_ARGS_ASSERT_GV_AUTOLOAD_SV; + namepv = SvPV(namesv, namelen); + if (SvUTF8(namesv)) + flags |= SVf_UTF8; + return gv_autoload_pvn(stash, namepv, namelen, flags); +} + +GV* +Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags) +{ + PERL_ARGS_ASSERT_GV_AUTOLOAD_PV; + return gv_autoload_pvn(stash, namepv, strlen(namepv), flags); +} + +GV* +Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) { dVAR; GV* gv; @@ -789,24 +1131,25 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) HV* varstash; GV* vargv; SV* varsv; - const char *packname = ""; - STRLEN packname_len = 0; + SV *packname = NULL; + U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0; - PERL_ARGS_ASSERT_GV_AUTOLOAD4; + PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN; if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) return NULL; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { - packname = SvPV_const(MUTABLE_SV(stash), packname_len); + STRLEN packname_len = 0; + const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len); + packname = newSVpvn_flags(packname_ptr, packname_len, + SVs_TEMP | SvUTF8(stash)); stash = NULL; } - else { - packname = HvNAME_get(stash); - packname_len = HvNAMELEN_get(stash); - } + else + packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); } - if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) + if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8))) return NULL; cv = GvCV(gv); @@ -816,11 +1159,14 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) /* * Inheriting AUTOLOAD for non-methods works ... for now. */ - if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash) + if ( + !(flags & GV_AUTOLOAD_ISMETHOD) + && (GvCVGEN(gv) || GvSTASH(gv) != stash) ) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", - packname, (int)len, name); + "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated", + SVfARG(packname), + SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8))); if (CvISXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here @@ -831,6 +1177,8 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) CvSTASH_set(cv, stash); SvPV_set(cv, (char *)name); /* cast to lose constness warning */ SvCUR_set(cv, len); + if (is_utf8) + SvUTF8_on(cv); return gv; } @@ -845,18 +1193,20 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) ENTER; if (!isGV(vargv)) { - gv_init(vargv, varstash, S_autoload, S_autolen, FALSE); + gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); #ifdef PERL_DONT_CREATE_GVSV GvSV(vargv) = newSV(0); #endif } LEAVE; varsv = GvSVn(vargv); - sv_setpvn(varsv, packname, packname_len); + sv_setsv(varsv, packname); sv_catpvs(varsv, "::"); /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */ sv_catpvn_mg(varsv, name, len); + if (is_utf8) + SvUTF8_on(varsv); return gv; } @@ -964,7 +1314,7 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; assert(stash); if (!HvNAME_get(stash)) { - hv_name_set(stash, name, namelen, 0); + hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ /* If the containing stash has multiple effective @@ -991,7 +1341,7 @@ Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) PERL_ARGS_ASSERT_GV_STASHSV; - return gv_stashpvn(ptr, len, flags); + return gv_stashpvn(ptr, len, flags | SvUTF8(sv)); } @@ -1004,7 +1354,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) { GV * Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { STRLEN len; - const char * const nambeg = SvPV_const(name, len); + const char * const nambeg = + SvPV_flags_const(name, len, flags & GV_NO_SVGMAGIC ? 0 : SV_GMAGIC); PERL_ARGS_ASSERT_GV_FETCHSV; return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); } @@ -1034,8 +1385,6 @@ S_gv_magicalize_overload(pTHX_ GV *gv) hv_magic(hv, NULL, PERL_MAGIC_overload); } -static void core_xsub(pTHX_ CV* cv); - GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const svtype sv_type) @@ -1050,6 +1399,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); const I32 no_expand = flags & GV_NOEXPAND; const I32 add = flags & ~GV_NOADD_MASK; + const U32 is_utf8 = flags & SVf_UTF8; + bool addmg = !!(flags & GV_ADDMG); const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; U32 faking_it; @@ -1062,7 +1413,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, goto no_stash; } - if (full_len > 2 && *name == '*' && isALPHA(name[1])) { + if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) { /* accidental stringify on a GV? */ name++; } @@ -1092,11 +1443,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, tmpbuf[len++] = ':'; key = tmpbuf; } - gvp = (GV**)hv_fetch(stash, key, len, add); + gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add); gv = gvp ? *gvp : NULL; if (gv && gv != (const GV *)&PL_sv_undef) { if (SvTYPE(gv) != SVt_PVGV) - gv_init(gv, stash, key, len, (add & GV_ADDMULTI)); + gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8); else GvMULTI_on(gv); } @@ -1114,7 +1465,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, hv_name_set(stash, "CORE", 4, 0); else hv_name_set( - stash, nambeg, name_cursor-nambeg, 0 + stash, nambeg, name_cursor-nambeg, is_utf8 ); /* If the containing stash has multiple effective names, see that this one gets them, too. */ @@ -1123,7 +1474,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } } else if (!HvNAME_get(stash)) - hv_name_set(stash, nambeg, name_cursor - nambeg, 0); + hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8); } if (*name_cursor == ':') @@ -1190,7 +1541,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, !(len == 1 && sv_type == SVt_PV && (*name == 'a' || *name == 'b')) ) { - gvp = (GV**)hv_fetch(stash,name,len,0); + gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0); if (!gvp || *gvp == (const GV *)&PL_sv_undef || SvTYPE(*gvp) != SVt_PVGV) @@ -1201,17 +1552,18 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) { + SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8); /* diag_listed_as: Variable "%s" is not imported%s */ Perl_ck_warner_d( aTHX_ packWARN(WARN_MISC), - "Variable \"%c%s\" is not imported", + "Variable \"%c%"SVf"\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', - name); + SVfARG(namesv)); if (GvCVu(*gvp)) Perl_ck_warner_d( aTHX_ packWARN(WARN_MISC), - "\t(Did you mean &%s instead?)\n", name + "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv) ); stash = NULL; } @@ -1229,11 +1581,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (!stash) { if (add) { SV * const err = Perl_mess(aTHX_ - "Global symbol \"%s%s\" requires explicit package name", + "Global symbol \"%s%"SVf"\" requires explicit package name", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" - : ""), name); + : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8))); GV *gv; if (USE_UTF8_IN_NAMES) SvUTF8_on(err); @@ -1252,14 +1604,19 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (!SvREFCNT(stash)) /* symbol table under destruction */ return NULL; - gvp = (GV**)hv_fetch(stash,name,len,add); - if (!gvp || *gvp == (const GV *)&PL_sv_undef) - return NULL; - gv = *gvp; + gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add); + if (!gvp || *gvp == (const GV *)&PL_sv_undef) { + if (addmg) gv = (GV *)newSV(0); + else return NULL; + } + else gv = *gvp, addmg = 0; + /* From this point on, addmg means gv has not been inserted in the + symtab yet. */ + if (SvTYPE(gv) == SVt_PVGV) { if (add) { GvMULTI_on(gv); - gv_init_sv(gv, sv_type); + gv_init_svtype(gv, sv_type); if (len == 1 && stash == PL_defstash && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) { if (*name == '!') @@ -1274,8 +1631,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } return gv; } else if (no_init) { + assert(!addmg); return gv; } else if (no_expand && SvROK(gv)) { + assert(!addmg); return gv; } @@ -1289,12 +1648,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, faking_it = SvOK(gv); if (add & GV_ADDWARN) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); - gv_init(gv, stash, name, len, add & GV_ADDMULTI); - gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly", + SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 ))); + gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); - if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) - : (PL_dowarn & G_WARN_ON ) ) ) + if ( isIDFIRST_lazy_if(name, is_utf8) + && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) GvMULTI_on(gv) ; /* set up magic where warranted */ @@ -1324,111 +1683,17 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, default: goto try_core; } - return gv; + goto add_magical_gv; } try_core: if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { /* Avoid null warning: */ const char * const stashname = HvNAME(stash); assert(stashname); - if (strnEQ(stashname, "CORE", 4)) { - const int code = keyword(name, len, 1); - static const char file[] = __FILE__; - CV *cv, *oldcompcv; - int opnum = 0; - SV *opnumsv; - bool ampable = TRUE; /* &{}-able */ - COP *oldcurcop; - yy_parser *oldparser; - I32 oldsavestack_ix; - - if (code >= 0) return gv; /* not overridable */ - switch (-code) { - /* no support for \&CORE::infix; - no support for funcs that take labels, as their parsing is - weird */ - case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump: - case KEY_eq: case KEY_ge: - case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne: - case KEY_or: case KEY_x: case KEY_xor: - return gv; - case KEY_chdir: - case KEY_chomp: case KEY_chop: - case KEY_each: case KEY_eof: case KEY_exec: - case KEY_keys: - case KEY_lstat: - case KEY_pop: - case KEY_push: case KEY_reset: - case KEY_select: case KEY_send: - case KEY_setpgrp: case KEY_shift: case KEY_sleep: - case KEY_splice: - case KEY_srand: case KEY_stat: case KEY_substr: - case KEY_sysopen: - case KEY_system: case KEY_syswrite: - case KEY_tell: case KEY_tie: case KEY_tied: - case KEY_truncate: case KEY_umask: case KEY_unlink: - case KEY_unpack: case KEY_unshift: case KEY_untie: - case KEY_values: case KEY_write: - ampable = FALSE; - } - if (ampable) { - ENTER; - oldcurcop = PL_curcop; - oldparser = PL_parser; - lex_start(NULL, NULL, 0); - oldcompcv = PL_compcv; - PL_compcv = NULL; /* Prevent start_subparse from setting - CvOUTSIDE. */ - oldsavestack_ix = start_subparse(FALSE,0); - cv = PL_compcv; - } - else { - /* Avoid calling newXS, as it calls us, and things start to - get hairy. */ - cv = MUTABLE_CV(newSV_type(SVt_PVCV)); - GvCV_set(gv,cv); - GvCVGEN(gv) = 0; - mro_method_changed_in(GvSTASH(gv)); - CvISXSUB_on(cv); - CvXSUB(cv) = core_xsub; - } - CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE - from PL_curcop. */ - (void)gv_fetchfile(file); - CvFILE(cv) = (char *)file; - /* XXX This is inefficient, as doing things this order causes - a prototype check in newATTRSUB. But we have to do - it this order as we need an op number before calling - new ATTRSUB. */ - (void)core_prototype((SV *)cv, name, code, &opnum); - if (ampable) { - if (opnum == OP_VEC || opnum == OP_LOCK) CvLVALUE_on(cv); - newATTRSUB(oldsavestack_ix, - newSVOP( - OP_CONST, 0, - newSVpvn_share(nambeg,full_len,0) - ), - NULL,NULL, - coresub_op( - opnum - ? newSVuv((UV)opnum) - : newSVpvn(name,len), - code, opnum - ) - ); - assert(GvCV(gv) == cv); - if (opnum == OP_LOCK) - CvLVALUE_off(cv); /* Now *that* was a neat trick. */ - LEAVE; - PL_parser = oldparser; - PL_curcop = oldcurcop; - PL_compcv = oldcompcv; - } - opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; - cv_set_call_checker( - cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv - ); - SvREFCNT_dec(opnumsv); - } + if (strnEQ(stashname, "CORE", 4) + && S_maybe_add_coresub(aTHX_ + addmg ? stash : 0, gv, name, len, nambeg, full_len + )) + addmg = 0; } } else if (len > 1) { @@ -1555,7 +1820,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* This snippet is taken from is_gv_magical */ const char *end = name + len; while (--end > name) { - if (!isDIGIT(*end)) return gv; + if (!isDIGIT(*end)) goto add_magical_gv; } goto magicalize; } @@ -1684,7 +1949,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case ']': /* $] */ { - SV * const sv = GvSVn(gv); + SV * const sv = GvSV(gv); if (!sv_derived_from(PL_patchlevel, "version")) upg_version(PL_patchlevel, TRUE); GvSV(gv) = vnumify(PL_patchlevel); @@ -1694,7 +1959,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case '\026': /* $^V */ { - SV * const sv = GvSVn(gv); + SV * const sv = GvSV(gv); GvSV(gv) = new_version(PL_patchlevel); SvREADONLY_on(GvSV(gv)); SvREFCNT_dec(sv); @@ -1702,14 +1967,22 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; } } + add_magical_gv: + if (addmg) { + if (GvAV(gv) || GvHV(gv) || GvIO(gv) || GvCV(gv) || ( + GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))) + )) + (void)hv_store(stash,name,len,(SV *)gv,0); + else SvREFCNT_dec(gv), gv = NULL; + } + if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); return gv; } void Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) { - const char *name; - STRLEN namelen; + SV *name; const HV * const hv = GvSTASH(gv); PERL_ARGS_ASSERT_GV_FULLNAME4; @@ -1720,19 +1993,15 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) } sv_setpv(sv, prefix ? prefix : ""); - name = HvNAME_get(hv); - if (name) { - namelen = HvNAMELEN_get(hv); - } else { - name = "__ANON__"; - namelen = 8; - } + name = HvNAME_get(hv) + ? sv_2mortal(newSVhek(HvNAME_HEK(hv))) + : newSVpvn_flags( "__ANON__", 8, SVs_TEMP ); - if (keepmain || strNE(name, "main")) { - sv_catpvn(sv,name,namelen); + if (keepmain || strnNE(SvPV_nolen(name), "main", SvCUR(name))) { + sv_catsv(sv,name); sv_catpvs(sv,"::"); } - sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); + sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv)))); } void @@ -1766,7 +2035,8 @@ Perl_gv_check(pTHX_ const HV *stash) if (hv != PL_defstash && hv != stash) gv_check(hv); /* nested package */ } - else if (isALPHA(*HeKEY(entry))) { + else if ( *HeKEY(entry) != '_' + && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) { const char *file; gv = MUTABLE_GV(HeVAL(entry)); if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) @@ -1780,22 +2050,26 @@ Perl_gv_check(pTHX_ const HV *stash) = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); #endif Perl_warner(aTHX_ packWARN(WARN_ONCE), - "Name \"%s::%s\" used only once: possible typo", - HvNAME_get(stash), GvNAME(gv)); + "Name \"%"HEKf"::%"HEKf + "\" used only once: possible typo", + HEKfARG(HvNAME_HEK(stash)), + HEKfARG(GvNAME_HEK(gv))); } } } } GV * -Perl_newGVgen(pTHX_ const char *pack) +Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) { dVAR; + PERL_ARGS_ASSERT_NEWGVGEN_FLAGS; - PERL_ARGS_ASSERT_NEWGVGEN; - - return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), - GV_ADD, SVt_PVGV); + return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld", + SVfARG(newSVpvn_flags(pack, strlen(pack), + SVs_TEMP | flags)), + (long)PL_gensym++), + GV_ADD, SVt_PVGV); } /* hopefully this is only called on local symbol table entries */ @@ -1869,10 +2143,11 @@ Perl_gp_free(pTHX_ GV *gv) /* FIXME - another reference loop GV -> symtab -> GV ? Somehow gp->gp_hv can end up pointing at freed garbage. */ if (hv && SvTYPE(hv) == SVt_PVHV) { - const char *hvname = HvNAME_get(hv); - if (PL_stashcache && hvname) - (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv), - G_DISCARD); + const HEK *hvname_hek = HvNAME_HEK(hv); + if (PL_stashcache && hvname_hek) + (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek), + (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)), + G_DISCARD); SvREFCNT_dec(hv); } SvREFCNT_dec(io); @@ -1963,7 +2238,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ /* Try to find via inheritance. */ - GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); + GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0); SV * const sv = gv ? GvSV(gv) : NULL; CV* cv; @@ -1997,14 +2272,15 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) But if B overloads "bool", we may want to use it for numifying instead of C's "+0". */ if (i >= DESTROY_amg) - gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0); + gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0); else /* Autoload taken care of below */ - gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); + gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); cv = 0; if (gv && (cv = GvCV(gv))) { - const char *hvname; - if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") - && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) { + if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){ + const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv))); + if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8 + && strEQ(hvname, "overload")) { /* This is a hack to support autoloading..., while knowing *which* methods were declared as overloaded. */ /* GvSV contains the name of the method. */ @@ -2013,25 +2289,31 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ "\" for overloaded \"%s\" in package \"%.256s\"\n", - (void*)GvSV(gv), cp, hvname) ); + (void*)GvSV(gv), cp, HvNAME(stash)) ); if (!gvsv || !SvPOK(gvsv) - || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv), - FALSE))) + || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) { /* Can be an import stub (created by "can"). */ if (destructing) { return -1; } else { - const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???"; - Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\ - "in package \"%.256s\"", + const SV * const name = (gvsv && SvPOK(gvsv)) + ? gvsv + : newSVpvs_flags("???", SVs_TEMP); + Perl_croak(aTHX_ "%s method \"%"SVf256 + "\" overloading \"%s\" "\ + "in package \"%"HEKf256"\"", (GvCVGEN(gv) ? "Stub found while resolving" : "Can't resolve"), - name, cp, hvname); + SVfARG(name), cp, + HEKfARG( + HvNAME_HEK(stash) + )); } } cv = GvCV(gv = ngv); + } } DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), @@ -2490,25 +2772,25 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SV *msg; if (off==-1) off=method; msg = sv_2mortal(Perl_newSVpvf(aTHX_ - "Operation \"%s\": no method found,%sargument %s%s%s%s", - AMG_id2name(method + assignshift), - (flags & AMGf_unary ? " " : "\n\tleft "), - SvAMAGIC(left)? - "in overloaded package ": - "has no overloaded magic", - SvAMAGIC(left)? - HvNAME_get(SvSTASH(SvRV(left))): - "", - SvAMAGIC(right)? - ",\n\tright argument in overloaded package ": - (flags & AMGf_unary - ? "" - : ",\n\tright argument has no overloaded magic"), - SvAMAGIC(right)? - HvNAME_get(SvSTASH(SvRV(right))): - "")); + "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf, + AMG_id2name(method + assignshift), + (flags & AMGf_unary ? " " : "\n\tleft "), + SvAMAGIC(left)? + "in overloaded package ": + "has no overloaded magic", + SvAMAGIC(left)? + SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))): + SVfARG(&PL_sv_no), + SvAMAGIC(right)? + ",\n\tright argument in overloaded package ": + (flags & AMGf_unary + ? "" + : ",\n\tright argument has no overloaded magic"), + SvAMAGIC(right)? + SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))): + SVfARG(&PL_sv_no))); if (use_default_op) { - DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); + DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) ); } else { Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); } @@ -2520,7 +2802,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ - "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n", + "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n", AMG_id2name(off), method+assignshift==off? "" : " (initially \"", @@ -2530,7 +2812,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", flags & AMGf_unary? " for argument" : "", - stash ? HvNAME_get(stash) : "null", + stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), fl? ",\n\tassignment variant used": "") ); } #endif @@ -2654,146 +2936,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } } -/* -=for apidoc is_gv_magical_sv - -Returns C if given the name of a magical GV. Any get-magic that -C has is ignored. - -Currently only useful internally when determining if a GV should be -created even in rvalue contexts. - -C is not used at present but available for future extension to -allow selecting particular classes of magical variable. - -=cut -*/ - -bool -Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags) -{ - STRLEN len; - const char *const name = SvPV_nomg_const(name_sv, len); - - PERL_UNUSED_ARG(flags); - PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV; - - if (len > 1) { - const char * const name1 = name + 1; - switch (*name) { - case 'I': - if (len == 3 && name[1] == 'S' && name[2] == 'A') - goto yes; - break; - case 'O': - if (len == 8 && strEQ(name1, "VERLOAD")) - goto yes; - break; - case 'S': - if (len == 3 && name[1] == 'I' && name[2] == 'G') - goto yes; - break; - /* Using ${^...} variables is likely to be sufficiently rare that - it seems sensible to avoid the space hit of also checking the - length. */ - case '\017': /* ${^OPEN} */ - if (strEQ(name1, "PEN")) - goto yes; - break; - case '\024': /* ${^TAINT} */ - if (strEQ(name1, "AINT")) - goto yes; - break; - case '\025': /* ${^UNICODE} */ - if (strEQ(name1, "NICODE")) - goto yes; - if (strEQ(name1, "TF8LOCALE")) - goto yes; - break; - case '\027': /* ${^WARNING_BITS} */ - if (strEQ(name1, "ARNING_BITS")) - goto yes; - break; - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - { - const char *end = name + len; - while (--end > name) { - if (!isDIGIT(*end)) - return FALSE; - } - goto yes; - } - } - } else { - /* Because we're already assuming that name is NUL terminated - below, we can treat an empty name as "\0" */ - switch (*name) { - case '&': - case '`': - case '\'': - case ':': - case '?': - case '!': - case '-': - case '#': - case '[': - case '^': - case '~': - case '=': - case '%': - case '.': - case '(': - case ')': - case '<': - case '>': - case '\\': - case '/': - case '$': - case '|': - case '+': - case ';': - case ']': - case '\001': /* $^A */ - case '\003': /* $^C */ - case '\004': /* $^D */ - case '\005': /* $^E */ - case '\006': /* $^F */ - case '\010': /* $^H */ - case '\011': /* $^I, NOT \t in EBCDIC */ - case '\014': /* $^L */ - case '\016': /* $^N */ - case '\017': /* $^O */ - case '\020': /* $^P */ - case '\023': /* $^S */ - case '\024': /* $^T */ - case '\026': /* $^V */ - case '\027': /* $^W */ - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - yes: - return TRUE; - default: - break; - } - } - return FALSE; -} - void Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) { @@ -2801,7 +2943,6 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) U32 hash; PERL_ARGS_ASSERT_GV_NAME_SET; - PERL_UNUSED_ARG(flags); if (len > I32_MAX) Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len); @@ -2811,7 +2952,7 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) } PERL_HASH(hash, name, len); - GvNAME_HEK(gv) = share_hek(name, len, hash); + GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); } /*