X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7d3b1f61da54c4cf5210c73ac1c807d0eea47175..60666776a83addda0a7fcb957c6b5007b8e030f3:/gv.c?ds=sidebyside diff --git a/gv.c b/gv.c index 156f2fb..65c2971 100644 --- a/gv.c +++ b/gv.c @@ -1,7 +1,7 @@ /* gv.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -10,11 +10,13 @@ /* * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure - * of your inquisitiveness, I shall spend all the rest of my days answering + * of your inquisitiveness, I shall spend all the rest of my days in answering * you. What more do you want to know?' * 'The names of all the stars, and of all living things, and the whole * 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"] */ /* @@ -33,77 +35,57 @@ Perl stores its global variables. #include "EXTERN.h" #define PERL_IN_GV_C #include "perl.h" +#include "overload.c" static const char S_autoload[] = "AUTOLOAD"; static const STRLEN S_autolen = sizeof(S_autoload)-1; - -#ifdef PERL_DONT_CREATE_GVSV -GV * -Perl_gv_SVadd(pTHX_ GV *gv) -{ - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) - Perl_croak(aTHX_ "Bad symbol for scalar"); - if (!GvSV(gv)) - GvSV(gv) = newSV(0); - return gv; -} -#endif - GV * -Perl_gv_AVadd(pTHX_ register GV *gv) +Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) { - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) - Perl_croak(aTHX_ "Bad symbol for array"); - if (!GvAV(gv)) - GvAV(gv) = newAV(); - return gv; -} - -GV * -Perl_gv_HVadd(pTHX_ register GV *gv) -{ - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) - Perl_croak(aTHX_ "Bad symbol for hash"); - if (!GvHV(gv)) - GvHV(gv) = newHV(); - return gv; -} - -GV * -Perl_gv_IOadd(pTHX_ register GV *gv) -{ - dVAR; - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) { - - /* - * if it walks like a dirhandle, then let's assume that - * this is a dirhandle. - */ - const char * const fh = - 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 ? - "dirhandle" : "filehandle"; - Perl_croak(aTHX_ "Bad symbol for %s", fh); + SV **where; + + if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) { + const char *what; + if (type == SVt_PVIO) { + /* + * 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 ? + "dirhandle" : "filehandle"; + /* diag_listed_as: Bad symbol for filehandle */ + } else if (type == SVt_PVHV) { + what = "hash"; + } else { + what = type == SVt_PVAV ? "array" : "scalar"; + } + Perl_croak(aTHX_ "Bad symbol for %s", what); } - if (!GvIOp(gv)) { -#ifdef GV_UNIQUE_CHECK - if (GvUNIQUE(gv)) { - Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)"); - } -#endif - GvIOp(gv) = newIO(); + if (type == SVt_PVHV) { + where = (SV **)&GvHV(gv); + } else if (type == SVt_PVAV) { + where = (SV **)&GvAV(gv); + } else if (type == SVt_PVIO) { + where = (SV **)&GvIOp(gv); + } else { + where = &GvSV(gv); } + + if (!*where) + *where = newSV_type(type); return gv; } GV * Perl_gv_fetchfile(pTHX_ const char *name) { + PERL_ARGS_ASSERT_GV_FETCHFILE; return gv_fetchfile_flags(name, strlen(name), 0); } @@ -117,6 +99,7 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, const STRLEN tmplen = namelen + 2; GV *gv; + PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS; PERL_UNUSED_ARG(flags); if (!PL_defstash) @@ -138,9 +121,9 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, #else sv_setpvn(GvSV(gv), name, namelen); #endif - if (PERLDB_LINE) - hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); } + if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv)) + hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); if (tmpbuf != smallbuf) Safefree(tmpbuf); return gv; @@ -160,6 +143,8 @@ NULL. SV * Perl_gv_const_sv(pTHX_ GV *gv) { + PERL_ARGS_ASSERT_GV_CONST_SV; + if (SvTYPE(gv) == SVt_PVGV) return cv_const_sv(GvCVu(gv)); return SvROK(gv) ? SvRV(gv) : NULL; @@ -169,10 +154,26 @@ GP * Perl_newGP(pTHX_ GV *const gv) { GP *gp; + U32 hash; +#ifdef USE_ITHREADS const char *const file = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : ""; - STRLEN len = strlen(file); - U32 hash; + const STRLEN len = strlen(file); +#else + SV *const temp_sv = CopFILESV(PL_curcop); + const char *file; + STRLEN len; + + PERL_ARGS_ASSERT_NEWGP; + + if (temp_sv) { + file = SvPVX(temp_sv); + len = SvCUR(temp_sv); + } else { + file = ""; + len = 0; + } +#endif PERL_HASH(hash, file, len); @@ -192,16 +193,55 @@ Perl_newGP(pTHX_ GV *const gv) return gp; } +/* Assign CvGV(cv) = gv, handling weak references. + * See also S_anonymise_cv_maybe */ + +void +Perl_cvgv_set(pTHX_ CV* cv, GV* gv) +{ + GV * const oldgv = CvGV(cv); + PERL_ARGS_ASSERT_CVGV_SET; + + if (oldgv == gv) + return; + + if (oldgv) { + if (CvCVGV_RC(cv)) { + SvREFCNT_dec(oldgv); + CvCVGV_RC_off(cv); + } + else { + sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); + } + } + + SvANY(cv)->xcv_gv = gv; + assert(!CvCVGV_RC(cv)); + + if (!gv) + return; + + if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv)) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv)); + else { + CvCVGV_RC_on(cv); + SvREFCNT_inc_simple_void_NN(gv); + } +} + + void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { dVAR; const U32 old_type = SvTYPE(gv); const bool doproto = old_type > SVt_NULL; - const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL; + char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; + const STRLEN protolen = proto ? SvCUR(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; assert (!(proto && has_constant)); if (has_constant) { @@ -224,7 +264,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) if (old_type < SVt_PVGV) { if (old_type >= SVt_PV) SvCUR_set(gv, 0); - sv_upgrade((SV*)gv, SVt_PVGV); + sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); } if (SvLEN(gv)) { if (proto) { @@ -240,15 +280,25 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) GvGP(gv) = Perl_newGP(aTHX_ gv); GvSTASH(gv) = stash; if (stash) - Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv); + 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); if (doproto) { /* Replicate part of newSUB here. */ + CV *cv; ENTER; if (has_constant) { + char *name0 = NULL; + if (name[len]) + /* newCONSTSUB doesn't take a len arg, so make sure we + * give it a \0-terminated string */ + name0 = savepvn(name,len); + /* newCONSTSUB takes ownership of the reference from us. */ - GvCV(gv) = newCONSTSUB(stash, name, has_constant); + cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant); + assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */ + if (name0) + Safefree(name0); /* If this reference was a copy of another, then the subroutine must have been "imported", by a Perl space assignment to a GV from a reference to CV. */ @@ -256,24 +306,29 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) GvIMPORTED_CV_on(gv); } else { (void) start_subparse(0,0); /* Create empty CV in compcv. */ - GvCV(gv) = PL_compcv; + cv = PL_compcv; + GvCV(gv) = cv; } LEAVE; mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */ - CvGV(GvCV(gv)) = gv; - CvFILE_set_from_cop(GvCV(gv), PL_curcop); - CvSTASH(GvCV(gv)) = PL_curstash; + CvGV_set(cv, gv); + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH(cv) = PL_curstash; + if (PL_curstash) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv)); if (proto) { - sv_setpv((SV*)GvCV(gv), proto); - Safefree(proto); + sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, + SV_HAS_TRAILING_NUL); } } } STATIC void -S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) +S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type) { + PERL_ARGS_ASSERT_GV_INIT_SV; + switch (sv_type) { case SVt_PVIO: (void)GvIOn(gv); @@ -342,6 +397,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) STRLEN packlen; U32 topgen_cmp; + PERL_ARGS_ASSERT_GV_FETCHMETH; + /* UNIVERSAL methods should be callable without a stash */ if (!stash) { create = 0; /* probably appropriate */ @@ -406,9 +463,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) cstash = gv_stashsv(linear_sv, 0); if (!cstash) { - if (ckWARN(WARN_SYNTAX)) - Perl_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 @%s::ISA", + SVfARG(linear_sv), hvname); continue; } @@ -476,13 +532,15 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le { GV *gv = gv_fetchmeth(stash, name, len, level); + PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD; + if (!gv) { CV *cv; GV **gvp; if (!stash) return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ - if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) + if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) return NULL; if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) return NULL; @@ -536,6 +594,8 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) GV* gv; HV* stash; + PERL_ARGS_ASSERT_GV_GET_SUPER_PKG; + stash = gv_stashpvn(name, namelen, 0); if(stash) return stash; @@ -548,8 +608,13 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) gv_init(gv, stash, "ISA", 3, TRUE); superisa = GvAVn(gv); GvMULTI_on(gv); - sv_magic((SV*)superisa, (SV*)gv, PERL_MAGIC_isa, NULL, 0); + sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); +#ifdef USE_ITHREADS av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0)); +#else + av_push(superisa, newSVhek(CopSTASH(PL_curcop) + ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL)); +#endif return stash; } @@ -557,27 +622,48 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { + PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD; + + return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0); +} + +/* 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) +{ dVAR; register const char *nend; const char *nsplit = NULL; GV* gv; HV* ostash = stash; + const char * const origname = name; + SV *const error_report = MUTABLE_SV(stash); + const U32 autoload = flags & GV_AUTOLOAD; + const U32 do_croak = flags & GV_CROAK; + + PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS; - if (stash && SvTYPE(stash) < SVt_PVHV) + if (SvTYPE(stash) < SVt_PVHV) stash = NULL; + else { + /* The only way stash can become NULL later on is if nsplit is set, + which in turn means that there is no need for a SVt_PVHV case + the error reporting code. */ + } for (nend = name; *nend; nend++) { - if (*nend == '\'') + if (*nend == '\'') { nsplit = nend; - else if (*nend == ':' && *(nend + 1) == ':') - nsplit = ++nend; + name = nend + 1; + } + else if (*nend == ':' && *(nend + 1) == ':') { + nsplit = nend++; + name = nend + 1; + } } if (nsplit) { - const char * const origname = name; - name = nsplit + 1; - if (*nsplit == ':') - --nsplit; - if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { + 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))); @@ -603,9 +689,34 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) - gv = (GV*)&PL_sv_yes; + gv = MUTABLE_GV(&PL_sv_yes); else if (autoload) gv = gv_autoload4(ostash, name, nend - name, TRUE); + if (!gv && do_croak) { + /* Right now this is exclusively for the benefit of S_method_common + in pp_hot.c */ + if (stash) { + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%.*s\"", + name, (int)HvNAMELEN_get(stash), HvNAME_get(stash)); + } + else { + STRLEN packlen; + const char *packname; + + if (nsplit) { + packlen = nsplit - origname; + packname = origname; + } else { + packname = SvPV_const(error_report, packlen); + } + + 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); + } + } } else if (autoload) { CV* const cv = GvCV(gv); @@ -642,11 +753,13 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) const char *packname = ""; STRLEN packname_len = 0; - if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) + PERL_ARGS_ASSERT_GV_AUTOLOAD4; + + if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) return NULL; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { - packname = SvPV_const((SV*)stash, packname_len); + packname = SvPV_const(MUTABLE_SV(stash), packname_len); stash = NULL; } else { @@ -665,11 +778,10 @@ 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) - && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) ) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", - packname, (int)len, name); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", + packname, (int)len, name); if (CvISXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here @@ -678,6 +790,8 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) * pass along the same data via some unused fields in the CV */ CvSTASH(cv) = stash; + if (stash) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(cv)); SvPV_set(cv, (char *)name); /* cast to lose constness warning */ SvCUR_set(cv, len); return gv; @@ -726,6 +840,8 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp dVAR; HV* stash = gv_stashsv(namesv, 0); + PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; + if (!stash || !(gv_fetchmethod(stash, methpv))) { SV *module = newSVsv(namesv); char varname = *varpv; /* varpv might be clobbered by load_module, @@ -764,6 +880,7 @@ determine the length of C, then calls C. HV* Perl_gv_stashpv(pTHX_ const char *name, I32 create) { + PERL_ARGS_ASSERT_GV_STASHPV; return gv_stashpvn(name, strlen(name), create); } @@ -788,15 +905,18 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) char *tmpbuf; HV *stash; GV *tmpgv; + U32 tmplen = namelen + 2; + + PERL_ARGS_ASSERT_GV_STASHPVN; - if (namelen + 2 <= sizeof smallbuf) + if (tmplen <= sizeof smallbuf) tmpbuf = smallbuf; else - Newx(tmpbuf, namelen + 2, char); - Copy(name,tmpbuf,namelen,char); - tmpbuf[namelen++] = ':'; - tmpbuf[namelen++] = ':'; - tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV); + Newx(tmpbuf, tmplen, char); + Copy(name, tmpbuf, namelen, char); + tmpbuf[namelen] = ':'; + tmpbuf[namelen+1] = ':'; + tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV); if (tmpbuf != smallbuf) Safefree(tmpbuf); if (!tmpgv) @@ -822,25 +942,70 @@ 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); } GV * -Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { +Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) { + PERL_ARGS_ASSERT_GV_FETCHPV; return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); } GV * -Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) { +Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { STRLEN len; const char * const nambeg = SvPV_const(name, len); + PERL_ARGS_ASSERT_GV_FETCHSV; return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); } +STATIC void +S_gv_magicalize_isa(pTHX_ GV *gv, const char *nambeg, I32 add) +{ + AV* av; + + PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA; + + av = GvAVn(gv); + GvMULTI_on(gv); + sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, + NULL, 0); + /* NOTE: No support for tied ISA */ + if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") + && AvFILLp(av) == -1) + { + av_push(av, newSVpvs("NDBM_File")); + gv_stashpvs("NDBM_File", GV_ADD); + av_push(av, newSVpvs("DB_File")); + gv_stashpvs("DB_File", GV_ADD); + av_push(av, newSVpvs("GDBM_File")); + gv_stashpvs("GDBM_File", GV_ADD); + av_push(av, newSVpvs("SDBM_File")); + gv_stashpvs("SDBM_File", GV_ADD); + av_push(av, newSVpvs("ODBM_File")); + gv_stashpvs("ODBM_File", GV_ADD); + } +} + +STATIC void +S_gv_magicalize_overload(pTHX_ GV *gv) +{ + HV* hv; + + PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD; + + hv = GvHVn(gv); + GvMULTI_on(gv); + hv_magic(hv, NULL, PERL_MAGIC_overload); +} + GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, - I32 sv_type) + const svtype sv_type) { dVAR; register const char *name = nambeg; @@ -854,6 +1019,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const I32 add = flags & ~GV_NOADD_MASK; const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; + U32 faking_it; + + PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; if (flags & GV_NOTQUAL) { /* Caller promised that there is no stash, so we can skip the check. */ @@ -890,7 +1058,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, tmpbuf[len++] = ':'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); gv = gvp ? *gvp : NULL; - if (gv && gv != (GV*)&PL_sv_undef) { + if (gv && gv != (const GV *)&PL_sv_undef) { if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); else @@ -898,7 +1066,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } if (tmpbuf != smallbuf) Safefree(tmpbuf); - if (!gv || gv == (GV*)&PL_sv_undef) + if (!gv || gv == (const GV *)&PL_sv_undef) return NULL; if (!(stash = GvHV(gv))) @@ -913,7 +1081,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, name_cursor++; name = name_cursor; if (name == name_end) - return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE); + return gv + ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); } } len = name_cursor - name; @@ -974,7 +1143,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, { gvp = (GV**)hv_fetch(stash,name,len,0); if (!gvp || - *gvp == (GV*)&PL_sv_undef || + *gvp == (const GV *)&PL_sv_undef || SvTYPE(*gvp) != SVt_PVGV) { stash = NULL; @@ -983,12 +1152,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)) ) { - Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", + /* diag_listed_as: Variable "%s" is not imported%s */ + Perl_ck_warner_d( + aTHX_ packWARN(WARN_MISC), + "Variable \"%c%s\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', name); if (GvCVu(*gvp)) - Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); + Perl_ck_warner_d( + aTHX_ packWARN(WARN_MISC), + "\t(Did you mean &%s instead?)\n", name + ); stash = NULL; } } @@ -1014,7 +1189,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (USE_UTF8_IN_NAMES) SvUTF8_on(err); qerror(err); - gv = gv_fetchpvn_flags("::", 8, GV_ADDMULTI, SVt_PVHV); + gv = gv_fetchpvs("::", GV_ADDMULTI, SVt_PVHV); if(!gv) { /* symbol table under destruction */ return NULL; @@ -1029,7 +1204,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, return NULL; gvp = (GV**)hv_fetch(stash,name,len,add); - if (!gvp || *gvp == (GV*)&PL_sv_undef) + if (!gvp || *gvp == (const GV *)&PL_sv_undef) return NULL; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) { @@ -1050,19 +1225,51 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, return gv; } - /* Adding a new symbol */ + /* Adding a new symbol. + Unless of course there was already something non-GV here, in which case + we want to behave as if there was always a GV here, containing some sort + of subroutine. + Otherwise we run the risk of creating things like GvIO, which can cause + subtle bugs. eg the one that tripped up SQL::Translator */ - if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); + 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, sv_type); + gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type); if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) GvMULTI_on(gv) ; /* set up magic where warranted */ - if (len > 1) { + if (stash != PL_defstash) { /* not the main stash */ + /* We only have to check for four names here: EXPORT, ISA, OVERLOAD + and VERSION. All the others apply only to the main stash. */ + if (len > 1) { + const char * const name2 = name + 1; + switch (*name) { + case 'E': + if (strnEQ(name2, "XPORT", 5)) + GvMULTI_on(gv); + break; + case 'I': + if (strEQ(name2, "SA")) + gv_magicalize_isa(gv, nambeg, add); + break; + case 'O': + if (strEQ(name2, "VERLOAD")) + gv_magicalize_overload(gv); + break; + case 'V': + if (strEQ(name2, "ERSION")) + GvMULTI_on(gv); + break; + } + } + } + else if (len > 1) { #ifndef EBCDIC if (*name > 'V' ) { NOOP; @@ -1089,42 +1296,34 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case 'I': if (strEQ(name2, "SA")) { - AV* const av = GvAVn(gv); - GvMULTI_on(gv); - sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0); - /* NOTE: No support for tied ISA */ - if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") - && AvFILLp(av) == -1) - { - const char *pname; - av_push(av, newSVpvn(pname = "NDBM_File",9)); - gv_stashpvn(pname, 9, GV_ADD); - av_push(av, newSVpvn(pname = "DB_File",7)); - gv_stashpvn(pname, 7, GV_ADD); - av_push(av, newSVpvn(pname = "GDBM_File",9)); - gv_stashpvn(pname, 9, GV_ADD); - av_push(av, newSVpvn(pname = "SDBM_File",9)); - gv_stashpvn(pname, 9, GV_ADD); - av_push(av, newSVpvn(pname = "ODBM_File",9)); - gv_stashpvn(pname, 9, GV_ADD); - } + gv_magicalize_isa(gv, nambeg, add); } break; case 'O': if (strEQ(name2, "VERLOAD")) { - HV* const hv = GvHVn(gv); - GvMULTI_on(gv); - hv_magic(hv, NULL, PERL_MAGIC_overload); + gv_magicalize_overload(gv); } break; case 'S': if (strEQ(name2, "IG")) { HV *hv; I32 i; - if (!PL_psig_ptr) { - Newxz(PL_psig_ptr, SIG_SIZE, SV*); - Newxz(PL_psig_name, SIG_SIZE, SV*); + if (!PL_psig_name) { + Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); Newxz(PL_psig_pend, SIG_SIZE, int); + PL_psig_ptr = PL_psig_name + SIG_SIZE; + } else { + /* I think that the only way to get here is to re-use an + embedded perl interpreter, where the previous + use didn't clean up fully because + PL_perl_destruct_level was 0. I'm not sure that we + "support" that, in that I suspect in that scenario + there are sufficient other garbage values left in the + interpreter structure that something else will crash + before we get here. I suspect that this is one of + those "doctor, it hurts when I do this" bugs. */ + Zero(PL_psig_name, 2 * SIG_SIZE, SV*); + Zero(PL_psig_pend, SIG_SIZE, int); } GvMULTI_on(gv); hv = GvHVn(gv); @@ -1133,9 +1332,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); if (init) sv_setsv(*init, &PL_sv_undef); - PL_psig_ptr[i] = 0; - PL_psig_name[i] = 0; - PL_psig_pend[i] = 0; } } break; @@ -1202,9 +1398,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* Names of length 1. (Or 0. But name is NUL terminated, so that will be case '\0' in this switch statement (ie a default case) */ switch (*name) { - case '&': - case '`': - case '\'': + case '&': /* $& */ + case '`': /* $` */ + case '\'': /* $' */ if ( sv_type == SVt_PVAV || sv_type == SVt_PVHV || @@ -1215,36 +1411,36 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, PL_sawampersand = TRUE; goto magicalize; - case ':': + case ':': /* $: */ sv_setpv(GvSVn(gv),PL_chopset); goto magicalize; - case '?': + case '?': /* $? */ #ifdef COMPLEX_STATUS SvUPGRADE(GvSVn(gv), SVt_PVLV); #endif goto magicalize; - case '!': + case '!': /* $! */ GvMULTI_on(gv); /* If %! has been used, automatically load Errno.pm. */ - sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); /* magicalization must be done before require_tie_mod is called */ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); break; - case '-': - case '+': + case '-': /* $- */ + case '+': /* $+ */ GvMULTI_on(gv); /* no used once warnings here */ { AV* const av = GvAVn(gv); - SV* const avc = (*name == '+') ? (SV*)av : NULL; + SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL; - sv_magic((SV*)av, avc, PERL_MAGIC_regdata, NULL, 0); - sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); + sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); if (avc) SvREADONLY_on(GvSVn(gv)); SvREADONLY_on(av); @@ -1254,13 +1450,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; } - case '*': - case '#': - if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "$%c is no longer supported", *name); + case '*': /* $* */ + case '#': /* $# */ + if (sv_type == SVt_PV) + Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "$%c is no longer supported", *name); break; - case '|': + case '|': /* $| */ sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); goto magicalize; @@ -1274,28 +1470,28 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, ro_magicalize: SvREADONLY_on(GvSVn(gv)); /* FALL THROUGH */ - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - case '[': - case '^': - case '~': - case '=': - case '%': - case '.': - case '(': - case ')': - case '<': - case '>': - case ',': - case '\\': - case '/': + case '0': /* $0 */ + case '1': /* $1 */ + case '2': /* $2 */ + case '3': /* $3 */ + case '4': /* $4 */ + case '5': /* $5 */ + case '6': /* $6 */ + case '7': /* $7 */ + case '8': /* $8 */ + case '9': /* $9 */ + case '[': /* $[ */ + case '^': /* $^ */ + case '~': /* $~ */ + case '=': /* $= */ + case '%': /* $% */ + case '.': /* $. */ + case '(': /* $( */ + case ')': /* $) */ + case '<': /* $< */ + case '>': /* $> */ + case '\\': /* $\ */ + case '/': /* $/ */ case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ @@ -1308,17 +1504,17 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '\024': /* $^T */ case '\027': /* $^W */ magicalize: - sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); break; case '\014': /* $^L */ - sv_setpvn(GvSVn(gv),"\f",1); + sv_setpvs(GvSVn(gv),"\f"); PL_formfeed = GvSVn(gv); break; - case ';': - sv_setpvn(GvSVn(gv),"\034",1); + case ';': /* $; */ + sv_setpvs(GvSVn(gv),"\034"); break; - case ']': + case ']': /* $] */ { SV * const sv = GvSVn(gv); if (!sv_derived_from(PL_patchlevel, "version")) @@ -1347,6 +1543,9 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) const char *name; STRLEN namelen; const HV * const hv = GvSTASH(gv); + + PERL_ARGS_ASSERT_GV_FULLNAME4; + if (!hv) { SvOK_off(sv); return; @@ -1371,29 +1570,11 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) void Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) { - const GV * const egv = GvEGV(gv); - gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); -} + const GV * const egv = GvEGVx(gv); -IO * -Perl_newIO(pTHX) -{ - dVAR; - GV *iogv; - IO * const io = (IO*)newSV_type(SVt_PVIO); - /* This used to read SvREFCNT(io) = 1; - It's not clear why the reference count needed an explicit reset. NWC - */ - assert (SvREFCNT(io) == 1); - SvOBJECT_on(io); - /* Clear the stashcache because a new IO could overrule a package name */ - hv_clear(PL_stashcache); - iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV); - /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ - if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) - iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); - SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv))); - return io; + PERL_ARGS_ASSERT_GV_EFULLNAME4; + + gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); } void @@ -1402,6 +1583,8 @@ Perl_gv_check(pTHX_ const HV *stash) dVAR; register I32 i; + PERL_ARGS_ASSERT_GV_CHECK; + if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { @@ -1410,14 +1593,14 @@ Perl_gv_check(pTHX_ const HV *stash) register GV *gv; HV *hv; if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && - (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv))) + (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) { if (hv != PL_defstash && hv != stash) gv_check(hv); /* nested package */ } else if (isALPHA(*HeKEY(entry))) { const char *file; - gv = (GV*)HeVAL(entry); + gv = MUTABLE_GV(HeVAL(entry)); if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) continue; file = GvFILE(gv); @@ -1425,7 +1608,8 @@ Perl_gv_check(pTHX_ const HV *stash) #ifdef USE_ITHREADS CopFILE(PL_curcop) = (char *)file; /* set for warning */ #else - CopFILEGV(PL_curcop) = gv_fetchfile(file); + CopFILEGV(PL_curcop) + = 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", @@ -1439,6 +1623,9 @@ GV * Perl_newGVgen(pTHX_ const char *pack) { dVAR; + + PERL_ARGS_ASSERT_NEWGVGEN; + return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), GV_ADD, SVt_PVGV); } @@ -1474,10 +1661,9 @@ Perl_gp_free(pTHX_ GV *gv) if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) return; if (gp->gp_refcnt == 0) { - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free unreferenced glob pointers" - pTHX__FORMAT pTHX__VALUE); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free unreferenced glob pointers" + pTHX__FORMAT pTHX__VALUE); return; } if (--gp->gp_refcnt > 0) { @@ -1514,12 +1700,14 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) AMT * const amtp = (AMT*)mg->mg_ptr; PERL_UNUSED_ARG(sv); + PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; + if (amtp && AMT_AMAGIC(amtp)) { int i; for (i = 1; i < NofAMmeth; i++) { CV * const cv = amtp->table[i]; if (cv) { - SvREFCNT_dec((SV *) cv); + SvREFCNT_dec(MUTABLE_SV(cv)); amtp->table[i] = NULL; } } @@ -1528,24 +1716,31 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) } /* Updates and caches the CV's */ +/* Returns: + * 1 on success and there is some overload + * 0 if there is no overload + * -1 if some error occurred and it couldn't croak + */ -bool -Perl_Gv_AMupdate(pTHX_ HV *stash) +int +Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) { dVAR; - MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); AMT amt; const struct mro_meta* stash_meta = HvMROMETA(stash); U32 newgen; + PERL_ARGS_ASSERT_GV_AMUPDATE; + newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; if (mg) { const AMT * const amtp = (AMT*)mg->mg_ptr; if (amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == newgen) { - return (bool)AMT_OVERLOADED(amtp); + return AMT_OVERLOADED(amtp) ? 1 : 0; } - sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); + sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); } DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); @@ -1585,7 +1780,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) const char * const cooky = PL_AMG_names[i]; /* Human-readable form, for debugging: */ const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); - const STRLEN l = strlen(cooky); + const STRLEN l = PL_AMG_namelens[i]; DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", cp, HvNAME_get(stash)) ); @@ -1619,12 +1814,17 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) FALSE))) { /* Can be an import stub (created by "can"). */ - const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(gvsv) : "???"; - Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\ - "in package \"%.256s\"", - (GvCVGEN(gv) ? "Stub found while resolving" - : "Can't resolve"), - name, cp, hvname); + 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\"", + (GvCVGEN(gv) ? "Stub found while resolving" + : "Can't resolve"), + name, cp, hvname); + } } cv = GvCV(gv = ngv); } @@ -1635,16 +1835,16 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) if (i < DESTROY_amg) have_ovl = 1; } else if (gv) { /* Autoloaded... */ - cv = (CV*)gv; + cv = MUTABLE_CV(gv); filled = 1; } - amt.table[i]=(CV*)SvREFCNT_inc_simple(cv); + amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); } if (filled) { AMT_AMAGIC_on(&amt); if (have_ovl) AMT_OVERLOADED_on(&amt); - sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, + sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMT)); return have_ovl; } @@ -1652,9 +1852,9 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) /* Here we have no table: */ /* no_table: */ AMT_AMAGIC_off(&amt); - sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, + sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMTS)); - return FALSE; + return 0; } @@ -1673,11 +1873,23 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) stash_meta = HvMROMETA(stash); newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; - mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: - Gv_AMupdate(stash); - mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + /* If we're looking up a destructor to invoke, we must avoid + * that Gv_AMupdate croaks, because we might be dying already */ + if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) { + /* and if it didn't found a destructor, we fall back + * to a simpler method that will only look for the + * destructor instead of the whole magic */ + if (id == DESTROY_amg) { + GV * const gv = gv_fetchmethod(stash, "DESTROY"); + if (gv) + return GvCV(gv); + } + return NULL; + } + mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); } assert(mg); amtp = (AMT*)mg->mg_ptr; @@ -1703,6 +1915,99 @@ 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. +*/ + +bool +Perl_try_amagic_un(pTHX_ int method, int flags) { + dVAR; + dSP; + SV* tmpsv; + SV* const arg = TOPs; + + SvGETMAGIC(arg); + + if (SvAMAGIC(arg) && (tmpsv = AMG_CALLun_var(arg,method))) { + if (flags & AMGf_set) { + SETs(tmpsv); + } + else { + dTARGET; + if (SvPADMY(TARG)) { + sv_setsv(TARG, tmpsv); + SETTARG; + } + else + SETs(tmpsv); + } + PUTBACK; + return TRUE; + } + + if ((flags & AMGf_numeric) && SvROK(arg)) + *sp = sv_2num(arg); + return FALSE; +} + + +/* Implement tryAMAGICbin_MG macro. + 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. +*/ + +bool +Perl_try_amagic_bin(pTHX_ int method, int flags) { + dVAR; + dSP; + SV* const left = TOPm1s; + SV* const right = TOPs; + + SvGETMAGIC(left); + if (left != right) + SvGETMAGIC(right); + + if (SvAMAGIC(left) || SvAMAGIC(right)) { + SV * const tmpsv = amagic_call(left, right, method, + ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)); + 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); + } + PUTBACK; + return TRUE; + } + } + if (flags & AMGf_numeric) { + if (SvROK(left)) + *(sp-1) = sv_2num(left); + if (SvROK(right)) + *sp = sv_2num(right); + } + return FALSE; +} + + SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { @@ -1719,9 +2024,33 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) int fl=0; #endif HV* stash=NULL; + + PERL_ARGS_ASSERT_AMAGIC_CALL; + + if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { + SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, + 0, "overloading", 11, 0, 0); + + if ( !lex_mask || !SvOK(lex_mask) ) + /* overloading lexically disabled */ + return NULL; + else if ( lex_mask && SvPOK(lex_mask) ) { + /* we have an entry in the hints hash, check if method has been + * masked by overloading.pm */ + STRLEN len; + const int offset = method / 8; + const int bit = method % 8; + char *pv = SvPV(lex_mask, len); + + /* Bit set, so this overloading operator is disabled */ + if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) + return NULL; + } + } + if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (stash = SvSTASH(SvRV(left))) - && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) + && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table : NULL)) @@ -1768,7 +2097,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) (void)((cv = cvp[off=bool__amg]) || (cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); - postpr = 1; + if (cv) + postpr = 1; break; case copy_amg: { @@ -1790,7 +2120,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) Hence we can't use SvAMAGIC_on() */ SvFLAGS(newref) |= SVf_AMAGIC; - SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef))); + SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); return newref; } } @@ -1828,6 +2158,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) break; case int_amg: case iter_amg: /* XXXX Eventually should do to_gv. */ + case ftest_amg: /* XXXX Eventually should do to_gv. */ + case regexp_amg: /* FAIL safe */ return NULL; /* Delegate operation to standard mechanisms. */ break; @@ -1845,7 +2177,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) && (stash = SvSTASH(SvRV(right))) - && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) + && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table : NULL)) @@ -1871,35 +2203,24 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case ge_amg: case eq_amg: case ne_amg: - postpr = 1; off=ncmp_amg; break; + off = ncmp_amg; + break; case slt_amg: case sle_amg: case sgt_amg: case sge_amg: case seq_amg: case sne_amg: - postpr = 1; off=scmp_amg; break; + off = scmp_amg; + break; } - if (off != -1) cv = cvp[off]; - if (!cv) { - goto not_found; - } + if ((off != -1) && (cv = cvp[off])) + postpr = 1; + else + goto not_found; } else { not_found: /* No method found, either report or croak */ switch (method) { - case lt_amg: - case le_amg: - case gt_amg: - case ge_amg: - case eq_amg: - case ne_amg: - case slt_amg: - case sle_amg: - case sgt_amg: - case sge_amg: - case seq_amg: - case sne_amg: - postpr = 0; break; case to_sv_amg: case to_av_amg: case to_hv_amg: @@ -1989,7 +2310,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (( (method + assignshift == off) && (assign || (method == inc_amg) || (method == dec_amg))) || force_cpy) + { RvDEEPCP(left); + } + { dSP; BINOP myop; @@ -2016,12 +2340,13 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(lr>0? left: right); PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { - PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0))); + PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), + AMG_id2namelen(method + assignshift), SVs_TEMP)); } - PUSHs((SV*)cv); + PUSHs(MUTABLE_SV(cv)); PUTBACK; - if ((PL_op = Perl_pp_entersub(aTHX))) + if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) CALLRUNOPS(aTHX); LEAVE; SPAGAIN; @@ -2075,22 +2400,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. Calls is_gv_magical. - -=cut -*/ - -bool -Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags) -{ - STRLEN len; - const char * const temp = SvPV_const(name, len); - return is_gv_magical(temp, len, flags); -} - -/* -=for apidoc is_gv_magical - Returns C if given the name of a magical GV. Currently only useful internally when determining if a GV should be @@ -2105,17 +2414,21 @@ pointers returned by SvPV. =cut */ + bool -Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) +Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags) { - PERL_UNUSED_CONTEXT; + STRLEN len; + const char *const name = SvPV_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 && name1[1] == 'S' && name[2] == 'A') + if (len == 3 && name[1] == 'S' && name[2] == 'A') goto yes; break; case 'O': @@ -2187,7 +2500,6 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) case ')': case '<': case '>': - case ',': case '\\': case '/': case '|': @@ -2233,7 +2545,7 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) dVAR; U32 hash; - assert(name); + PERL_ARGS_ASSERT_GV_NAME_SET; PERL_UNUSED_ARG(flags); if (len > I32_MAX) @@ -2248,6 +2560,76 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) } /* +=for apidoc gv_try_downgrade + +If the typeglob C can be expressed more succinctly, by having +something other than a real GV in its place in the stash, replace it +with the optimised form. Basic requirements for this are that C +is a real typeglob, is sufficiently ordinary, and is only referenced +from its package. This function is meant to be used when a GV has been +looked up in part to see what was there, causing upgrading, but based +on what was found it turns out that the real GV isn't required after all. + +If C is a completely empty typeglob, it is deleted from the stash. + +If C is a typeglob containing only a sufficiently-ordinary constant +sub, the typeglob is replaced with a scalar-reference placeholder that +more compactly represents the same thing. + +=cut +*/ + +void +Perl_gv_try_downgrade(pTHX_ GV *gv) +{ + HV *stash; + CV *cv; + HEK *namehek; + SV **gvp; + PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE; + if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && + !SvOBJECT(gv) && !SvREADONLY(gv) && + isGV_with_GP(gv) && GvGP(gv) && + !GvINTRO(gv) && GvREFCNT(gv) == 1 && + !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && + GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) + return; + if (SvMAGICAL(gv)) { + MAGIC *mg; + /* only backref magic is allowed */ + if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) + return; + for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) { + if (mg->mg_type != PERL_MAGIC_backref) + return; + } + } + 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 && + !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && + CvSTASH(cv) == stash && 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 == (SV*)gv) { + SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); + SvREFCNT(gv) = 0; + sv_clear((SV*)gv); + SvREFCNT(gv) = 1; + SvFLAGS(gv) = SVt_IV|SVf_ROK; + SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - + STRUCT_OFFSET(XPVIV, xiv_iv)); + SvRV_set(gv, value); + } +} + +/* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4