X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c8aa86e11144b22a034d68da930a681a5a5fb4f5..99ee976292c47b41b12e66dc2a0fea4a98c9ab9f:/gv.c diff --git a/gv.c b/gv.c index 598eb9e..b2cb5a4 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. @@ -40,76 +40,51 @@ 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; - - 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); + SV **where; + + if ( + !gv + || ( + SvTYPE((const SV *)gv) != SVt_PVGV + && SvTYPE((const SV *)gv) != SVt_PVLV + ) + ) { + 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; } @@ -152,9 +127,9 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, #else sv_setpvn(GvSV(gv), name, namelen); #endif - if (PERLDB_LINE || PERLDB_SAVESRC) - 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; @@ -224,6 +199,58 @@ 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); + } +} + +/* Assign CvSTASH(cv) = st, handling weak references. */ + +void +Perl_cvstash_set(pTHX_ CV *cv, HV *st) +{ + HV *oldst = CvSTASH(cv); + PERL_ARGS_ASSERT_CVSTASH_SET; + if (oldst == st) + return; + if (oldst) + sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv)); + SvANY(cv)->xcv_stash = st; + if (st) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); +} + void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { @@ -279,10 +306,20 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) 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. */ @@ -290,16 +327,17 @@ 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_set(cv, PL_curstash); if (proto) { - sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen, + sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, SV_HAS_TRAILING_NUL); } } @@ -444,9 +482,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; } @@ -760,11 +797,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 @@ -772,7 +808,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) * and split that value on the last '::', * pass along the same data via some unused fields in the CV */ - CvSTASH(cv) = stash; + CvSTASH_set(cv, stash); SvPV_set(cv, (char *)name); /* cast to lose constness warning */ SvCUR_set(cv, len); return gv; @@ -886,26 +922,25 @@ 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) return NULL; - if (!GvHV(tmpgv)) - GvHV(tmpgv) = newHV(); stash = GvHV(tmpgv); - if (!HvNAME_get(stash)) - hv_name_set(stash, name, namelen, 0); + assert(stash); + assert(HvNAME_get(stash)); return stash; } @@ -943,6 +978,31 @@ Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); } +STATIC void +S_gv_magicalize_isa(pTHX_ GV *gv) +{ + 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); +} + +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, const svtype sv_type) @@ -986,33 +1046,43 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, len = name_cursor - name; if (len > 0) { - char smallbuf[128]; - char *tmpbuf; - - if (len + 2 <= (I32)sizeof (smallbuf)) - tmpbuf = smallbuf; - else + const char *key; + if (*name_cursor == ':') { + key = name; + len += 2; + } else { + char *tmpbuf; Newx(tmpbuf, len+2, char); - Copy(name, tmpbuf, len, char); - tmpbuf[len++] = ':'; - tmpbuf[len++] = ':'; - gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); + Copy(name, tmpbuf, len, char); + tmpbuf[len++] = ':'; + tmpbuf[len++] = ':'; + key = tmpbuf; + } + gvp = (GV**)hv_fetch(stash, key, len, add); gv = gvp ? *gvp : NULL; if (gv && gv != (const GV *)&PL_sv_undef) { if (SvTYPE(gv) != SVt_PVGV) - gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); + gv_init(gv, stash, key, len, (add & GV_ADDMULTI)); else GvMULTI_on(gv); } - if (tmpbuf != smallbuf) - Safefree(tmpbuf); + if (key != name) + Safefree((char *)key); if (!gv || gv == (const GV *)&PL_sv_undef) return NULL; if (!(stash = GvHV(gv))) + { stash = GvHV(gv) = newHV(); - - if (!HvNAME_get(stash)) + if (!HvNAME_get(stash)) { + hv_name_set(stash, nambeg, name_cursor-nambeg, 0); + /* If the containing stash has multiple effective + names, see that this one gets them, too. */ + if (HvAUX(GvSTASH(gv))->xhv_name_count) + mro_package_moved(stash, NULL, gv, 1); + } + } + else if (!HvNAME_get(stash)) hv_name_set(stash, nambeg, name_cursor - nambeg, 0); } @@ -1092,12 +1162,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; } } @@ -1151,6 +1227,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, else if (*name == '-' || *name == '+') require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); } + else if (len == 3 && sv_type == SVt_PVAV + && strnEQ(name, "ISA", 3) + && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) + gv_magicalize_isa(gv); } return gv; } else if (no_init) { @@ -1168,8 +1248,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); @@ -1178,7 +1258,32 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 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); + 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; @@ -1205,42 +1310,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(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); - } + gv_magicalize_isa(gv); } 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); @@ -1249,9 +1346,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; @@ -1267,6 +1361,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "NCODING")) goto magicalize; break; + case '\007': /* $^GLOBAL_PHASE */ + if (strEQ(name2, "LOBAL_PHASE")) + goto ro_magicalize; + break; case '\015': /* $^MATCH */ if (strEQ(name2, "ATCH")) goto magicalize; @@ -1276,7 +1374,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case '\020': /* $^PREMATCH $^POSTMATCH */ if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) - goto magicalize; + goto magicalize; + break; case '\024': /* ${^TAINT} */ if (strEQ(name2, "AINT")) goto ro_magicalize; @@ -1318,9 +1417,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 || @@ -1331,17 +1430,17 @@ 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. */ @@ -1352,8 +1451,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 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); @@ -1370,13 +1469,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; @@ -1390,27 +1489,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 '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 */ @@ -1430,10 +1530,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, sv_setpvs(GvSVn(gv),"\f"); PL_formfeed = GvSVn(gv); break; - case ';': + case ';': /* $; */ sv_setpvs(GvSVn(gv),"\034"); break; - case ']': + case ']': /* $] */ { SV * const sv = GvSVn(gv); if (!sv_derived_from(PL_patchlevel, "version")) @@ -1489,34 +1589,13 @@ 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); + const GV * const egv = GvEGVx(gv); PERL_ARGS_ASSERT_GV_EFULLNAME4; 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) { @@ -1601,10 +1680,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) { @@ -1657,9 +1735,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); @@ -1674,7 +1757,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); } @@ -1750,12 +1833,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); } @@ -1785,7 +1873,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; } @@ -1807,7 +1895,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); @@ -1834,6 +1934,119 @@ 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 = amagic_call(arg, &PL_sv_undef, method, + AMGf_noright | AMGf_unary))) { + 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_deref_call(pTHX_ SV *ref, int method) { + SV *tmpsv = NULL; + + PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL; + + while (SvAMAGIC(ref) && + (tmpsv = amagic_call(ref, &PL_sv_undef, method, + AMGf_noright | AMGf_unary))) { + if (!SvROK(tmpsv)) + Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); + if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { + /* Bail out if it returns us the same reference. */ + return tmpsv; + } + ref = tmpsv; + } + return tmpsv ? tmpsv : ref; +} + SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { @@ -1853,6 +2066,26 @@ 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 = cop_hints_fetch_pvs(PL_curcop, "overloading", 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)) @@ -1902,7 +2135,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: { @@ -1962,6 +2196,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; @@ -2005,35 +2241,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: @@ -2123,7 +2348,18 @@ 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); + { + /* newSVsv does not behave as advertised, so we copy missing + * information by hand */ + SV *tmpRef = SvRV(left); + SV *rv_copy; + if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLun(left,copy))) { + SvRV_set(left, rv_copy); + SvSETMAGIC(left); + SvREFCNT_dec(tmpRef); + } + } + { dSP; BINOP myop; @@ -2210,25 +2446,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 @@ -2243,13 +2460,15 @@ pointers returned by SvPV. =cut */ + bool -S_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; @@ -2387,6 +2606,81 @@ 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; + + /* XXX Why and where does this leave dangling pointers during global + destruction? */ + if (PL_phase == PERL_PHASE_DESTRUCT) return; + + 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