X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=932b2b800210b5264fe6ee6daa3f30d0626612ea;hb=0be0346991b9897be3779aad45b504f1f1d7c709;hp=4a1617c1c6a8f220e8582d89c913514dfb4423df;hpb=ad64d0ecd555e97c5a216efca1ec5a96b7fd0b34;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 4a1617c..932b2b8 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, 2008 by Larry Wall and others + * 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"] */ /* @@ -38,76 +40,45 @@ Perl stores its global variables. 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) -{ - PERL_ARGS_ASSERT_GV_SVADD; - - if (!gv || SvTYPE((const 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_ARGS_ASSERT_GV_AVADD; - - if (!gv || SvTYPE((const 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) -{ - PERL_ARGS_ASSERT_GV_HVADD; - - if (!gv || SvTYPE((const 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) +Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) { - dVAR; - - PERL_ARGS_ASSERT_GV_IOADD; + SV **where; if (!gv || SvTYPE((const 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); + 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; } @@ -150,7 +121,7 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, #else sv_setpvn(GvSV(gv), name, namelen); #endif - if (PERLDB_LINE) + if (PERLDB_LINE || PERLDB_SAVESRC) hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); } if (tmpbuf != smallbuf) @@ -442,9 +413,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; } @@ -669,7 +639,7 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) 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) { @@ -758,11 +728,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 @@ -884,17 +853,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) @@ -996,7 +966,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 @@ -1004,7 +974,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))) @@ -1019,7 +989,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; @@ -1080,7 +1051,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; @@ -1089,6 +1060,7 @@ 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)) ) { + /* diag_listed_as: Variable "%s" is not imported%s */ Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', @@ -1135,7 +1107,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) { @@ -1165,8 +1137,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, faking_it = SvOK(gv); - if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); + if (add & GV_ADDWARN) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type); @@ -1210,17 +1182,16 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1) { - const char *pname; - av_push(av, newSVpvs(pname = "NDBM_File")); - gv_stashpvn(pname, 9, GV_ADD); - av_push(av, newSVpvs(pname = "DB_File")); - gv_stashpvn(pname, 7, GV_ADD); - av_push(av, newSVpvs(pname = "GDBM_File")); - gv_stashpvn(pname, 9, GV_ADD); - av_push(av, newSVpvs(pname = "SDBM_File")); - gv_stashpvn(pname, 9, GV_ADD); - av_push(av, newSVpvs(pname = "ODBM_File")); - gv_stashpvn(pname, 9, GV_ADD); + 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); } } break; @@ -1235,10 +1206,22 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 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); @@ -1247,9 +1230,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; @@ -1370,9 +1350,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } 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); + if (sv_type == SVt_PV) + Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "$%c is no longer supported", *name); break; case '|': sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); @@ -1388,6 +1368,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, ro_magicalize: SvREADONLY_on(GvSVn(gv)); /* FALL THROUGH */ + case '0': case '1': case '2': case '3': @@ -1407,7 +1388,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case ')': case '<': case '>': - case ',': case '\\': case '/': case '\001': /* $^A */ @@ -1495,27 +1475,6 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); } -IO * -Perl_newIO(pTHX) -{ - dVAR; - GV *iogv; - IO * const io = MUTABLE_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, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); - return io; -} - void Perl_gv_check(pTHX_ const HV *stash) { @@ -1532,14 +1491,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); @@ -1600,10 +1559,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) { @@ -1656,9 +1614,14 @@ 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((const SV *)stash, PERL_MAGIC_overload_table); @@ -1673,7 +1636,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) 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(MUTABLE_SV(stash), PERL_MAGIC_overload_table); } @@ -1749,12 +1712,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); } @@ -1784,7 +1752,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) AMT_AMAGIC_off(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMTS)); - return FALSE; + return 0; } @@ -1806,7 +1774,19 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: - Gv_AMupdate(stash); + /* 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); @@ -1852,6 +1832,27 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) 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((const SV *)stash, PERL_MAGIC_overload_table)) @@ -1961,6 +1962,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; @@ -2155,7 +2158,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(MUTABLE_SV(cv)); PUTBACK; - if ((PL_op = Perl_pp_entersub(aTHX))) + if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) CALLRUNOPS(aTHX); LEAVE; SPAGAIN; @@ -2209,25 +2212,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); - - PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV; - - 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 @@ -2242,13 +2226,15 @@ 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; - PERL_UNUSED_ARG(flags); + STRLEN len; + const char *const name = SvPV_const(name_sv, len); - PERL_ARGS_ASSERT_IS_GV_MAGICAL; + PERL_UNUSED_ARG(flags); + PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV; if (len > 1) { const char * const name1 = name + 1; @@ -2326,7 +2312,6 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) case ')': case '<': case '>': - case ',': case '\\': case '/': case '|': @@ -2387,6 +2372,53 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) } /* +=for apidoc gv_try_downgrade + +If C is a typeglob containing only a constant sub, and is only +referenced from its package, and both the typeglob and the sub are +sufficiently ordinary, replace the typeglob (in the package) with a +placeholder that more compactly represents the same thing. This is meant +to be used when a placeholder has been upgraded, most likely because +something wanted to look at a proper code object, and it has turned out +to be a constant sub to which a proper reference is no longer required. + +=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) && !SvMAGICAL(gv) && !SvREADONLY(gv) && + isGV_with_GP(gv) && GvGP(gv) && + GvMULTI(gv) && !GvINTRO(gv) && GvREFCNT(gv) == 1 && + !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && + GvEGV(gv) == gv && (stash = GvSTASH(gv)) && (cv = GvCV(gv)) && + !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