X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/dd38834bfe79dc631f1823deed588b23c6db62d5..1c321dc6ba82145ce5173a7eb3ec132cf550fc22:/gv.c diff --git a/gv.c b/gv.c index 0ec33ef..e4c59b5 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, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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. @@ -80,7 +80,8 @@ Perl_gv_IOadd(pTHX_ register GV *gv) * if it walks like a dirhandle, then let's assume that * this is a dirhandle. */ - const char *fh = PL_op->op_type == OP_READDIR || + 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 || @@ -156,14 +157,42 @@ Perl_gv_const_sv(pTHX_ GV *gv) return SvROK(gv) ? SvRV(gv) : NULL; } +GP * +Perl_newGP(pTHX_ GV *const gv) +{ + GP *gp; + const char *const file + = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : ""; + STRLEN len = strlen(file); + U32 hash; + + PERL_HASH(hash, file, len); + + Newxz(gp, 1, GP); + +#ifndef PERL_DONT_CREATE_GVSV + gp->gv_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; +} + void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { dVAR; - register GP *gp; - const bool doproto = SvTYPE(gv) > SVt_NULL; + const U32 old_type = SvTYPE(gv); + const bool doproto = old_type > SVt_NULL; const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL; SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; + const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; assert (!(proto && has_constant)); @@ -177,12 +206,18 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) case SVt_PVIO: Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", sv_reftype(has_constant, 0)); + default: NOOP; } SvRV_set(gv, NULL); SvROK_off(gv); } - sv_upgrade((SV*)gv, SVt_PVGV); + + if (old_type < SVt_PVGV) { + if (old_type >= SVt_PV) + SvCUR_set(gv, 0); + sv_upgrade((SV*)gv, SVt_PVGV); + } if (SvLEN(gv)) { if (proto) { SvPV_set(gv, NULL); @@ -191,33 +226,26 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) } else Safefree(SvPVX_mutable(gv)); } - Newxz(gp, 1, GP); - GvGP(gv) = gp_ref(gp); -#ifdef PERL_DONT_CREATE_GVSV - GvSV(gv) = NULL; -#else - GvSV(gv) = newSV(0); -#endif - GvLINE(gv) = CopLINE(PL_curcop); - /* XXX Ideally this cast would be replaced with a change to const char* - in the struct. */ - GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) ""; - GvCVGEN(gv) = 0; - GvEGV(gv) = gv; - SvSCREAM_on(gv); + SvIOK_off(gv); + isGV_with_GP_on(gv); + + GvGP(gv) = Perl_newGP(aTHX_ gv); GvSTASH(gv) = stash; if (stash) Perl_sv_add_backref(aTHX_ (SV*)stash, (SV*)gv); - GvNAME(gv) = savepvn(name, len); - GvNAMELEN(gv) = len; + gv_name_set(gv, name, len, GV_ADD); if (multi || doproto) /* doproto means it _was_ mentioned */ GvMULTI_on(gv); if (doproto) { /* Replicate part of newSUB here. */ - SvIOK_off(gv); ENTER; if (has_constant) { /* newCONSTSUB takes ownership of the reference from us. */ GvCV(gv) = newCONSTSUB(stash, name, has_constant); + /* 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. */ + if (exported_constant) + GvIMPORTED_CV_on(gv); } else { /* XXX unsafe for threads if eval_owner isn't held */ (void) start_subparse(0,0); /* Create empty CV in compcv. */ @@ -292,6 +320,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) GV** gvp; CV* cv; const char *hvname; + HV* lastchance = NULL; /* UNIVERSAL methods should be callable without a stash */ if (!stash) { @@ -351,7 +380,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "ISA", 3, TRUE); SvREFCNT_dec(GvAV(gv)); - GvAV(gv) = (AV*)SvREFCNT_inc(av); + GvAV(gv) = (AV*)SvREFCNT_inc_simple(av); } } } @@ -366,7 +395,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", - sv, hvname); + SVfARG(sv), hvname); continue; } gv = gv_fetchmeth(basestash, name, len, @@ -379,7 +408,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* if at top level, try UNIVERSAL */ if (level == 0 || level == -1) { - HV* const lastchance = gv_stashpvs("UNIVERSAL", FALSE); + lastchance = gv_stashpvs("UNIVERSAL", FALSE); if (lastchance) { if ((gv = gv_fetchmeth(lastchance, name, len, @@ -508,7 +537,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) --nsplit; if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ - SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", + SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE); @@ -569,7 +598,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) GV* vargv; SV* varsv; const char *packname = ""; - STRLEN packname_len; + STRLEN packname_len = 0; if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) return NULL; @@ -633,32 +662,47 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) sv_setpvn(varsv, packname, packname_len); sv_catpvs(varsv, "::"); sv_catpvn(varsv, name, len); - SvTAINTED_off(varsv); return gv; } -/* The "gv" parameter should be the glob known to Perl code as *! - * The scalar must already have been magicalized. + +/* require_tie_mod() internal routine for requiring a module + * that implements the logic of automatical ties like %! and %- + * + * The "gv" parameter should be the glob. + * "varpv" holds the name of the var, used for error messages + * "namesv" holds the module name + * "methpv" holds the method name to test for to check that things + * are working reasonably close to as expected + * "flags" if flag & 1 then save the scalar before loading. + * For the protection of $! to work (it is set by this routine) + * the sv slot must already be magicalized. */ -STATIC void -S_require_errno(pTHX_ GV *gv) +STATIC HV* +S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags) { dVAR; - HV* stash = gv_stashpvs("Errno", FALSE); - - if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { + HV* stash = gv_stashsv(namesv, FALSE); + + if (!stash || !(gv_fetchmethod(stash, methpv))) { + SV *module = newSVsv(namesv); dSP; PUTBACK; ENTER; - save_scalar(gv); /* keep the value of $! */ - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvs("Errno"), NULL); + if ( flags & 1 ) + save_scalar(gv); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); LEAVE; SPAGAIN; - stash = gv_stashpvs("Errno", FALSE); - if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) - Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available"); + stash = gv_stashsv(namesv, FALSE); + if (!stash) + Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" is not available", + varpv, module); + else if (!gv_fetchmethod(stash, methpv)) + Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" does not support method %s", + varpv, module, methpv); } + return stash; } /* @@ -793,7 +837,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, char smallbuf[128]; char *tmpbuf; - if (len + 3 < sizeof (smallbuf)) + if (len + 3 < (I32)sizeof (smallbuf)) tmpbuf = smallbuf; else Newx(tmpbuf, len+3, char); @@ -890,7 +934,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, *gvp == (GV*)&PL_sv_undef || SvTYPE(*gvp) != SVt_PVGV) { - stash = 0; + stash = NULL; } else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || @@ -902,7 +946,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, name); if (GvCVu(*gvp)) Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); - stash = 0; + stash = NULL; } } } @@ -923,10 +967,16 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" : ""), name); + GV *gv; if (USE_UTF8_IN_NAMES) SvUTF8_on(err); qerror(err); - stash = GvHV(gv_fetchpvn_flags("::", 8, GV_ADDMULTI, SVt_PVHV)); + gv = gv_fetchpvn_flags("::", 8, GV_ADDMULTI, SVt_PVHV); + if(!gv) { + /* symbol table under destruction */ + return NULL; + } + stash = GvHV(gv); } else return NULL; @@ -943,8 +993,14 @@ 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 (*name=='!' && sv_type == SVt_PVHV && len==1) - require_errno(gv); + if (sv_type == SVt_PVHV && len == 1 ) { + if (*name == '!') + require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); + else + if (*name == '-' || *name == '+') + require_tie_mod(gv, name, newSVpvs("re::Tie::Hash::NamedCapture"), "FETCH", 0); + + } } return gv; } else if (no_init) { @@ -968,7 +1024,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (len > 1) { #ifndef EBCDIC if (*name > 'V' ) { - /*EMPTY*/; + NOOP; /* Nothing else to do. The compiler will probably turn the switch statement into a branch table. Make sure we avoid even that small overhead for @@ -982,6 +1038,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "RGV")) { IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; } + else if (strEQ(name2, "RGVOUT")) { + GvMULTI_on(gv); + } break; case 'E': if (strnEQ(name2, "XPORT", 5)) @@ -1064,6 +1123,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, goto ro_magicalize; if (strEQ(name2, "TF8LOCALE")) goto ro_magicalize; + if (strEQ(name2, "TF8CACHE")) + goto magicalize; break; case '\027': /* $^WARNING_BITS */ if (strEQ(name2, "ARNING_BITS")) @@ -1118,25 +1179,45 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, goto magicalize; case '!': - - /* If %! has been used, automatically load Errno.pm. - The require will itself set errno, so in order to - preserve its value we have to set up the magic - now (rather than going to magicalize) - */ + GvMULTI_on(gv); + /* If %! has been used, automatically load Errno.pm. */ sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); + /* magicalization must be done before require_tie_mod is called */ if (sv_type == SVt_PVHV) - require_errno(gv); + require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); break; case '-': - { - AV* const av = GvAVn(gv); - sv_magic((SV*)av, NULL, PERL_MAGIC_regdata, NULL, 0); - SvREADONLY_on(av); - goto magicalize; + case '+': + GvMULTI_on(gv); /* no used once warnings here */ + { + bool plus = (*name == '+'); + SV *stashname = newSVpvs("re::Tie::Hash::NamedCapture"); + AV* const av = GvAVn(gv); + HV *const hv = GvHVn(gv); + HV *const hv_tie = newHV(); + SV *tie = newRV_noinc((SV*)hv_tie); + + sv_bless(tie, gv_stashsv(stashname,1)); + hv_magic(hv, (GV*)tie, PERL_MAGIC_tied); + sv_magic((SV*)av, (plus ? (SV*)av : NULL), PERL_MAGIC_regdata, NULL, 0); + sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len); + + if (plus) + SvREADONLY_on(GvSVn(gv)); + else + Perl_hv_store(aTHX_ hv_tie, STR_WITH_LEN("all"), newSViv(1), 0); + + SvREADONLY_on(hv); + SvREADONLY_on(tie); + SvREADONLY_on(av); + + if (sv_type == SVt_PVHV) + require_tie_mod(gv, name, stashname, "FETCH", 0); + + break; } case '*': case '#': @@ -1148,13 +1229,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); goto magicalize; - case '+': - { - AV* const av = GvAVn(gv); - sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0); - SvREADONLY_on(av); - /* FALL THROUGH */ - } + case '\010': /* $^H */ + { + HV *const hv = GvHVn(gv); + hv_magic(hv, NULL, PERL_MAGIC_hints); + } + goto magicalize; case '\023': /* $^S */ case '1': case '2': @@ -1186,7 +1266,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '\004': /* $^D */ case '\005': /* $^E */ case '\006': /* $^F */ - case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ case '\016': /* $^N */ case '\017': /* $^O */ @@ -1285,7 +1364,7 @@ Perl_newIO(pTHX) } void -Perl_gv_check(pTHX_ HV *stash) +Perl_gv_check(pTHX_ const HV *stash) { dVAR; register I32 i; @@ -1341,7 +1420,7 @@ Perl_newGVgen(pTHX_ const char *pack) { dVAR; return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), - TRUE, SVt_PVGV); + GV_ADD, SVt_PVGV); } /* hopefully this is only called on local symbol table entries */ @@ -1351,7 +1430,7 @@ Perl_gp_ref(pTHX_ GP *gp) { dVAR; if (!gp) - return (GP*)NULL; + return NULL; gp->gp_refcnt++; if (gp->gp_cv) { if (gp->gp_cvgen) { @@ -1374,7 +1453,7 @@ Perl_gp_free(pTHX_ GV *gv) dVAR; GP* gp; - if (!gv || !(gp = GvGP(gv))) + if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) return; if (gp->gp_refcnt == 0) { if (ckWARN_d(WARN_INTERNAL)) @@ -1394,8 +1473,10 @@ Perl_gp_free(pTHX_ GV *gv) return; } - if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv); - if (gp->gp_av) SvREFCNT_dec(gp->gp_av); + 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) { @@ -1405,9 +1486,9 @@ Perl_gp_free(pTHX_ GV *gv) G_DISCARD); SvREFCNT_dec(gp->gp_hv); } - if (gp->gp_io) SvREFCNT_dec(gp->gp_io); - if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv); - if (gp->gp_form) SvREFCNT_dec(gp->gp_form); + SvREFCNT_dec(gp->gp_io); + SvREFCNT_dec(gp->gp_cv); + SvREFCNT_dec(gp->gp_form); Safefree(gp); GvGP(gv) = 0; @@ -1423,7 +1504,7 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) int i; for (i = 1; i < NofAMmeth; i++) { CV * const cv = amtp->table[i]; - if (cv != NULL) { + if (cv) { SvREFCNT_dec((SV *) cv); amtp->table[i] = NULL; } @@ -1439,13 +1520,16 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) { dVAR; MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); - AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; AMT amt; - if (mg && amtp->was_ok_am == PL_amagic_generation - && amtp->was_ok_sub == PL_sub_generation) - return (bool)AMT_OVERLOADED(amtp); - sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); + if (mg) { + const AMT * const amtp = (AMT*)mg->mg_ptr; + if (amtp->was_ok_am == PL_amagic_generation + && amtp->was_ok_sub == PL_sub_generation) { + return (bool)AMT_OVERLOADED(amtp); + } + sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); + } DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); @@ -1470,7 +1554,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) lim = DESTROY_amg; /* Skip overloading entries. */ #ifdef PERL_DONT_CREATE_GVSV else if (!sv) { - /*EMPTY*/; /* Equivalent to !SvTRUE and !SvOK */ + NOOP; /* Equivalent to !SvTRUE and !SvOK */ } #endif else if (SvTRUE(sv)) @@ -1512,7 +1596,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ "\" for overloaded \"%s\" in package \"%.256s\"\n", - GvSV(gv), cp, hvname) ); + (void*)GvSV(gv), cp, hvname) ); if (!gvsv || !SvPOK(gvsv) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv), FALSE))) @@ -1537,7 +1621,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) cv = (CV*)gv; filled = 1; } - amt.table[i]=(CV*)SvREFCNT_inc(cv); + amt.table[i]=(CV*)SvREFCNT_inc_simple(cv); } if (filled) { AMT_AMAGIC_on(&amt); @@ -1572,6 +1656,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) Gv_AMupdate(stash); mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); } + assert(mg); amtp = (AMT*)mg->mg_ptr; if ( amtp->was_ok_am != PL_amagic_generation || amtp->was_ok_sub != PL_sub_generation ) @@ -1616,7 +1701,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table - : (CV **) NULL)) + : NULL)) && ((cv = cvp[off=method+assignshift]) || (assign && amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ @@ -1676,6 +1761,12 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) */ SV* const newref = newSVsv(tmpRef); SvOBJECT_on(newref); + /* As a bit of a source compatibility hack, SvAMAGIC() and + friends dereference an RV, to behave the same was as when + overloading was stored on the reference, not the referant. + Hence we can't use SvAMAGIC_on() + */ + SvFLAGS(newref) |= SVf_AMAGIC; SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef))); return newref; } @@ -1734,7 +1825,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table - : (CV **) NULL)) + : NULL)) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; @@ -1786,6 +1877,9 @@ 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) { + /* Skip generating the "no method found" message. */ + return NULL; } else { SV *msg; if (off==-1) off=method; @@ -1810,7 +1904,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (amtp && amtp->fallback >= AMGfallYES) { DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); } else { - Perl_croak(aTHX_ "%"SVf, msg); + Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); } return NULL; } @@ -1869,7 +1963,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) CATCH_SET(TRUE); Zero(&myop, 1, BINOP); myop.op_last = (OP *) &myop; - myop.op_next = Nullop; + myop.op_next = NULL; myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; PUSHSTACKi(PERLSI_OVERLOAD); @@ -1978,6 +2072,7 @@ pointers returned by SvPV. bool Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) { + PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(flags); if (len > 1) { @@ -2096,6 +2191,26 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) return FALSE; } +void +Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) +{ + dVAR; + U32 hash; + + assert(name); + PERL_UNUSED_ARG(flags); + + if (len > I32_MAX) + Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len); + + if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { + unshare_hek(GvNAME_HEK(gv)); + } + + PERL_HASH(hash, name, len); + GvNAME_HEK(gv) = share_hek(name, len, hash); +} + /* * Local variables: * c-indentation-style: bsd