X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/070dc47562b0f958a4767d69f47c6cf47cb7e230..1da7b04307a09e4931d85cc5a89e85f653429783:/gv.c diff --git a/gv.c b/gv.c index 29bf398..73fb7da 100644 --- a/gv.c +++ b/gv.c @@ -21,7 +21,6 @@ /* =head1 GV Functions - A GV is a structure which corresponds to to a Perl typeglob, ie *foo. It is a structure that holds a pointer to a scalar, an array, a hash etc, corresponding to $foo, @foo, %foo. @@ -82,10 +81,12 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) } if (!*where) + { *where = newSV_type(type); - if (type == SVt_PVAV && GvNAMELEN(gv) == 3 - && strnEQ(GvNAME(gv), "ISA", 3)) - sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); + if (type == SVt_PVAV && GvNAMELEN(gv) == 3 + && strnEQ(GvNAME(gv), "ISA", 3)) + sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); + } return gv; } @@ -100,7 +101,6 @@ GV * Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, const U32 flags) { - dVAR; char smallbuf[128]; char *tmpbuf; const STRLEN tmplen = namelen + 2; @@ -130,7 +130,7 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, #endif } if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv)) - hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); + hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile); if (tmpbuf != smallbuf) Safefree(tmpbuf); return gv; @@ -151,6 +151,7 @@ SV * Perl_gv_const_sv(pTHX_ GV *gv) { PERL_ARGS_ASSERT_GV_CONST_SV; + PERL_UNUSED_CONTEXT; if (SvTYPE(gv) == SVt_PVGV) return cv_const_sv(GvCVu(gv)); @@ -176,9 +177,10 @@ Perl_newGP(pTHX_ GV *const gv) gp->gp_sv = newSV(0); #endif - /* PL_curcop should never be null here. */ - assert(PL_curcop); - /* But for non-debugging builds play it safe */ + /* PL_curcop may be null here. E.g., + INIT { bless {} and exit } + frees INIT before looking up DESTROY (and creating *DESTROY) + */ if (PL_curcop) { gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ #ifdef USE_ITHREADS @@ -214,7 +216,7 @@ Perl_newGP(pTHX_ GV *const gv) void Perl_cvgv_set(pTHX_ CV* cv, GV* gv) { - GV * const oldgv = CvGV(cv); + GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv; HEK *hek; PERL_ARGS_ASSERT_CVGV_SET; @@ -230,7 +232,11 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); } } - else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek); + else if ((hek = CvNAME_HEK(cv))) { + unshare_hek(hek); + CvNAMED_off(cv); + CvLEXICAL_off(cv); + } SvANY(cv)->xcv_gv_u.xcv_gv = gv; assert(!CvCVGV_RC(cv)); @@ -246,6 +252,37 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) } } +/* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a + GV, but for efficiency that GV may not in fact exist. This function, + called by CvGV, reifies it. */ + +GV * +Perl_cvgv_from_hek(pTHX_ CV *cv) +{ + GV *gv; + SV **svp; + PERL_ARGS_ASSERT_CVGV_FROM_HEK; + assert(SvTYPE(cv) == SVt_PVCV); + if (!CvSTASH(cv)) return NULL; + ASSUME(CvNAME_HEK(cv)); + svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0); + gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0)); + if (!isGV(gv)) + gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)), + HEK_LEN(CvNAME_HEK(cv)), + SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv))); + if (!CvNAMED(cv)) { /* gv_init took care of it */ + assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv); + return gv; + } + unshare_hek(CvNAME_HEK(cv)); + CvNAMED_off(cv); + SvANY(cv)->xcv_gv_u.xcv_gv = gv; + if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv); + CvCVGV_RC_on(cv); + return gv; +} + /* Assign CvSTASH(cv) = st, handling weak references. */ void @@ -327,7 +364,6 @@ Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags) void 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)) @@ -342,14 +378,14 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag assert (!(proto && has_constant)); if (has_constant) { - /* The constant has to be a simple scalar type. */ + /* The constant has to be a scalar, array or subroutine. */ switch (SvTYPE(has_constant)) { case SVt_PVHV: - case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", sv_reftype(has_constant, 0)); + default: NOOP; } SvRV_set(gv, NULL); @@ -380,7 +416,21 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag 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) { + if (has_constant && SvTYPE(has_constant) == SVt_PVCV) { + /* Not actually a constant. Just a regular sub. */ + CV * const cv = (CV *)has_constant; + GvCV_set(gv,cv); + if (CvSTASH(cv) == stash && ( + CvNAME_HEK(cv) == GvNAME_HEK(gv) + || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv)) + && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv)) + && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv)) + && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv)) + ) + )) + CvGV_set(cv,gv); + } + else if (doproto) { CV *cv; if (has_constant) { /* newCONSTSUB takes ownership of the reference from us. */ @@ -460,7 +510,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, /* no support for \&CORE::infix; no support for funcs that do not parse like funcs */ case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD: - case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_CORE : + case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_default : case KEY_DESTROY: case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif : case KEY_END : case KEY_eq : case KEY_eval : @@ -516,7 +566,6 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, 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; } @@ -538,7 +587,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, CvLVALUE_on(cv); /* newATTRSUB will free the CV and return NULL if we're still compiling after a syntax error */ - if ((cv = newATTRSUB_flags( + if ((cv = newATTRSUB_x( oldsavestack_ix, (OP *)gv, NULL,NULL, coresub_op( @@ -547,7 +596,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, : newSVpvn(name,len), code, opnum ), - 1 + TRUE )) != NULL) { assert(GvCV(gv) == orig_cv); if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS @@ -642,7 +691,6 @@ obtained from the GV with the C macro. GV * Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) { - dVAR; GV** gvp; AV* linear_av; SV** linear_svp; @@ -899,16 +947,16 @@ means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. Calling C is equivalent to calling C with a non-zero C parameter. -These functions grant C<"SUPER"> token as a prefix of the method name. Note +These functions grant C<"SUPER"> token +as a prefix of the method name. Note that if you want to keep the returned glob for a long time, you need to check for it being "AUTOLOAD", since at the later time the call may load a -different subroutine due to $AUTOLOAD changing its value. Use the glob -created via a side effect to do this. +different subroutine due to $AUTOLOAD changing its value. Use the glob +created as a side effect to do this. -These functions have the same side-effects and as C with -C. C should be writable if contains C<':'> or C<' -''>. The warning against passing the GV returned by C to -C apply equally to these functions. +These functions have the same side-effects as C with +C. The warning against passing the GV returned by +C to C applies equally to these functions. =cut */ @@ -945,7 +993,6 @@ Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags) GV * Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags) { - dVAR; const char *nend; const char *nsplit = NULL; GV* gv; @@ -1054,7 +1101,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le GV* stubgv; GV* autogv; - if (CvANON(cv)) + if (CvANON(cv) || CvLEXICAL(cv)) stubgv = gv; else { stubgv = CvGV(cv); @@ -1095,7 +1142,6 @@ Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags) GV* Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) { - dVAR; GV* gv; CV* cv; HV* varstash; @@ -1120,7 +1166,8 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); } - if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8))) + if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, + is_utf8 | (flags & GV_SUPER)))) return NULL; cv = GvCV(gv); @@ -1199,7 +1246,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) * use that, but for lack of anything better we will use the sub's * original package to look up $AUTOLOAD. */ - varstash = GvSTASH(CvGV(cv)); + varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); ENTER; @@ -1242,7 +1289,6 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) STATIC HV* S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags) { - dVAR; HV* stash = gv_stashsv(namesv, 0); PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; @@ -1253,14 +1299,15 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp so save it. For the moment it's always a single char. */ const char type = varname == '[' ? '$' : '%'; +#ifdef DEBUGGING dSP; +#endif ENTER; SAVEFREESV(namesv); if ( flags & 1 ) save_scalar(gv); - PUSHSTACKi(PERLSI_MAGIC); Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); - POPSTACK; + assert(sp == PL_stack_sp); stash = gv_stashsv(namesv, 0); if (!stash) Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available", @@ -1311,11 +1358,22 @@ Flags may be one of: The most important of which are probably GV_ADD and SVf_UTF8. +Note, use of C instead of C where possible is strongly +recommended for performance reasons. + =cut */ -HV* -Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) +/* +gv_stashpvn_internal + +Perform the internal bits of gv_stashsvpvn_cached. You could think of this +as being one half of the logic. Not to be called except from gv_stashsvpvn_cached(). + +*/ + +PERL_STATIC_INLINE HV* +S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags) { char smallbuf[128]; char *tmpbuf; @@ -1323,7 +1381,7 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) GV *tmpgv; U32 tmplen = namelen + 2; - PERL_ARGS_ASSERT_GV_STASHPVN; + PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL; if (tmplen <= sizeof smallbuf) tmpbuf = smallbuf; @@ -1353,22 +1411,81 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) } /* +gv_stashsvpvn_cached + +Returns a pointer to the stash for a specified package, possibly +cached. Implements both C and C. + +Requires one of either namesv or namepv to be non-null. + +See C for details on "flags". + +Note the sv interface is strongly preferred for performance reasons. + +*/ + +#define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \ + assert(namesv || name) + +PERL_STATIC_INLINE HV* +S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags) +{ + HV* stash; + HE* he; + + PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED; + + he = (HE *)hv_common( + PL_stashcache, namesv, name, namelen, + (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0 + ); + + if (he) return INT2PTR(HV*,SvIVX(HeVAL(he))); + else if (flags & GV_CACHE_ONLY) return NULL; + + if (namesv) { + if (SvOK(namesv)) { /* prevent double uninit warning */ + STRLEN len; + name = SvPV_const(namesv, len); + namelen = len; + flags |= SvUTF8(namesv); + } else { + name = ""; namelen = 0; + } + } + stash = gv_stashpvn_internal(name, namelen, flags); + + if (stash && namelen) { + SV* const ref = newSViv(PTR2IV(stash)); + (void)hv_store(PL_stashcache, name, + (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0); + } + + return stash; +} + +HV* +Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) +{ + PERL_ARGS_ASSERT_GV_STASHPVN; + return gv_stashsvpvn_cached(NULL, name, namelen, flags); +} + +/* =for apidoc gv_stashsv Returns a pointer to the stash for a specified package. See C. +Note this interface is strongly preferred over C for performance reasons. + =cut */ HV* Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) { - STRLEN len; - const char * const ptr = SvPV_const(sv,len); - PERL_ARGS_ASSERT_GV_STASHSV; - - return gv_stashpvn(ptr, len, flags | SvUTF8(sv)); + return gv_stashsvpvn_cached(sv, NULL, 0, flags); } @@ -1448,7 +1565,7 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, tmpbuf[(*len)++] = ':'; key = tmpbuf; } - gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -(*len) : *len, add); + gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add); *gv = gvp ? *gvp : NULL; if (*gv && *gv != (const GV *)&PL_sv_undef) { if (SvTYPE(*gv) != SVt_PVGV) @@ -1495,67 +1612,81 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, return TRUE; } -/* This function is called if parse_gv_stash_name() failed to - * find a stash, or if GV_NOTQUAL or an empty name was passed - * to gv_fetchpvn_flags. - * - * It returns FALSE if the default stash can't be found nor created, - * which might happen during global destruction. - */ +/* Checks if an unqualified name is in the main stash */ PERL_STATIC_INLINE bool -S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, - const U32 is_utf8, const I32 add, - const svtype sv_type) +S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8) { - PERL_ARGS_ASSERT_FIND_DEFAULT_STASH; + PERL_ARGS_ASSERT_GV_IS_IN_MAIN; - /* No stash in name, so see how we can default */ - /* If it's an alphanumeric variable */ - if (len && isIDFIRST_lazy_if(name, is_utf8)) { - bool global = FALSE; - + if ( len && isIDFIRST_lazy_if(name, is_utf8) ) { /* Some "normal" variables are always in main::, * like INC or STDOUT. */ switch (len) { case 1: if (*name == '_') - global = TRUE; + return TRUE; break; case 3: if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C') || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V') || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G')) - global = TRUE; + return TRUE; break; case 4: if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' && name[3] == 'V') - global = TRUE; + return TRUE; break; case 5: if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' && name[3] == 'I' && name[4] == 'N') - global = TRUE; + return TRUE; break; case 6: if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D') &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T') ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R'))) - global = TRUE; + return TRUE; break; case 7: if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' && name[3] == 'V' && name[4] == 'O' && name[5] == 'U' && name[6] == 'T') - global = TRUE; + return TRUE; break; } + } + /* *{""}, or a special variable like $@ */ + else + return TRUE; + + return FALSE; +} + + +/* This function is called if parse_gv_stash_name() failed to + * find a stash, or if GV_NOTQUAL or an empty name was passed + * to gv_fetchpvn_flags. + * + * It returns FALSE if the default stash can't be found nor created, + * which might happen during global destruction. + */ +PERL_STATIC_INLINE bool +S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, + const U32 is_utf8, const I32 add, + const svtype sv_type) +{ + PERL_ARGS_ASSERT_FIND_DEFAULT_STASH; + + /* No stash in name, so see how we can default */ - if (global) - *stash = PL_defstash; - else if (IN_PERL_COMPILETIME) { + if ( gv_is_in_main(name, len, is_utf8) ) { + *stash = PL_defstash; + } + else { + if (IN_PERL_COMPILETIME) { *stash = PL_curstash; if (add && (PL_hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV && @@ -1565,7 +1696,7 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, !(len == 1 && sv_type == SVt_PV && (*name == 'a' || *name == 'b')) ) { - GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -len : len,0); + GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -(I32)len : (I32)len,0); if (!gvp || *gvp == (const GV *)&PL_sv_undef || SvTYPE(*gvp) != SVt_PVGV) { @@ -1597,23 +1728,22 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, *stash = CopSTASH(PL_curcop); } } - /* *{""}, or a special variable like $@ */ - else - *stash = PL_defstash; if (!*stash) { if (add && !PL_in_clean_all) { - SV * const err = Perl_mess(aTHX_ + GV *gv; + qerror(Perl_mess(aTHX_ "Global symbol \"%s%"UTF8f - "\" requires explicit package name", + "\" requires explicit package name (did you forget to " + "declare \"my %s%"UTF8f"\"?)", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" - : ""), UTF8fARG(is_utf8, len, name)); - GV *gv; - if (is_utf8) - SvUTF8_on(err); - qerror(err); + : ""), UTF8fARG(is_utf8, len, name), + (sv_type == SVt_PV ? "$" + : sv_type == SVt_PVAV ? "@" + : sv_type == SVt_PVHV ? "%" + : ""), UTF8fARG(is_utf8, len, name))); /* To maintain the output of errors after the strict exception * above, and to keep compat with older releases, rather than * placing the variables in the pad, we place @@ -1636,20 +1766,30 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, return TRUE; } -/* magicalize_gv() gets called by gv_fetchpvn_flags when creating a new GV */ -PERL_STATIC_INLINE GV* -S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, +/* gv_magicalize() is called by gv_fetchpvn_flags when creating + * a new GV. + * Note that it does not insert the GV into the stash prior to + * magicalization, which some variables require need in order + * to work (like $[, %+, %-, %!), so callers must take care of + * that beforehand. + * + * The return value has a specific meaning for gv_fetchpvn_flags: + * If it returns true, and the gv is empty, it indicates that its + * refcount should be decreased. + */ +PERL_STATIC_INLINE bool +S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, bool addmg, const svtype sv_type) { SSize_t paren; - PERL_ARGS_ASSERT_MAGICALIZE_GV; + PERL_ARGS_ASSERT_GV_MAGICALIZE; if (stash != PL_defstash) { /* not the main stash */ - /* We only have to check for three names here: EXPORT, ISA + /* We only have to check for a few names here: a, b, EXPORT, ISA and VERSION. All the others apply only to the main stash or to CORE (which is checked right after this). */ - if (len > 2) { + if (len) { const char * const name2 = name + 1; switch (*name) { case 'E': @@ -1664,10 +1804,15 @@ S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, if (strEQ(name2, "ERSION")) GvMULTI_on(gv); break; + case 'a': + case 'b': + if (len == 1 && sv_type == SVt_PV) + GvMULTI_on(gv); + /* FALLTHROUGH */ default: goto try_core; } - goto add_magical_gv; + return addmg; } try_core: if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { @@ -1815,9 +1960,10 @@ S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, /* This snippet is taken from is_gv_magical */ const char *end = name + len; while (--end > name) { - if (!isDIGIT(*end)) goto add_magical_gv; + if (!isDIGIT(*end)) + return addmg; } - paren = strtoul(name, NULL, 10); + paren = grok_atou(name, NULL); goto storeparen; } } @@ -1887,9 +2033,8 @@ S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, /* magicalization must be done before require_tie_mod is called */ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) { - if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0); - addmg = 0; require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); + addmg = FALSE; } break; @@ -1908,9 +2053,8 @@ S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) { - if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0); - addmg = 0; require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); + addmg = FALSE; } break; @@ -1931,16 +2075,15 @@ S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, case '[': /* $[ */ if ((sv_type == SVt_PV || sv_type == SVt_PVGV) && FEATURE_ARYBASE_IS_ENABLED) { - if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0); require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0); - addmg = 0; + addmg = FALSE; } else goto magicalize; break; case '\023': /* $^S */ ro_magicalize: SvREADONLY_on(GvSVn(gv)); - /* FALL THROUGH */ + /* FALLTHROUGH */ case '0': /* $0 */ case '^': /* $^ */ case '~': /* $~ */ @@ -1994,18 +2137,14 @@ S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, SvREFCNT_dec(sv); } break; + case 'a': + case 'b': + if (sv_type == SVt_PV) + GvMULTI_on(gv); } } - 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_NN(gv), gv = NULL; - } - - return gv; + + return addmg; } /* This function is called when the stash already holds the GV of the magic @@ -2059,7 +2198,6 @@ GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const svtype sv_type) { - dVAR; const char *name = nambeg; GV *gv = NULL; GV**gvp; @@ -2069,7 +2207,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 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); + bool addmg = cBOOL(flags & GV_ADDMG); const char *const name_end = nambeg + full_len; U32 faking_it; @@ -2095,7 +2233,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } /* By this point we should have a stash and a name */ - gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add); + gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add); if (!gvp || *gvp == (const GV *)&PL_sv_undef) { if (addmg) gv = (GV *)newSV(0); else return NULL; @@ -2165,8 +2303,34 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if ( isIDFIRST_lazy_if(name, is_utf8) && !ckWARN(WARN_ONCE) ) GvMULTI_on(gv) ; + /* First, store the gv in the symtab if we're adding magic, + * but only for non-empty GVs + */ +#define GvEMPTY(gv) !(GvAV(gv) || GvHV(gv) || GvIO(gv) \ + || GvCV(gv) || (GvSV(gv) && SvOK(GvSV(gv)))) + + if ( addmg && !GvEMPTY(gv) ) { + (void)hv_store(stash,name,len,(SV *)gv,0); + } + /* set up magic where warranted */ - gv = magicalize_gv(gv, stash, name, len, addmg, sv_type); + if ( gv_magicalize(gv, stash, name, len, addmg, sv_type) ) { + /* See 23496c6 */ + if (GvEMPTY(gv)) { + if ( GvSV(gv) && SvMAGICAL(GvSV(gv)) ) { + /* The GV was and still is "empty", except that now + * it has the magic flags turned on, so we want it + * stored in the symtab. + */ + (void)hv_store(stash,name,len,(SV *)gv,0); + } + else { + /* Most likely the temporary GV created above */ + SvREFCNT_dec_NN(gv); + gv = NULL; + } + } + } if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); return gv; @@ -2203,28 +2367,37 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); } + +/* recursively scan a stash and any nested stashes looking for entries + * that need the "only used once" warning raised + */ + void Perl_gv_check(pTHX_ HV *stash) { - dVAR; I32 i; PERL_ARGS_ASSERT_GV_CHECK; if (!HvARRAY(stash)) return; + + assert(SvOOK(stash)); + for (i = 0; i <= (I32) HvMAX(stash); i++) { const HE *entry; - /* SvIsCOW is unused on HVs, so we can use it to mark stashes we - are currently searching through recursively. */ - SvIsCOW_on(stash); + /* mark stash is being scanned, to avoid recursing */ + HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH; for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { GV *gv; HV *hv; if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) { - if (hv != PL_defstash && hv != stash && !SvIsCOW(hv)) + if (hv != PL_defstash && hv != stash + && !(SvOOK(hv) + && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH)) + ) gv_check(hv); /* nested package */ } else if ( *HeKEY(entry) != '_' @@ -2248,14 +2421,13 @@ Perl_gv_check(pTHX_ HV *stash) HEKfARG(GvNAME_HEK(gv))); } } - SvIsCOW_off(stash); + HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH; } } GV * Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) { - dVAR; PERL_ARGS_ASSERT_NEWGVGEN_FLAGS; assert(!(flags & ~SVf_UTF8)); @@ -2270,7 +2442,6 @@ Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) GP* Perl_gp_ref(pTHX_ GP *gp) { - dVAR; if (!gp) return NULL; gp->gp_refcnt++; @@ -2290,7 +2461,6 @@ Perl_gp_ref(pTHX_ GP *gp) void Perl_gp_free(pTHX_ GV *gv) { - dVAR; GP* gp; int attempts = 100; @@ -2302,9 +2472,11 @@ Perl_gp_free(pTHX_ GV *gv) pTHX__FORMAT pTHX__VALUE); return; } - if (--gp->gp_refcnt > 0) { + if (gp->gp_refcnt > 1) { + borrowed: if (gp->gp_egv == gv) gp->gp_egv = 0; + gp->gp_refcnt--; GvGP_set(gv, NULL); return; } @@ -2337,17 +2509,18 @@ Perl_gp_free(pTHX_ GV *gv) Somehow gp->gp_hv can end up pointing at freed garbage. */ if (hv && SvTYPE(hv) == SVt_PVHV) { const HEK *hvname_hek = HvNAME_HEK(hv); - DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek)); + DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", HEKfARG(hvname_hek))); 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); + (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD); SvREFCNT_dec(hv); } SvREFCNT_dec(io); SvREFCNT_dec(cv); SvREFCNT_dec(form); + /* Possibly reallocated by a destructor */ + gp = GvGP(gv); + if (!gp->gp_file_hek && !gp->gp_sv && !gp->gp_av @@ -2364,6 +2537,8 @@ Perl_gp_free(pTHX_ GV *gv) } } + /* Possibly incremented by a destructor doing glob assignment */ + if (gp->gp_refcnt > 1) goto borrowed; Safefree(gp); GvGP_set(gv, NULL); } @@ -2399,7 +2574,6 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) int Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) { - dVAR; MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); AMT amt; const struct mro_meta* stash_meta = HvMROMETA(stash); @@ -2426,6 +2600,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) { int filled = 0; int i; + bool deref_seen = 0; + /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ @@ -2456,6 +2632,10 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) filled = 1; } + assert(SvOOK(stash)); + /* initially assume the worst */ + HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; + for (i = 1; i < NofAMmeth; i++) { const char * const cooky = PL_AMG_names[i]; /* Human-readable form, for debugging: */ @@ -2473,11 +2653,14 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) numifying instead of C's "+0". */ gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); cv = 0; - if (gv && (cv = GvCV(gv))) { - 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")) { + if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) { + const HEK * const gvhek = + CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(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")) { /* This is a hack to support autoloading..., while knowing *which* methods were declared as overloaded. */ /* GvSV contains the name of the method. */ @@ -2511,7 +2694,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) } } 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))), @@ -2522,7 +2704,26 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) filled = 1; } amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); + + if (gv) { + switch (i) { + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + case nomethod_amg: + deref_seen = 1; + break; + } + } } + if (!deref_seen) + /* none of @{} etc overloaded; we can do $obj->[N] quicker. + * NB - aux var invalid here, HvARRAY() could have been + * reallocated since it was assigned to */ + HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF; + if (filled) { AMT_AMAGIC_on(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, @@ -2542,7 +2743,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) CV* Perl_gv_handler(pTHX_ HV *stash, I32 id) { - dVAR; MAGIC *mg; AMT *amtp; U32 newgen; @@ -2594,7 +2794,6 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) bool Perl_try_amagic_un(pTHX_ int method, int flags) { - dVAR; dSP; SV* tmpsv; SV* const arg = TOPs; @@ -2637,7 +2836,6 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { bool Perl_try_amagic_bin(pTHX_ int method, int flags) { - dVAR; dSP; SV* const left = TOPm1s; SV* const right = TOPs; @@ -2692,11 +2890,19 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { SV * Perl_amagic_deref_call(pTHX_ SV *ref, int method) { SV *tmpsv = NULL; + HV *stash; PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL; - while (SvAMAGIC(ref) && - (tmpsv = amagic_call(ref, &PL_sv_undef, method, + if (!SvAMAGIC(ref)) + return ref; + /* return quickly if none of the deref ops are overloaded */ + stash = SvSTASH(SvRV(ref)); + assert(SvOOK(stash)); + if (HvAUX(stash)->xhv_aux_flags & HvAUXf_NO_DEREF) + return ref; + + while ((tmpsv = amagic_call(ref, &PL_sv_undef, method, AMGf_noright | AMGf_unary))) { if (!SvROK(tmpsv)) Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); @@ -2705,6 +2911,8 @@ Perl_amagic_deref_call(pTHX_ SV *ref, int method) { return tmpsv; } ref = tmpsv; + if (!SvAMAGIC(ref)) + break; } return tmpsv ? tmpsv : ref; } @@ -2869,7 +3077,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case regexp_amg: /* FAIL safe */ return NULL; /* Delegate operation to standard mechanisms. */ - break; + case to_sv_amg: case to_av_amg: case to_hv_amg: @@ -2877,7 +3085,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case to_cv_amg: /* FAIL safe */ return left; /* Delegate operation to standard mechanisms. */ - break; + default: goto not_found; } @@ -2944,7 +3152,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case to_cv_amg: /* FAIL safe */ return left; /* Delegate operation to standard mechanisms. */ - break; } if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ notfound = 1; lr = -1; @@ -3134,7 +3341,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PL_op = (OP *) &myop; if (PERLDB_SUB && PL_curstash != PL_debstash) PL_op->op_private |= OPpENTERSUB_DB; - PUTBACK; Perl_pp_pushmark(aTHX); EXTEND(SP, notfound + 5); @@ -3282,6 +3488,8 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) return; + if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv) + return; if (SvMAGICAL(gv)) { MAGIC *mg; /* only backref magic is allowed */ @@ -3295,16 +3503,14 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) cv = GvCV(gv); if (!cv) { HEK *gvnhek = GvNAME_HEK(gv); - (void)hv_delete(stash, HEK_KEY(gvnhek), - HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD); - } else if (GvMULTI(gv) && cv && + (void)hv_deletehek(stash, gvnhek, G_DISCARD); + } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 && !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && - CvSTASH(cv) == stash && CvGV(cv) == gv && + CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv && CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && (namehek = GvNAME_HEK(gv)) && - (gvp = hv_fetch(stash, HEK_KEY(namehek), - HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) && + (gvp = hv_fetchhek(stash, namehek, 0)) && *gvp == (SV*)gv) { SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); const bool imported = !!GvIMPORTED_CV(gv); @@ -3318,6 +3524,23 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) } } +GV * +Perl_gv_override(pTHX_ const char * const name, const STRLEN len) +{ + GV *gv = gv_fetchpvn(name, len, GV_NOTQUAL, SVt_PVCV); + GV * const *gvp; + PERL_ARGS_ASSERT_GV_OVERRIDE; + if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) return gv; + gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE); + gv = gvp ? *gvp : NULL; + if (gv && !isGV(gv)) { + if (!SvPCS_IMPORTED(gv)) return NULL; + gv_init(gv, PL_globalstash, name, len, 0); + return gv; + } + return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL; +} + #include "XSUB.h" static void