X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/790acddeaa0d2c73524596048b129561225cf100..36f453d19563f9476d4310b8310ce4080209b04f:/gv.c diff --git a/gv.c b/gv.c index 315ec49..e849d0f 100644 --- a/gv.c +++ b/gv.c @@ -20,7 +20,7 @@ */ /* -=head1 GV Functions +=head1 GV Handling 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. @@ -28,6 +28,8 @@ corresponding to $foo, @foo, %foo. GVs are usually found as values in stashes (symbol table hashes) where Perl stores its global variables. +=for apidoc Ayh||GV + =cut */ @@ -83,8 +85,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; @@ -168,7 +170,6 @@ Perl_newGP(pTHX_ GV *const gv) #ifndef USE_ITHREADS GV *filegv; #endif - dVAR; PERL_ARGS_ASSERT_NEWGP; Newxz(gp, 1, GP); @@ -323,6 +324,8 @@ the return value of SvUTF8(sv). It can also take the C flag, which means to pretend that the GV has been seen before (i.e., suppress "Used once" warnings). +=for apidoc Amnh||GV_ADDMULTI + =for apidoc gv_init The old form of C. It does not work with UTF-8 strings, as it @@ -373,6 +376,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)); @@ -385,6 +391,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag case SVt_PVIO: Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", sv_reftype(has_constant, 0)); + NOT_REACHED; /* NOTREACHED */ break; default: NOOP; @@ -410,14 +417,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); @@ -516,9 +528,10 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif : case KEY_END : case KEY_eq : case KEY_eval : case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge : - case KEY_given : case KEY_goto : case KEY_grep : - case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le: - case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my: + case KEY_given : case KEY_goto : case KEY_grep : case KEY_gt : + case KEY_if : case KEY_isa : case KEY_INIT : case KEY_last : + case KEY_le : case KEY_local : case KEY_lt : case KEY_m : + case KEY_map : case KEY_my: case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our: case KEY_package: case KEY_print: case KEY_printf: case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw : @@ -607,11 +620,12 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, PL_compcv = oldcompcv; } if (cv) { - SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; - cv_set_call_checker( - cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv - ); - SvREFCNT_dec(opnumsv); + SV *opnumsv = newSViv( + (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ? + (OP_ENTEREVAL | (1<<16)) + : opnum ? opnum : (((I32)name[2]) << 16)); + cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0); + SvREFCNT_dec_NN(opnumsv); } return gv; @@ -637,7 +651,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); @@ -682,6 +697,8 @@ visible to Perl code. So when calling C, you should not use the GV directly; instead, you should use the method's CV, which can be obtained from the GV with the C macro. +=for apidoc Amnh||GV_SUPER + =cut */ @@ -700,6 +717,7 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, CV* cand_cv = NULL; GV* topgv = NULL; const char *hvname; + STRLEN hvnamelen; I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0; I32 items; U32 topgen_cmp; @@ -715,6 +733,7 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, assert(stash); hvname = HvNAME_get(stash); + hvnamelen = HvNAMELEN_get(stash); if (!hvname) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); @@ -769,8 +788,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; } @@ -784,20 +803,42 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, cstash = gv_stashsv(linear_sv, 0); if (!cstash) { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %" SVf " for @%" HEKf "::ISA", - SVfARG(linear_sv), - HEKfARG(HvNAME_HEK(stash))); + if ( ckWARN(WARN_SYNTAX)) { + if( /* these are loaded from Perl_Gv_AMupdate() one way or another */ + ( len && name[0] == '(' ) /* overload.pm related, in particular "()" */ + || ( memEQs( name, len, "DESTROY") ) + ) { + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Can't locate package %" SVf " for @%" HEKf "::ISA", + SVfARG(linear_sv), + HEKfARG(HvNAME_HEK(stash))); + + } else if( memEQs( name, len, "AUTOLOAD") ) { + /* gobble this warning */ + } else { + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "While trying to resolve method call %.*s->%.*s()" + " can not locate package \"%" SVf "\" yet it is mentioned in @%.*s::ISA" + " (perhaps you forgot to load \"%" SVf "\"?)", + (int) hvnamelen, hvname, + (int) len, name, + SVfARG(linear_sv), + (int) hvnamelen, hvname, + SVfARG(linear_sv)); + } + } continue; } assert(cstash); - gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0); + gvp = (GV**)hv_common( + cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0 + ); 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) )) @@ -1063,7 +1104,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; @@ -1080,9 +1121,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 ); @@ -1209,16 +1251,14 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) return NULL; /* - * Inheriting AUTOLOAD for non-methods works ... for now. + * Inheriting AUTOLOAD for non-methods no longer works */ 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 %" SVf - "::%" UTF8f "() is deprecated. This will be " - "fatal in Perl 5.28", + Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf + "::%" UTF8f "() is no longer allowed", SVfARG(packname), UTF8fARG(is_utf8, len, name)); @@ -1254,7 +1294,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) if (SvUTF8(cv)) sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2); ulen = SvCUR(tmpsv); - SvCUR(tmpsv)++; /* include null in string */ + SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */ sv_catpvn_flags( tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv) ); @@ -1262,8 +1302,8 @@ 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; - SvCUR(cv) = ulen; + SvLEN_set(cv, SvCUR(cv) + 1); + SvCUR_set(cv, ulen); } else { sv_setpvn((SV *)cv, name, len); @@ -1338,13 +1378,19 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, GV **gvp; dSP; + 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 == '[' ? '$' : '%'; @@ -1356,17 +1402,18 @@ 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; call_sv((SV *)*gvp, G_VOID|G_DISCARD); LEAVE; + POPSTACK; } } @@ -1417,6 +1464,13 @@ The most important of which are probably C and C. Note, use of C instead of C where possible is strongly recommended for performance reasons. +=for apidoc Amnh||GV_ADD +=for apidoc Amnh||GV_NOADD_NOINIT +=for apidoc Amnh||GV_NOINIT +=for apidoc Amnh||GV_NOEXPAND +=for apidoc Amnh||GV_ADDMG +=for apidoc Amnh||SVf_UTF8 + =cut */ @@ -1470,11 +1524,11 @@ S_gv_stashpvn_internal(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. +cached. Implements both C> and C>. -Requires one of either namesv or namepv to be non-null. +Requires one of either C or C to be non-null. -See C> for details on "flags". +See C> for details on C. Note the sv interface is strongly preferred for performance reasons. @@ -1483,8 +1537,8 @@ 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* +Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags) { HV* stash; HE* he; @@ -1552,12 +1606,10 @@ Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) PERL_ARGS_ASSERT_GV_STASHSV; return gv_stashsvpvn_cached(sv, NULL, 0, flags); } - - GV * -Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) { +Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) { PERL_ARGS_ASSERT_GV_FETCHPV; - return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); + return gv_fetchpvn_flags(nambeg, strlen(nambeg), flags, sv_type); } GV * @@ -1593,9 +1645,11 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, STRLEN *len, const char *nambeg, STRLEN full_len, const U32 is_utf8, const I32 add) { + char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */ const char *name_cursor; const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; + char smallbuf[64]; /* small buffer to avoid a malloc when possible */ PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME; @@ -1615,7 +1669,7 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, if (!*stash) *stash = PL_defstash; if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */ - return FALSE; + goto notok; *len = name_cursor - *name; if (name_cursor > nambeg) { /* Skip for initial :: or ' */ @@ -1625,9 +1679,17 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, key = *name; *len += 2; } - else { + else { /* using ' for package separator */ + /* use our pre-allocated buffer when possible to save a malloc */ char *tmpbuf; - Newx(tmpbuf, *len+2, char); + if ( *len+2 <= sizeof smallbuf) + tmpbuf = smallbuf; + else { + /* only malloc once if needed */ + if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */ + Newx(tmpfullbuf, full_len+2, char); + tmpbuf = tmpfullbuf; + } Copy(*name, tmpbuf, *len, char); tmpbuf[(*len)++] = ':'; tmpbuf[(*len)++] = ':'; @@ -1635,22 +1697,20 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, } 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) - gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8); - else - GvMULTI_on(*gv); + if (!*gv || *gv == (const GV *)&PL_sv_undef) { + goto notok; } - if (key != *name) - Safefree(key); - if (!*gv || *gv == (const GV *)&PL_sv_undef) - return FALSE; + /* here we know that *gv && *gv != &PL_sv_undef */ + if (SvTYPE(*gv) != SVt_PVGV) + gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8); + else + GvMULTI_on(*gv); if (!(*stash = GvHV(*gv))) { *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( @@ -1679,14 +1739,20 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); } } - return TRUE; + goto ok; } } } *len = name_cursor - *name; + ok: + Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */ return TRUE; + notok: + Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */ + return FALSE; } + /* Checks if an unqualified name is in the main stash */ PERL_STATIC_INLINE bool S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8) @@ -1851,7 +1917,7 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, * 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 + * to work (like %+, %-, %!), so callers must take care of * that. * * It returns true if the gv did turn out to be magical one; i.e., @@ -1908,7 +1974,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); } } @@ -1994,18 +2060,16 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, /* @{^CAPTURE} %{^CAPTURE} */ if (memEQs(name, len, "\003APTURE")) { AV* const av = GvAVn(gv); - UV uv= *name; + const Size_t n = *name; - sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0); + sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0); SvREADONLY_on(av); - if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) - require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0); + require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0); } else /* %{^CAPTURE_ALL} */ if (memEQs(name, len, "\003APTURE_ALL")) { - if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) - require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0); + require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0); } break; case '\005': /* $^ENCODING */ @@ -2040,6 +2104,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; @@ -2162,33 +2230,24 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, } { /* @- @+ */ AV* const av = GvAVn(gv); - const UV uv = (UV)*name; + const Size_t n = *name; - sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0); + sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0); SvREADONLY_on(av); } break; case '*': /* $* */ case '#': /* $# */ - if (sv_type == SVt_PV) - /* diag_listed_as: $* is no longer supported. Its use will be fatal in Perl 5.30 */ - Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "$%c is no longer supported. Its use " - "will be fatal in Perl 5.30", *name); - break; + if (sv_type == SVt_PV) + /* diag_listed_as: $* is no longer supported as of Perl 5.30 */ + Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name); + break; case '\010': /* $^H */ { HV *const hv = GvHVn(gv); hv_magic(hv, NULL, PERL_MAGIC_hints); } goto magicalize; - case '[': /* $[ */ - if ((sv_type == SVt_PV || sv_type == SVt_PVGV) - && FEATURE_ARYBASE_IS_ENABLED) { - require_tie_mod_s(gv,'[',"arybase",0); - } - else goto magicalize; - break; case '\023': /* $^S */ ro_magicalize: SvREADONLY_on(GvSVn(gv)); @@ -2207,6 +2266,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, case '/': /* $/ */ case '|': /* $| */ case '$': /* $$ */ + case '[': /* $[ */ case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ @@ -2284,18 +2344,12 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0); } else if (sv_type == SVt_PV) { if (*name == '*' || *name == '#') { - /* diag_listed_as: $# is no longer supported. Its use will be fatal in Perl 5.30 */ - Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, - WARN_SYNTAX), - "$%c is no longer supported. Its use " - "will be fatal in Perl 5.30", *name); + /* diag_listed_as: $* is no longer supported as of Perl 5.30 */ + Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name); } } if (sv_type==SVt_PV || sv_type==SVt_PVGV) { switch (*name) { - case '[': - require_tie_mod_s(gv,'[',"arybase",0); - break; #ifdef PERL_SAWAMPERSAND case '`': PL_sawampersand |= SAWAMPERSAND_LEFT; @@ -2314,6 +2368,75 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) } } +/* +=for apidoc gv_fetchpv +=for apidoc_item |GV *|gv_fetchpvn|const char * nambeg|STRLEN full_len|I32 flags|const svtype sv_type +=for apidoc_item ||gv_fetchpvn_flags +=for apidoc_item |GV *|gv_fetchpvs|"name"|I32 flags|const svtype sv_type +=for apidoc_item ||gv_fetchsv +=for apidoc_item |GV *|gv_fetchsv_nomg|SV *name|I32 flags|const svtype sv_type + +These all return the GV of type C whose name is given by the inputs, +or NULL if no GV of that name and type could be found. See L. + +The only differences are how the input name is specified, and if 'get' magic is +normally used in getting that name. + +Don't be fooled by the fact that only one form has C in its name. They +all have a C parameter in fact, and all the flag bits have the same +meanings for all + +If any of the flags C, C, C, C, or +C is set, a GV is created if none already exists for the input name +and type. However, C will only do the creation for magical GV's. +For all of these flags except C, C> is called after +the addition. C is used when the caller expects that adding won't +be necessary because the symbol should already exist; but if not, add it +anyway, with a warning that it was unexpectedly absent. The C +flag means to pretend that the GV has been seen before (I, suppress "Used +once" warnings). + +The flag C causes C> not be to called if the +GV existed but isn't PVGV. + +If the C bit is set, the name is treated as being encoded in UTF-8; +otherwise the name won't be considered to be UTF-8 in the C-named forms, +and the UTF-8ness of the underlying SVs will be used in the C forms. + +If the flag C is set, the caller warrants that the input name is a +plain symbol name, not qualified with a package, otherwise the name is checked +for being a qualified one. + +In C, C is a C string, NUL-terminated with no intermediate +NULs. + +In C, C is a literal C string, hence is enclosed in +double quotes. + +C and C are identical. In these, is +a Perl string whose byte length is given by C, and may contain +embedded NULs. + +In C and C, the name is extracted from the PV of +the input C SV. The only difference between these two forms is that +'get' magic is normally done on C in C, and always skipped +with C. Including C in the C parameter +to C makes it behave identically to C. + +=for apidoc Amnh||GV_ADD +=for apidoc Amnh||GV_ADDMG +=for apidoc Amnh||GV_ADDMULTI +=for apidoc Amnh||GV_ADDWARN +=for apidoc Amnh||GV_NOADD_NOINIT +=for apidoc Amnh||GV_NOINIT +=for apidoc Amnh||GV_NOTQUAL +=for apidoc Amnh||GV_NO_SVGMAGIC +=for apidoc Amnh||SVf_UTF8 + +=cut +*/ + GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const svtype sv_type) @@ -2355,7 +2478,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 ? -(I32)len : (I32)len,add); if (!gvp || *gvp == (const GV *)&PL_sv_undef) { - if (addmg) gv = (GV *)newSV(0); + if (addmg) gv = (GV *)newSV(0); /* tentatively */ else return NULL; } else gv = *gvp, addmg = 0; @@ -2384,8 +2507,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); } @@ -2461,7 +2584,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,"::"); } @@ -2787,13 +2910,12 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); cv = 0; if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) { - const HEK * const gvhek = - CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv)); + 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. */ @@ -2920,8 +3042,6 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) /* Implement tryAMAGICun_MG macro. Do get magic, then see if the stack arg is overloaded and if so call it. Flags: - AMGf_set return the arg using SETs rather than assigning to - the targ AMGf_numeric apply sv_2num to the stack arg. */ @@ -2937,18 +3057,21 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { AMGf_noright | AMGf_unary | (flags & AMGf_numarg)))) { - if (flags & AMGf_set) { - SETs(tmpsv); - } - else { - dTARGET; - if (SvPADMY(TARG)) { - sv_setsv(TARG, tmpsv); - SETTARG; - } - else - SETs(tmpsv); - } + /* where the op is of the form: + * $lex = $x op $y (where the assign is optimised away) + * then assign the returned value to targ and return that; + * otherwise return the value directly + */ + if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX) + && (PL_op->op_private & OPpTARGET_MY)) + { + dTARGET; + sv_setsv(TARG, tmpsv); + SETTARG; + } + else + SETs(tmpsv); + PUTBACK; return TRUE; } @@ -2963,8 +3086,6 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { Do get magic, then see if the two stack args are overloaded and if so call it. Flags: - AMGf_set return the arg using SETs rather than assigning to - the targ AMGf_assign op may be called as mutator (eg +=) AMGf_numeric apply sv_2num to the stack arg. */ @@ -2980,28 +3101,38 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { SvGETMAGIC(right); if (SvAMAGIC(left) || SvAMAGIC(right)) { - SV * const tmpsv = amagic_call(left, right, method, - ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0) + SV * tmpsv; + /* STACKED implies mutator variant, e.g. $x += 1 */ + bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED); + + tmpsv = amagic_call(left, right, method, + (mutator ? AMGf_assign: 0) | (flags & AMGf_numarg)); if (tmpsv) { - if (flags & AMGf_set) { - (void)POPs; - SETs(tmpsv); - } - else { - dATARGET; - (void)POPs; - if (opASSIGN || SvPADMY(TARG)) { - sv_setsv(TARG, tmpsv); - SETTARG; - } - else - SETs(tmpsv); - } + (void)POPs; + /* where the op is one of the two forms: + * $x op= $y + * $lex = $x op $y (where the assign is optimised away) + * then assign the returned value to targ and return that; + * otherwise return the value directly + */ + if ( mutator + || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX) + && (PL_op->op_private & OPpTARGET_MY))) + { + dTARG; + TARG = mutator ? *SP : PAD_SV(PL_op->op_targ); + sv_setsv(TARG, tmpsv); + SETTARG; + } + else + SETs(tmpsv); + PUTBACK; return TRUE; } } + if(left==right && SvGMAGICAL(left)) { SV * const left = sv_newmortal(); *(sp-1) = left; @@ -3081,7 +3212,6 @@ Perl_amagic_is_enabled(pTHX_ int method) SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { - dVAR; MAGIC *mg; CV *cv=NULL; CV **cvp=NULL, **ocvp=NULL; @@ -3179,11 +3309,11 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case abs_amg: if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { - SV* const nullsv=sv_2mortal(newSViv(0)); + SV* const nullsv=&PL_sv_zero; if (off1==lt_amg) { SV* const lessp = amagic_call(left,nullsv, lt_amg,AMGf_noright); - logic = SvTRUE(lessp); + logic = SvTRUE_NN(lessp); } else { SV* const lessp = amagic_call(left,nullsv, ncmp_amg,AMGf_noright); @@ -3203,7 +3333,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case neg_amg: if ((cv = cvp[off=subtr_amg])) { right = left; - left = sv_2mortal(newSViv(0)); + left = &PL_sv_zero; lr = 1; } break; @@ -3451,7 +3581,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); @@ -3512,7 +3647,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); @@ -3521,7 +3656,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) break; } /* FALLTHROUGH */ - } default: res = POPs; break; @@ -3556,7 +3690,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case dec_amg: SvSetSV(left,res); return left; case not_amg: - ans=!SvTRUE(res); break; + ans=!SvTRUE_NN(res); break; default: ans=0; break; } @@ -3575,7 +3709,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) void Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) { - dVAR; U32 hash; PERL_ARGS_ASSERT_GV_NAME_SET;