X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=f24a7f153150350db1b066355f6d3ac4ba346904;hb=f0c5aa00eeb992584d6996af147c4c51fe7a6540;hp=f278e37ce5e09d365f8e19d16744d454cfa3c1c8;hpb=e23d9e2f39425eea292ee5999c974fdc2cdd98b8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index f278e37..f24a7f1 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. @@ -99,15 +99,11 @@ Perl_gv_IOadd(pTHX_ register GV *gv) PL_op->op_type == OP_REWINDDIR || PL_op->op_type == OP_CLOSEDIR ? "dirhandle" : "filehandle"; + /* diag_listed_as: Bad symbol for filehandle */ Perl_croak(aTHX_ "Bad symbol for %s", fh); } if (!GvIOp(gv)) { -#ifdef GV_UNIQUE_CHECK - if (GvUNIQUE(gv)) { - Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)"); - } -#endif GvIOp(gv) = newIO(); } return gv; @@ -1092,6 +1088,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 ? '%' : '$', @@ -1237,10 +1234,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); @@ -1249,9 +1258,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; @@ -1390,6 +1396,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': @@ -1657,9 +1664,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 +1686,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 +1762,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 +1802,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 +1824,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); @@ -1853,6 +1882,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)) @@ -1962,6 +2012,7 @@ 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. */ /* FAIL safe */ return NULL; /* Delegate operation to standard mechanisms. */ break; @@ -2156,7 +2207,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; @@ -2210,25 +2261,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 +2275,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;