X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8561ea1dd1a3357825e765e1df4f883e53f89a9d..6ea81ccfc852fdeb1f2b4a07ebfbb5ccf65f3239:/gv.c diff --git a/gv.c b/gv.c index 08d41db..8449047 100644 --- a/gv.c +++ b/gv.c @@ -162,17 +162,38 @@ 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) : ""; - const STRLEN len = strlen(file); -#else - SV *const temp_sv = CopFILESV(PL_curcop); const char *file; STRLEN len; +#ifndef USE_ITHREADS + SV * temp_sv; +#endif + dVAR; PERL_ARGS_ASSERT_NEWGP; + Newxz(gp, 1, GP); + gp->gp_egv = gv; /* allow compiler to reuse gv after this */ +#ifndef PERL_DONT_CREATE_GVSV + gp->gp_sv = newSV(0); +#endif +#ifdef USE_ITHREADS + if (PL_curcop) { + gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ + if (CopFILE(PL_curcop)) { + file = CopFILE(PL_curcop); + len = strlen(file); + } + else goto no_file; + } + else { + no_file: + file = ""; + len = 0; + } +#else + if(PL_curcop) + gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ + temp_sv = CopFILESV(PL_curcop); if (temp_sv) { file = SvPVX(temp_sv); len = SvCUR(temp_sv); @@ -183,18 +204,7 @@ Perl_newGP(pTHX_ GV *const gv) #endif PERL_HASH(hash, file, len); - - Newxz(gp, 1, GP); - -#ifndef PERL_DONT_CREATE_GVSV - gp->gp_sv = newSV(0); -#endif - - gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0; - /* XXX Ideally this cast would be replaced with a change to const char* - in the struct. */ gp->gp_file_hek = share_hek(file, len, hash); - gp->gp_egv = gv; gp->gp_refcnt = 1; return gp; @@ -215,7 +225,7 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) if (oldgv) { if (CvCVGV_RC(cv)) { - SvREFCNT_dec(oldgv); + SvREFCNT_dec_NN(oldgv); CvCVGV_RC_off(cv); } else { @@ -440,7 +450,6 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, static const char file[] = __FILE__; CV *cv, *oldcompcv = NULL; int opnum = 0; - SV *opnumsv; bool ampable = TRUE; /* &{}-able */ COP *oldcurcop = NULL; yy_parser *oldparser = NULL; @@ -526,8 +535,13 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, if (stash) (void)hv_store(stash,name,len,(SV *)gv,0); if (ampable) { +#ifdef DEBUGGING + CV *orig_cv = cv; +#endif CvLVALUE_on(cv); - newATTRSUB_flags( + /* newATTRSUB will free the CV and return NULL if we're still + compiling after a syntax error */ + if ((cv = newATTRSUB_flags( oldsavestack_ix, (OP *)gv, NULL,NULL, coresub_op( @@ -537,21 +551,25 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, code, opnum ), 1 - ); - assert(GvCV(gv) == cv); - if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS - && opnum != OP_UNDEF) - CvLVALUE_off(cv); /* Now *that* was a neat trick. */ + )) != NULL) { + assert(GvCV(gv) == orig_cv); + if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS + && opnum != OP_UNDEF) + CvLVALUE_off(cv); /* Now *that* was a neat trick. */ + } LEAVE; PL_parser = oldparser; PL_curcop = oldcurcop; PL_compcv = oldcompcv; } - opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; - cv_set_call_checker( - cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv - ); - SvREFCNT_dec(opnumsv); + if (cv) { + SV *opnumsv = opnum ? newSVuv((UV)opnum) : (SV *)NULL; + cv_set_call_checker( + cv, Perl_ck_entersub_args_core, opnumsv ? opnumsv : (SV *)cv + ); + SvREFCNT_dec(opnumsv); + } + return gv; } @@ -639,7 +657,6 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, const char *hvname; I32 create = (level >= 0) ? 1 : 0; I32 items; - STRLEN packlen; U32 topgen_cmp; U32 is_utf8 = flags & SVf_UTF8; @@ -688,7 +705,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, } else { /* stale cache entry, junk it and move on */ - SvREFCNT_dec(cand_cv); + SvREFCNT_dec_NN(cand_cv); GvCV_set(topgv, NULL); cand_cv = NULL; GvCVGEN(topgv) = 0; @@ -705,7 +722,6 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, goto have_gv; } - packlen = HvNAMELEN_get(stash); linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ items = AvFILLp(linear_av); /* no +1, to skip over self */ @@ -1010,10 +1026,9 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le return gv; } Perl_croak(aTHX_ - "Can't locate object method \"%"SVf + "Can't locate object method \"%"UTF8f "\" via package \"%"HEKf"\"", - SVfARG(newSVpvn_flags(name, nend - name, - SVs_TEMP | is_utf8)), + UTF8fARG(is_utf8, nend - name, name), HEKfARG(HvNAME_HEK(stash))); } else { @@ -1023,14 +1038,14 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le packnamesv = newSVpvn_flags(origname, nsplit - origname, SVs_TEMP | is_utf8); } else { - packnamesv = sv_2mortal(newSVsv(error_report)); + packnamesv = error_report; } Perl_croak(aTHX_ - "Can't locate object method \"%"SVf"\" via package \"%"SVf"\"" + "Can't locate object method \"%"UTF8f + "\" via package \"%"SVf"\"" " (perhaps you forgot to load \"%"SVf"\"?)", - SVfARG(newSVpvn_flags(name, nend - name, - SVs_TEMP | is_utf8)), + UTF8fARG(is_utf8, nend - name, name), SVfARG(packnamesv), SVfARG(packnamesv)); } } @@ -1122,9 +1137,10 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) && (GvCVGEN(gv) || GvSTASH(gv) != stash) ) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated", + "Use of inherited AUTOLOAD for non-method %"SVf + "::%"UTF8f"() is deprecated", SVfARG(packname), - SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8))); + UTF8fARG(is_utf8, len, name)); if (CvISXSUB(cv)) { /* Instead of forcing the XSUB do another lookup for $AUTOLOAD @@ -1151,7 +1167,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) */ CvSTASH_set(cv, stash); if (SvPOK(cv)) { /* Ouch! */ - SV *tmpsv = newSVpvn_flags(name, len, is_utf8); + SV * const tmpsv = newSVpvn_flags(name, len, is_utf8); STRLEN ulen; const char *proto = CvPROTO(cv); assert(proto); @@ -1165,7 +1181,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) SvTEMP_on(tmpsv); /* Allow theft */ sv_setsv_nomg((SV *)cv, tmpsv); SvTEMP_off(tmpsv); - SvREFCNT_dec(tmpsv); + SvREFCNT_dec_NN(tmpsv); SvLEN(cv) = SvCUR(cv) + 1; SvCUR(cv) = ulen; } @@ -1241,13 +1257,12 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp const char type = varname == '[' ? '$' : '%'; dSP; ENTER; + SAVEFREESV(namesv); if ( flags & 1 ) save_scalar(gv); PUSHSTACKi(PERLSI_MAGIC); Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); POPSTACK; - LEAVE; - SPAGAIN; stash = gv_stashsv(namesv, 0); if (!stash) Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available", @@ -1255,8 +1270,9 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp else if (!gv_fetchmethod(stash, methpv)) Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s", type, varname, SVfARG(namesv), methpv); + LEAVE; } - SvREFCNT_dec(namesv); + else SvREFCNT_dec_NN(namesv); return stash; } @@ -1394,7 +1410,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, const char *name = nambeg; GV *gv = NULL; GV**gvp; - I32 len; + STRLEN len; const char *name_cursor; HV *stash = NULL; const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); @@ -1492,7 +1508,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (!stash) { no_stash: - if (len && isIDFIRST_lazy(name)) { + if (len && isIDFIRST_lazy_if(name, is_utf8)) { bool global = FALSE; switch (len) { @@ -1553,18 +1569,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)) ) { - SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8); /* diag_listed_as: Variable "%s" is not imported%s */ Perl_ck_warner_d( aTHX_ packWARN(WARN_MISC), - "Variable \"%c%"SVf"\" is not imported", + "Variable \"%c%"UTF8f"\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', - SVfARG(namesv)); + UTF8fARG(is_utf8, len, name)); if (GvCVu(*gvp)) Perl_ck_warner_d( aTHX_ packWARN(WARN_MISC), - "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv) + "\t(Did you mean &%"UTF8f" instead?)\n", + UTF8fARG(is_utf8, len, name) ); stash = NULL; } @@ -1580,15 +1596,16 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* By this point we should have a stash and a name */ if (!stash) { - if (add) { + if (add && !PL_in_clean_all) { SV * const err = Perl_mess(aTHX_ - "Global symbol \"%s%"SVf"\" requires explicit package name", + "Global symbol \"%s%"UTF8f + "\" requires explicit package name", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" - : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8))); + : ""), UTF8fARG(is_utf8, len, name)); GV *gv; - if (USE_UTF8_IN_NAMES) + if (is_utf8) SvUTF8_on(err); qerror(err); gv = gv_fetchpvs("::", GV_ADDMULTI, SVt_PVHV); @@ -1618,18 +1635,30 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (add) { GvMULTI_on(gv); gv_init_svtype(gv, sv_type); + /* You reach this path once the typeglob has already been created, + either by the same or a different sigil. If this path didn't + exist, then (say) referencing $! first, and %! second would + mean that %! was not handled correctly. */ if (len == 1 && stash == PL_defstash) { if (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 (sv_type == SVt_PV) { + if (*name == '*' || *name == '#') { + /* diag_listed_as: $* is no longer supported */ + Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, + WARN_SYNTAX), + "$%c is no longer supported", *name); + } + } if (sv_type==SVt_PV || sv_type==SVt_PVGV) { switch (*name) { case '[': require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0); break; +#ifdef PERL_SAWAMPERSAND case '`': PL_sawampersand |= SAWAMPERSAND_LEFT; (void)GvSVn(gv); @@ -1642,6 +1671,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, PL_sawampersand |= SAWAMPERSAND_RIGHT; (void)GvSVn(gv); break; +#endif } } } @@ -1669,8 +1699,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, faking_it = SvOK(gv); if (add & GV_ADDWARN) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly", - SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 ))); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Had to create %"UTF8f" unexpectedly", + UTF8fARG(is_utf8, name_end-nambeg, nambeg)); gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); if ( isIDFIRST_lazy_if(name, is_utf8) @@ -1846,6 +1877,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '&': /* $& */ case '`': /* $` */ case '\'': /* $' */ +#ifdef PERL_SAWAMPERSAND if (!( sv_type == SVt_PVAV || sv_type == SVt_PVHV || @@ -1859,6 +1891,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, ? SAWAMPERSAND_MIDDLE : SAWAMPERSAND_RIGHT; } +#endif goto magicalize; case ':': /* $: */ @@ -1915,10 +1948,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 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); - goto magicalize; - case '\010': /* $^H */ { HV *const hv = GvHVn(gv); @@ -1959,6 +1988,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '>': /* $> */ case '\\': /* $\ */ case '/': /* $/ */ + case '|': /* $| */ case '$': /* $$ */ case '\001': /* $^A */ case '\003': /* $^C */ @@ -1977,7 +2007,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '\014': /* $^L */ sv_setpvs(GvSVn(gv),"\f"); - PL_formfeed = GvSV(gv); break; case ';': /* $; */ sv_setpvs(GvSVn(gv),"\034"); @@ -2008,7 +2037,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, GvSV(gv) && (SvOK(GvSV(gv)) || SvMAGICAL(GvSV(gv))) )) (void)hv_store(stash,name,len,(SV *)gv,0); - else SvREFCNT_dec(gv), gv = NULL; + else SvREFCNT_dec_NN(gv), gv = NULL; } if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); return gv; @@ -2095,10 +2124,10 @@ Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags) { dVAR; PERL_ARGS_ASSERT_NEWGVGEN_FLAGS; + assert(!(flags & ~SVf_UTF8)); - return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::_GEN_%ld", - SVfARG(newSVpvn_flags(pack, strlen(pack), - SVs_TEMP | flags)), + return gv_fetchpv(Perl_form(aTHX_ "%"UTF8f"::_GEN_%ld", + UTF8fARG(flags, strlen(pack), pack), (long)PL_gensym++), GV_ADD, SVt_PVGV); } @@ -2117,7 +2146,7 @@ Perl_gp_ref(pTHX_ GP *gp) /* If the GP they asked for a reference to contains a method cache entry, clear it first, so that we don't infect them with our cached entry */ - SvREFCNT_dec(gp->gp_cv); + SvREFCNT_dec_NN(gp->gp_cv); gp->gp_cv = NULL; gp->gp_cvgen = 0; } @@ -2175,6 +2204,7 @@ Perl_gp_free(pTHX_ GV *gv) Somehow gp->gp_hv can end up pointing at freed garbage. */ if (hv && SvTYPE(hv) == SVt_PVHV) { const HEK *hvname_hek = HvNAME_HEK(hv); + DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek)); if (PL_stashcache && hvname_hek) (void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek), (HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) : HEK_LEN(hvname_hek)), @@ -2218,7 +2248,7 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) for (i = 1; i < NofAMmeth; i++) { CV * const cv = amtp->table[i]; if (cv) { - SvREFCNT_dec(MUTABLE_SV(cv)); + SvREFCNT_dec_NN(MUTABLE_SV(cv)); amtp->table[i] = NULL; } } @@ -2248,7 +2278,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (mg) { const AMT * const amtp = (AMT*)mg->mg_ptr; if (amtp->was_ok_sub == newgen) { - return AMT_OVERLOADED(amtp) ? 1 : 0; + return AMT_AMAGIC(amtp) ? 1 : 0; } sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); } @@ -2261,8 +2291,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) amt.flags = 0; { - int filled = 0, have_ovl = 0; - int i, lim = 1; + int filled = 0; + int i; /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ @@ -2274,7 +2304,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (!gv) { if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0)) - lim = DESTROY_amg; /* Skip overloading entries. */ + goto no_table; } #ifdef PERL_DONT_CREATE_GVSV else if (!sv) { @@ -2288,19 +2318,15 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) else if (SvOK(sv)) { amt.fallback=AMGfallNEVER; filled = 1; - have_ovl = 1; } else { filled = 1; - have_ovl = 1; } - for (i = 1; i < lim; i++) - amt.table[i] = NULL; - for (; i < NofAMmeth; i++) { + for (i = 1; i < NofAMmeth; i++) { 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 char * const cp = AMG_id2name(i); const STRLEN l = PL_AMG_namelens[i]; DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", @@ -2312,10 +2338,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) then we could have created stubs for "(+0" in A and C too. But if B overloads "bool", we may want to use it for numifying instead of C's "+0". */ - if (i >= DESTROY_amg) - gv = Perl_gv_fetchmeth_pvn_autoload(aTHX_ stash, cooky, l, 0, 0); - else /* Autoload taken care of below */ - gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); + gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); cv = 0; if (gv && (cv = GvCV(gv))) { if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){ @@ -2361,8 +2384,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; - if (i < DESTROY_amg) - have_ovl = 1; } else if (gv) { /* Autoloaded... */ cv = MUTABLE_CV(gv); filled = 1; @@ -2371,15 +2392,13 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) } if (filled) { AMT_AMAGIC_on(&amt); - if (have_ovl) - AMT_OVERLOADED_on(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMT)); - return have_ovl; + return TRUE; } } /* Here we have no table: */ - /* no_table: */ + no_table: AMT_AMAGIC_off(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMTS)); @@ -2405,19 +2424,8 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); if (!mg) { 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, 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 */ - if (id == DESTROY_amg) { - GV * const gv = gv_fetchmethod(stash, "DESTROY"); - if (gv) - return GvCV(gv); - } + if (Gv_AMupdate(stash, 0) == -1) return NULL; - } mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); } assert(mg); @@ -2747,16 +2755,9 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table : NULL)) - && ((cv = cvp[off=method+assignshift]) - || (assign && amtp->fallback > AMGfallNEVER && /* fallback to - * usual method */ - ( -#ifdef DEBUGGING - fl = 1, -#endif - cv = cvp[off=method])))) { /* Method for right - * argument found */ - lr=1; + && (cv = cvp[off=method])) { /* Method for right + * argument found */ + lr=1; } else if (((cvp && amtp->fallback > AMGfallNEVER) || (ocvp && oamtp->fallback > AMGfallNEVER)) && !(flags & AMGf_unary)) { @@ -2961,7 +2962,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) { SvRV_set(left, rv_copy); SvSETMAGIC(left); - SvREFCNT_dec(tmpRef); + SvREFCNT_dec_NN(tmpRef); } } @@ -3173,10 +3174,11 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) && *gvp == (SV*)gv) { SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); + const bool imported = !!GvIMPORTED_CV(gv); SvREFCNT(gv) = 0; sv_clear((SV*)gv); SvREFCNT(gv) = 1; - SvFLAGS(gv) = SVt_IV|SVf_ROK; + SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported; SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); SvRV_set(gv, value);