X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6f1401dc2acd2a2b85df22b0a74e5f7e6e0a33aa..e058c50ad847ead283c43829ad8b0b73f59ef9db:/gv.c diff --git a/gv.c b/gv.c index 2d4cebc..aef0aa4 100644 --- a/gv.c +++ b/gv.c @@ -45,7 +45,13 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) { SV **where; - if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) { + if ( + !gv + || ( + SvTYPE((const SV *)gv) != SVt_PVGV + && SvTYPE((const SV *)gv) != SVt_PVLV + ) + ) { const char *what; if (type == SVt_PVIO) { /* @@ -121,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; @@ -193,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) { @@ -240,7 +298,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) SvIOK_off(gv); isGV_with_GP_on(gv); - GvGP(gv) = Perl_newGP(aTHX_ gv); + GvGP_set(gv, Perl_newGP(aTHX_ gv)); GvSTASH(gv) = stash; if (stash) Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); @@ -248,10 +306,23 @@ 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); + /* In case op.c:S_process_special_blocks stole it: */ + if (!GvCV(gv)) + GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv)); + 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. */ @@ -259,16 +330,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_set(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); } } @@ -339,7 +411,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) HV* cstash; GV* candidate = NULL; CV* cand_cv = NULL; - CV* old_cv; GV* topgv = NULL; const char *hvname; I32 create = (level >= 0) ? 1 : 0; @@ -384,7 +455,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) else { /* stale cache entry, junk it and move on */ SvREFCNT_dec(cand_cv); - GvCV(topgv) = cand_cv = NULL; + GvCV_set(topgv, NULL); + cand_cv = NULL; GvCVGEN(topgv) = 0; } } @@ -432,9 +504,10 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) * 2. method isn't a stub (else AUTOLOAD fails spectacularly) */ if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { - if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); + CV *old_cv = GvCV(topgv); + SvREFCNT_dec(old_cv); SvREFCNT_inc_simple_void_NN(cand_cv); - GvCV(topgv) = cand_cv; + GvCV_set(topgv, cand_cv); GvCVGEN(topgv) = topgen_cmp; } return candidate; @@ -447,9 +520,10 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) if(candidate) { cand_cv = GvCV(candidate); if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { - if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); + CV *old_cv = GvCV(topgv); + SvREFCNT_dec(old_cv); SvREFCNT_inc_simple_void_NN(cand_cv); - GvCV(topgv) = cand_cv; + GvCV_set(topgv, cand_cv); GvCVGEN(topgv) = topgen_cmp; } return candidate; @@ -646,6 +720,20 @@ Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) /* Right now this is exclusively for the benefit of S_method_common in pp_hot.c */ if (stash) { + /* If we can't find an IO::File method, it might be a call on + * a filehandle. If IO:File has not been loaded, try to + * require it first instead of croaking */ + const char *stash_name = HvNAME_get(stash); + if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") + && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, + STR_WITH_LEN("IO/File.pm"), 0, + HV_FETCH_ISEXISTS, NULL, 0) + ) { + require_pv("IO/File.pm"); + gv = gv_fetchmeth(stash, name, nend - name, 0); + if (gv) + return gv; + } Perl_croak(aTHX_ "Can't locate object method \"%s\" via package \"%.*s\"", name, (int)HvNAMELEN_get(stash), HvNAME_get(stash)); @@ -739,7 +827,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; @@ -765,13 +853,15 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) varsv = GvSVn(vargv); sv_setpvn(varsv, packname, packname_len); sv_catpvs(varsv, "::"); - sv_catpvn(varsv, name, len); + /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear + tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */ + sv_catpvn_mg(varsv, name, len); return gv; } /* require_tie_mod() internal routine for requiring a module - * that implements the logic of automatical ties like %! and %- + * that implements the logic of automatic ties like %! and %- * * The "gv" parameter should be the glob. * "varpv" holds the name of the var, used for error messages. @@ -869,11 +959,18 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) Safefree(tmpbuf); if (!tmpgv) return NULL; - if (!GvHV(tmpgv)) - GvHV(tmpgv) = newHV(); stash = GvHV(tmpgv); - if (!HvNAME_get(stash)) + if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; + assert(stash); + if (!HvNAME_get(stash)) { hv_name_set(stash, name, namelen, 0); + + /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ + /* If the containing stash has multiple effective + names, see that this one gets them, too. */ + if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) + mro_package_moved(stash, NULL, tmpgv, 1); + } return stash; } @@ -911,6 +1008,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) @@ -943,9 +1065,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } for (name_cursor = name; name_cursor < name_end; name_cursor++) { - if ((*name_cursor == ':' && name_cursor < name_em1 + if (name_cursor < name_em1 && + ((*name_cursor == ':' && name_cursor[1] == ':') - || (*name_cursor == '\'' && name_cursor[1])) + || *name_cursor == '\'')) { if (!stash) stash = PL_defstash; @@ -953,41 +1076,56 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, return NULL; len = name_cursor - name; - if (len > 0) { - char smallbuf[128]; - char *tmpbuf; - - if (len + 2 <= (I32)sizeof (smallbuf)) - tmpbuf = smallbuf; - else + if (name_cursor > nambeg) { /* Skip for initial :: or ' */ + 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(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)) { + if (GvSTASH(gv) == PL_defstash && len == 6 + && strnEQ(name, "CORE", 4)) + hv_name_set(stash, "CORE", 4, 0); + else + 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); } if (*name_cursor == ':') name_cursor++; - name_cursor++; - name = name_cursor; + name = name_cursor+1; if (name == name_end) return gv ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); @@ -1119,12 +1257,17 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (add) { GvMULTI_on(gv); gv_init_sv(gv, sv_type); - if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) { + if (len == 1 && stash == PL_defstash + && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) { if (*name == '!') require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); 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) { @@ -1152,7 +1295,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 > 2) { + 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; @@ -1179,32 +1347,12 @@ 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': @@ -1250,6 +1398,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; @@ -1259,7 +1411,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; @@ -1395,6 +1548,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '>': /* $> */ case '\\': /* $\ */ case '/': /* $/ */ + case '$': /* $$ */ case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ @@ -1560,6 +1714,7 @@ Perl_gp_free(pTHX_ GV *gv) { dVAR; GP* gp; + int attempts = 100; if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) return; @@ -1572,29 +1727,65 @@ Perl_gp_free(pTHX_ GV *gv) if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) gp->gp_egv = 0; - GvGP(gv) = 0; + GvGP_set(gv, NULL); return; } - if (gp->gp_file_hek) - unshare_hek(gp->gp_file_hek); - SvREFCNT_dec(gp->gp_sv); - SvREFCNT_dec(gp->gp_av); - /* FIXME - another reference loop GV -> symtab -> GV ? - Somehow gp->gp_hv can end up pointing at freed garbage. */ - if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { - const char *hvname = HvNAME_get(gp->gp_hv); + while (1) { + /* Copy and null out all the glob slots, so destructors do not see + freed SVs. */ + HEK * const file_hek = gp->gp_file_hek; + SV * const sv = gp->gp_sv; + AV * const av = gp->gp_av; + HV * const hv = gp->gp_hv; + IO * const io = gp->gp_io; + CV * const cv = gp->gp_cv; + CV * const form = gp->gp_form; + + gp->gp_file_hek = NULL; + gp->gp_sv = NULL; + gp->gp_av = NULL; + gp->gp_hv = NULL; + gp->gp_io = NULL; + gp->gp_cv = NULL; + gp->gp_form = NULL; + + if (file_hek) + unshare_hek(file_hek); + + SvREFCNT_dec(sv); + SvREFCNT_dec(av); + /* FIXME - another reference loop GV -> symtab -> GV ? + Somehow gp->gp_hv can end up pointing at freed garbage. */ + if (hv && SvTYPE(hv) == SVt_PVHV) { + const char *hvname = HvNAME_get(hv); if (PL_stashcache && hvname) - (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv), + (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv), G_DISCARD); - SvREFCNT_dec(gp->gp_hv); + SvREFCNT_dec(hv); + } + SvREFCNT_dec(io); + SvREFCNT_dec(cv); + SvREFCNT_dec(form); + + if (!gp->gp_file_hek + && !gp->gp_sv + && !gp->gp_av + && !gp->gp_hv + && !gp->gp_io + && !gp->gp_cv + && !gp->gp_form) break; + + if (--attempts == 0) { + Perl_die(aTHX_ + "panic: gp_free failed to free glob pointer - " + "something is repeatedly re-creating entries" + ); + } } - SvREFCNT_dec(gp->gp_io); - SvREFCNT_dec(gp->gp_cv); - SvREFCNT_dec(gp->gp_form); Safefree(gp); - GvGP(gv) = 0; + GvGP_set(gv, NULL); } int @@ -1781,7 +1972,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) do_update: /* 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) { + if (Gv_AMupdate(stash, cBOOL(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 */ @@ -1835,7 +2026,8 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { SvGETMAGIC(arg); - if (SvAMAGIC(arg) && (tmpsv = AMG_CALLun_var(arg,method))) { + if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method, + AMGf_noright | AMGf_unary))) { if (flags & AMGf_set) { SETs(tmpsv); } @@ -1901,15 +2093,46 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { return TRUE; } } + if(left==right && SvGMAGICAL(left)) { + SV * const left = sv_newmortal(); + *(sp-1) = left; + /* Print the uninitialized warning now, so it includes the vari- + able name. */ + if (!SvOK(right)) { + if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); + sv_setsv_flags(left, &PL_sv_no, 0); + } + else sv_setsv_flags(left, right, 0); + SvGETMAGIC(right); + } if (flags & AMGf_numeric) { - if (SvROK(left)) - *(sp-1) = sv_2num(left); + if (SvROK(TOPm1s)) + *(sp-1) = sv_2num(TOPm1s); 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) @@ -1923,6 +2146,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) int postpr = 0, force_cpy = 0; int assign = AMGf_assign & flags; const int assignshift = assign ? 1 : 0; + int use_default_op = 0; #ifdef DEBUGGING int fl=0; #endif @@ -1931,8 +2155,7 @@ 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); + SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); if ( !lex_mask || !SvOK(lex_mask) ) /* overloading lexically disabled */ @@ -2087,9 +2310,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; - } else if (((ocvp && oamtp->fallback > AMGfallNEVER - && (cvp=ocvp) && (lr = -1)) - || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) + } else if (((cvp && amtp->fallback > AMGfallNEVER) + || (ocvp && oamtp->fallback > AMGfallNEVER)) && !(flags & AMGf_unary)) { /* We look for substitution for * comparison operations and @@ -2117,7 +2339,17 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) off = scmp_amg; break; } - if ((off != -1) && (cv = cvp[off])) + if (off != -1) { + if (ocvp && (oamtp->fallback > AMGfallNEVER)) { + cv = ocvp[off]; + lr = -1; + } + if (!cv && (cvp && amtp->fallback > AMGfallNEVER)) { + cv = cvp[off]; + lr = 1; + } + } + if (cv) postpr = 1; else goto not_found; @@ -2137,7 +2369,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { notfound = 1; lr = 1; - } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) { + } else if ((use_default_op = + (!ocvp || oamtp->fallback >= AMGfallYES) + && (!cvp || amtp->fallback >= AMGfallYES)) + && !DEBUG_o_TEST) { /* Skip generating the "no method found" message. */ return NULL; } else { @@ -2161,7 +2396,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SvAMAGIC(right)? HvNAME_get(SvSTASH(SvRV(right))): "")); - if (amtp && amtp->fallback >= AMGfallYES) { + if (use_default_op) { DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); } else { Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); @@ -2214,7 +2449,15 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) && (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_CALLunary(left,copy_amg))) { + SvRV_set(left, rv_copy); + SvSETMAGIC(left); + SvREFCNT_dec(tmpRef); + } } { @@ -2236,7 +2479,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (PERLDB_SUB && PL_curstash != PL_debstash) PL_op->op_private |= OPpENTERSUB_DB; PUTBACK; - pp_pushmark(); + Perl_pp_pushmark(aTHX); EXTEND(SP, notfound + 5); PUSHs(lr>0? right: left); @@ -2490,13 +2733,28 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) 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) && !SvMAGICAL(gv) && !SvREADONLY(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);