X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/79656330a0811b95642a8239e923166ada7fb0a0..23e9944fa5e16d77ef1b741388ed0221a9729354:/gv.c diff --git a/gv.c b/gv.c index 6df78cc..0dcbabc 100644 --- a/gv.c +++ b/gv.c @@ -83,8 +83,8 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) if (!*where) { *where = newSV_type(type); - if (type == SVt_PVAV && GvNAMELEN(gv) == 3 - && strEQs(GvNAME(gv), "ISA")) + if (type == SVt_PVAV + && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); } return gv; @@ -373,6 +373,9 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag 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; + const bool really_sub = + has_constant && SvTYPE(has_constant) == SVt_PVCV; + COP * const old = PL_curcop; PERL_ARGS_ASSERT_GV_INIT_PVN; assert (!(proto && has_constant)); @@ -411,14 +414,19 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag SvIOK_off(gv); isGV_with_GP_on(gv); + if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant) + && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE + || CvSTART(has_constant)->op_type == OP_DBSTATE)) + PL_curcop = (COP *)CvSTART(has_constant); GvGP_set(gv, Perl_newGP(aTHX_ gv)); + PL_curcop = old; GvSTASH(gv) = stash; if (stash) Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(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 (has_constant && SvTYPE(has_constant) == SVt_PVCV) { + if (really_sub) { /* Not actually a constant. Just a regular sub. */ CV * const cv = (CV *)has_constant; GvCV_set(gv,cv); @@ -639,7 +647,8 @@ Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) STRLEN namelen; PERL_ARGS_ASSERT_GV_FETCHMETH_SV; if (LIKELY(SvPOK_nog(namesv))) /* common case */ - return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, flags); + return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, + flags | SvUTF8(namesv)); namepv = SvPV(namesv, namelen); if (SvUTF8(namesv)) flags |= SVf_UTF8; return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags); @@ -771,8 +780,8 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, return 0; } else if (stash == cachestash - && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4 - && strEQs(hvname, "CORE") + && len > 1 /* shortest is uc */ + && memEQs(hvname, HvNAMELEN_get(stash), "CORE") && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len)) goto have_gv; } @@ -799,7 +808,7 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, if (!gvp) { if (len > 1 && HvNAMELEN_get(cstash) == 4) { const char *hvname = HvNAME(cstash); assert(hvname); - if (strEQs(hvname, "CORE") + if (strBEGINs(hvname, "CORE") && (candidate = S_maybe_add_coresub(aTHX_ cstash,NULL,name,len) )) @@ -1065,7 +1074,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le origname, HvENAME_get(stash), name) ); } else if ( sep_len >= 7 && - strEQs(last_separator - 7, "::SUPER")) { + strBEGINs(last_separator - 7, "::SUPER")) { /* don't autovifify if ->NoSuchStash::SUPER::method */ stash = gv_stashpvn(origname, sep_len - 7, is_utf8); if (stash) flags |= GV_SUPER; @@ -1082,9 +1091,10 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le /* This is the special case that exempts Foo->import and Foo->unimport from being an error even if there's no import/unimport subroutine */ - if (strEQ(name,"import") || strEQ(name,"unimport")) - gv = MUTABLE_GV(&PL_sv_yes); - else if (autoload) + if (strEQ(name,"import") || strEQ(name,"unimport")) { + gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL, + NULL, 0, 0, NULL)); + } else if (autoload) gv = gv_autoload_pvn( ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags ); @@ -1262,7 +1272,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) sv_setsv_nomg((SV *)cv, tmpsv); SvTEMP_off(tmpsv); SvREFCNT_dec_NN(tmpsv); - SvLEN(cv) = SvCUR(cv) + 1; + SvLEN_set(cv, SvCUR(cv) + 1); SvCUR(cv) = ulen; } else { @@ -1341,11 +1351,16 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, PUSHSTACKi(PERLSI_MAGIC); ENTER; -#define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0) +#define GET_HV_FETCH_TIE_FUNC \ + ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \ + && *gvp \ + && ( (isGV(*gvp) && GvCV(*gvp)) \ + || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \ + ) /* Load the module if it is not loaded. */ if (!(stash = gv_stashpvn(name, len, 0)) - || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) + || ! GET_HV_FETCH_TIE_FUNC) { SV * const module = newSVpvn(name, len); const char type = varname == '[' ? '$' : '%'; @@ -1357,12 +1372,12 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, if (!stash) Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", type, varname, name); - else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) + else if (! GET_HV_FETCH_TIE_FUNC) Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", type, varname, name); } /* Now call the tie function. It should be in *gvp. */ - assert(gvp); assert(*gvp); assert(GvCV(*gvp)); + assert(gvp); assert(*gvp); PUSHMARK(SP); XPUSHs((SV *)gv); PUTBACK; @@ -1661,7 +1676,7 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, *stash = GvHV(*gv) = newHV(); if (!HvNAME_get(*stash)) { if (GvSTASH(*gv) == PL_defstash && *len == 6 - && strEQs(*name, "CORE")) + && strBEGINs(*name, "CORE")) hv_name_sets(*stash, "CORE", 0); else hv_name_set( @@ -1920,7 +1935,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { /* Avoid null warning: */ const char * const stashname = HvNAME(stash); assert(stashname); - if (strEQs(stashname, "CORE")) + if (strBEGINs(stashname, "CORE")) S_maybe_add_coresub(aTHX_ 0, gv, name, len); } } @@ -2052,6 +2067,10 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, goto storeparen; } break; + case '\023': + if (memEQs(name, len, "\023AFE_LOCALES")) + goto ro_magicalize; + break; case '\024': /* ${^TAINT} */ if (memEQs(name, len, "\024AINT")) goto ro_magicalize; @@ -2396,8 +2415,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (len == 1 && stash == PL_defstash) { maybe_multimagic_gv(gv, name, sv_type); } - else if (len == 3 && sv_type == SVt_PVAV - && strEQs(name, "ISA") + else if (sv_type == SVt_PVAV + && memEQs(name, len, "ISA") && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) gv_magicalize_isa(gv); } @@ -2473,7 +2492,7 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) if (hv && (name = HvNAME(hv))) { const STRLEN len = HvNAMELEN(hv); - if (keepmain || strnNE(name, "main", len)) { + if (keepmain || ! memBEGINs(name, len, "main")) { sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); sv_catpvs(sv,"::"); } @@ -2802,9 +2821,9 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) const HEK * const gvhek = CvGvNAME_HEK(cv); const HEK * const stashek = HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv))); - if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil") - && stashek && HEK_LEN(stashek) == 8 - && strEQ(HEK_KEY(stashek), "overload")) { + if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil") + && stashek + && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) { /* This is a hack to support autoloading..., while knowing *which* methods were declared as overloaded. */ /* GvSV contains the name of the method. */ @@ -3462,7 +3481,12 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SV* res; const bool oldcatch = CATCH_GET; I32 oldmark, nret; - U8 gimme = force_scalar ? G_SCALAR : GIMME_V; + /* for multiconcat, we may call overload several times, + * with the context of individual concats being scalar, + * regardless of the overall context of the multiconcat op + */ + U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT) + ? G_SCALAR : GIMME_V; CATCH_SET(TRUE); Zero(&myop, 1, BINOP); @@ -3523,7 +3547,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) res = &PL_sv_undef; SP = PL_stack_base + oldmark; break; - case G_ARRAY: { + case G_ARRAY: if (flags & AMGf_want_list) { res = sv_2mortal((SV *)newAV()); av_extend((AV *)res, nret); @@ -3532,7 +3556,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) break; } /* FALLTHROUGH */ - } default: res = POPs; break;