X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c5540e1cf88a13d2e3c4bd0f68265301c762bc26..62698e047b935ed44827dc9c8a013c1c41a9697d:/gv.c diff --git a/gv.c b/gv.c index 91d88db..01ed1f5 100644 --- a/gv.c +++ b/gv.c @@ -37,6 +37,7 @@ Perl stores its global variables. #include "perl.h" #include "overload.c" #include "keywords.h" +#include "feature.h" static const char S_autoload[] = "AUTOLOAD"; static const STRLEN S_autolen = sizeof(S_autoload)-1; @@ -61,12 +62,12 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) */ what = OP_IS_DIRHOP(PL_op->op_type) ? "dirhandle" : "filehandle"; - /* diag_listed_as: Bad symbol for filehandle */ } else if (type == SVt_PVHV) { what = "hash"; } else { what = type == SVt_PVAV ? "array" : "scalar"; } + /* diag_listed_as: Bad symbol for filehandle */ Perl_croak(aTHX_ "Bad symbol for %s", what); } @@ -82,6 +83,9 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) if (!*where) *where = newSV_type(type); + if (type == SVt_PVAV && GvNAMELEN(gv) == 3 + && strnEQ(GvNAME(gv), "ISA", 3)) + sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); return gv; } @@ -203,6 +207,7 @@ void Perl_cvgv_set(pTHX_ CV* cv, GV* gv) { GV * const oldgv = CvGV(cv); + HEK *hek; PERL_ARGS_ASSERT_CVGV_SET; if (oldgv == gv) @@ -217,8 +222,9 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); } } + else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek); - SvANY(cv)->xcv_gv = gv; + SvANY(cv)->xcv_gv_u.xcv_gv = gv; assert(!CvCVGV_RC(cv)); if (!gv) @@ -316,8 +322,11 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag dVAR; const U32 old_type = SvTYPE(gv); const bool doproto = old_type > SVt_NULL; - char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; + char * const proto = (doproto && SvPOK(gv)) + ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv)) + : NULL; const STRLEN protolen = proto ? SvCUR(gv) : 0; + const U32 proto_utf8 = proto ? SvUTF8(gv) : 0; SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; @@ -364,43 +373,28 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 )); if (flags & GV_ADDMULTI || doproto) /* doproto means it */ GvMULTI_on(gv); /* _was_ mentioned */ - if (doproto) { /* Replicate part of newSUB here. */ + if (doproto) { 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. */ - cv = newCONSTSUB_flags(stash, (name0 ? name0 : name), flags, has_constant); + cv = newCONSTSUB_flags(stash, name, len, flags, 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. */ if (exported_constant) GvIMPORTED_CV_on(gv); + CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */ } else { - (void) start_subparse(0,0); /* Create empty CV in compcv. */ - cv = PL_compcv; - GvCV_set(gv,cv); + cv = newSTUB(gv,1); } - LEAVE; - - mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */ - CvGV_set(cv, gv); - CvFILE_set_from_cop(cv, PL_curcop); - CvSTASH_set(cv, PL_curstash); if (proto) { sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, SV_HAS_TRAILING_NUL); + if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); } } } @@ -440,45 +434,53 @@ static void core_xsub(pTHX_ CV* cv); static GV * S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, - const char * const name, const STRLEN len, - const char * const fullname, STRLEN const fullen) + const char * const name, const STRLEN len) { const int code = keyword(name, len, 1); static const char file[] = __FILE__; - CV *cv, *oldcompcv; + CV *cv, *oldcompcv = NULL; int opnum = 0; SV *opnumsv; bool ampable = TRUE; /* &{}-able */ - COP *oldcurcop; - yy_parser *oldparser; - I32 oldsavestack_ix; + COP *oldcurcop = NULL; + yy_parser *oldparser = NULL; + I32 oldsavestack_ix = 0; assert(gv || stash); assert(name); - assert(stash || fullname); - if (!fullname && !HvENAME(stash)) return NULL; /* pathological case - that would require - inlining newATTRSUB */ - if (code >= 0) return NULL; /* not overridable */ - switch (-code) { + if (!code) return NULL; /* Not a keyword */ + switch (code < 0 ? -code : code) { /* no support for \&CORE::infix; - no support for funcs that take labels, as their parsing is - weird */ - case KEY_and: case KEY_cmp: case KEY_CORE: case KEY_dump: - case KEY_eq: case KEY_ge: - case KEY_gt: case KEY_le: case KEY_lt: case KEY_ne: - case KEY_or: case KEY_x: case KEY_xor: + no support for funcs that do not parse like funcs */ + case KEY___DATA__: case KEY___END__: case KEY_and: case KEY_AUTOLOAD: + case KEY_BEGIN : case KEY_CHECK : case KEY_cmp: case KEY_CORE : + case KEY_default : case KEY_DESTROY: + case KEY_do : case KEY_dump : case KEY_else : case KEY_elsif : + case KEY_END : case KEY_eq : case KEY_eval : + case KEY_for : case KEY_foreach: case KEY_format: case KEY_ge : + case KEY_given : case KEY_goto : case KEY_grep : + case KEY_gt : case KEY_if: case KEY_INIT: case KEY_last: case KEY_le: + case KEY_local: case KEY_lt: case KEY_m : case KEY_map : case KEY_my: + case KEY_ne : case KEY_next : case KEY_no: case KEY_or: case KEY_our: + case KEY_package: case KEY_print: case KEY_printf: + case KEY_q : case KEY_qq : case KEY_qr : case KEY_qw : + case KEY_qx : case KEY_redo : case KEY_require: case KEY_return: + case KEY_s : case KEY_say : case KEY_sort : + case KEY_state: case KEY_sub : + case KEY_tr : case KEY_UNITCHECK: case KEY_unless: + case KEY_until: case KEY_use : case KEY_when : case KEY_while : + case KEY_x : case KEY_xor : case KEY_y : return NULL; case KEY_chdir: - case KEY_chomp: case KEY_chop: - case KEY_each: case KEY_eof: case KEY_exec: + case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete: + case KEY_each : case KEY_eof : case KEY_exec : case KEY_exists: case KEY_keys: case KEY_lstat: case KEY_pop: case KEY_push: case KEY_shift: - case KEY_splice: + case KEY_splice: case KEY_split: case KEY_stat: case KEY_system: case KEY_truncate: case KEY_unlink: @@ -490,6 +492,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, gv = (GV *)newSV(0); gv_init(gv, stash, name, len, TRUE); } + GvMULTI_on(gv); if (ampable) { ENTER; oldcurcop = PL_curcop; @@ -520,29 +523,24 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, it this order as we need an op number before calling new ATTRSUB. */ (void)core_prototype((SV *)cv, name, code, &opnum); - if (stash && (fullname || !fullen)) + if (stash) (void)hv_store(stash,name,len,(SV *)gv,0); if (ampable) { - SV *tmpstr; CvLVALUE_on(cv); - if (!fullname) { - tmpstr = newSVhek(HvENAME_HEK(stash)); - sv_catpvs(tmpstr, "::"); - sv_catpvn(tmpstr,name,len); - } - else tmpstr = newSVpvn_share(fullname,fullen,0); - newATTRSUB(oldsavestack_ix, - newSVOP(OP_CONST, 0, tmpstr), + newATTRSUB_flags( + oldsavestack_ix, (OP *)gv, NULL,NULL, coresub_op( opnum ? newSVuv((UV)opnum) : newSVpvn(name,len), code, opnum - ) + ), + 1 ); assert(GvCV(gv) == cv); - if (opnum != OP_VEC && opnum != OP_SUBSTR) + 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; @@ -665,7 +663,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; /* check locally for a real method or a cache entry */ - gvp = (GV**)hv_fetch(stash, name, len, create); + gvp = (GV**)hv_fetch(stash, name, is_utf8 ? -(I32)len : (I32)len, create); if(gvp) { topgv = *gvp; have_gv: @@ -691,15 +689,18 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, } else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4 && strnEQ(hvname, "CORE", 4) - && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1)) + && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len)) goto have_gv; } packlen = HvNAMELEN_get(stash); - if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { + if ((packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) + || (packlen == 5 && strEQ(hvname, "SUPER"))) { HV* basestash; - packlen -= 7; - basestash = gv_stashpvn(hvname, packlen, GV_ADD); + basestash = packlen == 5 + ? PL_defstash + : gv_stashpvn(hvname, packlen - 7, + GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0)); linear_av = mro_get_linear_isa(basestash); } else { @@ -714,20 +715,22 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, cstash = gv_stashsv(linear_sv, 0); if (!cstash) { - Perl_ck_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 @%"HEKf"::ISA", + SVfARG(linear_sv), + HEKfARG(HvNAME_HEK(stash))); continue; } assert(cstash); - gvp = (GV**)hv_fetch(cstash, name, len, 0); + gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0); if (!gvp) { if (len > 1 && HvNAMELEN_get(cstash) == 4) { const char *hvname = HvNAME(cstash); assert(hvname); if (strnEQ(hvname, "CORE", 4) && (candidate = - S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0) + S_maybe_add_coresub(aTHX_ cstash,NULL,name,len) )) goto have_candidate; } @@ -839,7 +842,7 @@ Currently, the only significant value for C is SVf_UTF8. GV * Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags) { - GV *gv = gv_fetchmeth_pvn(stash, name, len, level, 0); + GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags); PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD; @@ -859,7 +862,8 @@ Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I3 /* Have an autoload */ if (level < 0) /* Cannot do without a stub */ gv_fetchmeth_pvn(stash, name, len, 0, flags); - gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); + gvp = (GV**)hv_fetch(stash, name, + (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0)); if (!gvp) return NULL; return *gvp; @@ -905,25 +909,21 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags) PERL_ARGS_ASSERT_GV_GET_SUPER_PKG; - stash = gv_stashpvn(name, namelen, 0); + stash = gv_stashpvn(name, namelen, flags); if(stash) return stash; /* If we must create it, give it an @ISA array containing the real package this SUPER is for, so that it's tied into the cache invalidation code correctly */ - stash = gv_stashpvn(name, namelen, GV_ADD); + stash = gv_stashpvn(name, namelen, GV_ADD | flags); gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); gv = *gvp; - gv_init_pvn(gv, stash, "ISA", 3, GV_ADDMULTI|(flags & SVf_UTF8)); + gv_init(gv, stash, "ISA", 3, TRUE); superisa = GvAVn(gv); GvMULTI_on(gv); sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); -#ifdef USE_ITHREADS - av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0)); -#else av_push(superisa, newSVhek(CopSTASH(PL_curcop) - ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL)); -#endif + ? HvENAME_HEK(CopSTASH(PL_curcop)) : NULL)); return stash; } @@ -961,7 +961,7 @@ GV * Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags) { dVAR; - register const char *nend; + const char *nend; const char *nsplit = NULL; GV* gv; HV* ostash = stash; @@ -969,6 +969,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le SV *const error_report = MUTABLE_SV(stash); const U32 autoload = flags & GV_AUTOLOAD; const U32 do_croak = flags & GV_CROAK; + const U32 is_utf8 = flags & SVf_UTF8; PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS; @@ -993,28 +994,30 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le if (nsplit) { if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ - SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", - CopSTASHPV(PL_curcop))); + SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ + "%"HEKf"::SUPER", + HEKfARG(HvENAME_HEK((HV*)CopSTASH(PL_curcop))) + )); /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr)); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", - origname, HvNAME_get(stash), name) ); + origname, HvENAME_get(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ - stash = gv_stashpvn(origname, nsplit - origname, 0); + stash = gv_stashpvn(origname, nsplit - origname, is_utf8); /* however, explicit calls to Pkg::SUPER::method may happen, and may require autovivification to work */ if (!stash && (nsplit - origname) >= 7 && strnEQ(nsplit - 7, "::SUPER", 7) && - gv_stashpvn(origname, nsplit - origname - 7, 0)) + gv_stashpvn(origname, nsplit - origname - 7, is_utf8)) stash = gv_get_super_pkg(origname, nsplit - origname, flags); } ostash = stash; } - gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0); + gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = MUTABLE_GV(&PL_sv_yes); @@ -1036,29 +1039,33 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le HV_FETCH_ISEXISTS, NULL, 0) ) { require_pv("IO/File.pm"); - gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0); + gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags); if (gv) return gv; } Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%.*s\"", - name, (int)HvNAMELEN_get(stash), HvNAME_get(stash)); + "Can't locate object method \"%"SVf + "\" via package \"%"HEKf"\"", + SVfARG(newSVpvn_flags(name, nend - name, + SVs_TEMP | is_utf8)), + HEKfARG(HvNAME_HEK(stash))); } else { - STRLEN packlen; - const char *packname; + SV* packnamesv; if (nsplit) { - packlen = nsplit - origname; - packname = origname; + packnamesv = newSVpvn_flags(origname, nsplit - origname, + SVs_TEMP | is_utf8); } else { - packname = SvPV_const(error_report, packlen); + packnamesv = sv_2mortal(newSVsv(error_report)); } Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%.*s\"" - " (perhaps you forgot to load \"%.*s\"?)", - name, (int)packlen, packname, (int)packlen, packname); + "Can't locate object method \"%"SVf"\" via package \"%"SVf"\"" + " (perhaps you forgot to load \"%"SVf"\"?)", + SVfARG(newSVpvn_flags(name, nend - name, + SVs_TEMP | is_utf8)), + SVfARG(packnamesv), SVfARG(packnamesv)); } } } @@ -1148,21 +1155,61 @@ 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 %s::%.*s() is deprecated", - SvPV_nolen(packname), (int)len, name); + "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated", + SVfARG(packname), + SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8))); if (CvISXSUB(cv)) { - /* rather than lookup/init $AUTOLOAD here - * only to have the XSUB do another lookup for $AUTOLOAD - * and split that value on the last '::', - * pass along the same data via some unused fields in the CV + /* Instead of forcing the XSUB do another lookup for $AUTOLOAD + * and split that value on the last '::', pass along the same data + * via the SvPVX field in the CV, and the stash in CvSTASH. + * + * Due to an unfortunate accident of history, the SvPVX field + * serves two purposes. It is also used for the subroutine's pro- + * type. Since SvPVX has been documented as returning the sub name + * for a long time, but not as returning the prototype, we have + * to preserve the SvPVX AUTOLOAD behaviour and put the prototype + * elsewhere. + * + * We put the prototype in the same allocated buffer, but after + * the sub name. The SvPOK flag indicates the presence of a proto- + * type. The CvAUTOLOAD flag indicates the presence of a sub name. + * If both flags are on, then SvLEN is used to indicate the end of + * the prototype (artificially lower than what is actually allo- + * cated), at the risk of having to reallocate a few bytes unneces- + * sarily--but that should happen very rarely, if ever. + * + * We use SvUTF8 for both prototypes and sub names, so if one is + * UTF8, the other must be upgraded. */ CvSTASH_set(cv, stash); - SvPV_set(cv, (char *)name); /* cast to lose constness warning */ - SvCUR_set(cv, len); - if (is_utf8) + if (SvPOK(cv)) { /* Ouch! */ + SV *tmpsv = newSVpvn_flags(name, len, is_utf8); + STRLEN ulen; + const char *proto = CvPROTO(cv); + assert(proto); + if (SvUTF8(cv)) + sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2); + ulen = SvCUR(tmpsv); + SvCUR(tmpsv)++; /* include null in string */ + sv_catpvn_flags( + tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv) + ); + SvTEMP_on(tmpsv); /* Allow theft */ + sv_setsv_nomg((SV *)cv, tmpsv); + SvTEMP_off(tmpsv); + SvREFCNT_dec(tmpsv); + SvLEN(cv) = SvCUR(cv) + 1; + SvCUR(cv) = ulen; + } + else { + sv_setpvn((SV *)cv, name, len); + SvPOK_off(cv); + if (is_utf8) SvUTF8_on(cv); - return gv; + else SvUTF8_off(cv); + } + CvAUTOLOAD_on(cv); } /* @@ -1183,11 +1230,16 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) } LEAVE; varsv = GvSVn(vargv); + SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */ + /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */ sv_setsv(varsv, packname); sv_catpvs(varsv, "::"); /* 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); + sv_catpvn_flags( + varsv, name, len, + SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES) + ); if (is_utf8) SvUTF8_on(varsv); return gv; @@ -1214,11 +1266,12 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; - if (!stash || !(gv_fetchmethod(stash, methpv))) { + if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) { SV *module = newSVsv(namesv); char varname = *varpv; /* varpv might be clobbered by load_module, so save it. For the moment it's always a single char. */ + const char type = varname == '[' ? '$' : '%'; dSP; ENTER; if ( flags & 1 ) @@ -1230,11 +1283,11 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp SPAGAIN; stash = gv_stashsv(namesv, 0); if (!stash) - Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available", - varname, SVfARG(namesv)); + Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available", + type, varname, SVfARG(namesv)); else if (!gv_fetchmethod(stash, methpv)) - Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s", - varname, SVfARG(namesv), methpv); + Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s", + type, varname, SVfARG(namesv), methpv); } SvREFCNT_dec(namesv); return stash; @@ -1266,6 +1319,16 @@ created if it does not already exist. If the package does not exist and C is 0 (or any other setting that does not create packages) then NULL is returned. +Flags may be one of: + + GV_ADD + SVf_UTF8 + GV_NOADD_NOINIT + GV_NOINIT + GV_NOEXPAND + GV_ADDMG + +The most important of which are probably GV_ADD and SVf_UTF8. =cut */ @@ -1356,28 +1419,16 @@ S_gv_magicalize_isa(pTHX_ GV *gv) 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) { dVAR; - register const char *name = nambeg; - register GV *gv = NULL; + const char *name = nambeg; + GV *gv = NULL; GV**gvp; I32 len; - register const char *name_cursor; + const char *name_cursor; HV *stash = NULL; const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); const I32 no_expand = flags & GV_NOEXPAND; @@ -1396,7 +1447,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, goto no_stash; } - if (full_len > 2 && *name == '*' && isALPHA(name[1])) { + if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) { /* accidental stringify on a GV? */ name++; } @@ -1535,17 +1586,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%s\" is not imported", + "Variable \"%c%"SVf"\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', - name); + SVfARG(namesv)); if (GvCVu(*gvp)) Perl_ck_warner_d( aTHX_ packWARN(WARN_MISC), - "\t(Did you mean &%s instead?)\n", name + "\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv) ); stash = NULL; } @@ -1563,11 +1615,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (!stash) { if (add) { SV * const err = Perl_mess(aTHX_ - "Global symbol \"%s%s\" requires explicit package name", + "Global symbol \"%s%"SVf"\" requires explicit package name", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" - : ""), name); + : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8))); GV *gv; if (USE_UTF8_IN_NAMES) SvUTF8_on(err); @@ -1599,12 +1651,32 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (add) { GvMULTI_on(gv); gv_init_svtype(gv, sv_type); - if (len == 1 && stash == PL_defstash - && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) { + 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); + } + if (sv_type==SVt_PV || sv_type==SVt_PVGV) { + switch (*name) { + case '[': + require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0); + break; + case '`': + PL_sawampersand |= SAWAMPERSAND_LEFT; + (void)GvSVn(gv); + break; + case '&': + PL_sawampersand |= SAWAMPERSAND_MIDDLE; + (void)GvSVn(gv); + break; + case '\'': + PL_sawampersand |= SAWAMPERSAND_RIGHT; + (void)GvSVn(gv); + break; + } + } } else if (len == 3 && sv_type == SVt_PVAV && strnEQ(name, "ISA", 3) @@ -1630,16 +1702,17 @@ 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 %s unexpectedly", nambeg); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly", + SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 ))); gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); - if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) - : (PL_dowarn & G_WARN_ON ) ) ) + if ( isIDFIRST_lazy_if(name, is_utf8) + && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) GvMULTI_on(gv) ; /* set up magic where warranted */ if (stash != PL_defstash) { /* not the main stash */ - /* We only have to check for four names here: EXPORT, ISA, OVERLOAD + /* We only have to check for three names here: EXPORT, ISA and VERSION. All the others apply only to the main stash or to CORE (which is checked right after this). */ if (len > 2) { @@ -1653,10 +1726,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 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); @@ -1670,11 +1739,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { /* Avoid null warning: */ const char * const stashname = HvNAME(stash); assert(stashname); - if (strnEQ(stashname, "CORE", 4) - && S_maybe_add_coresub(aTHX_ - addmg ? stash : 0, gv, name, len, nambeg, full_len - )) - addmg = 0; + if (strnEQ(stashname, "CORE", 4)) + S_maybe_add_coresub(aTHX_ 0, gv, name, len); } } else if (len > 1) { @@ -1707,11 +1773,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, gv_magicalize_isa(gv); } break; - case 'O': - if (strEQ(name2, "VERLOAD")) { - gv_magicalize_overload(gv); - } - break; case 'S': if (strEQ(name2, "IG")) { HV *hv; @@ -1814,14 +1875,19 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '&': /* $& */ case '`': /* $` */ case '\'': /* $' */ - if ( + if (!( sv_type == SVt_PVAV || sv_type == SVt_PVHV || sv_type == SVt_PVCV || sv_type == SVt_PVFM || sv_type == SVt_PVIO - ) { break; } - PL_sawampersand = TRUE; + )) { PL_sawampersand |= + (*name == '`') + ? SAWAMPERSAND_LEFT + : (*name == '&') + ? SAWAMPERSAND_MIDDLE + : SAWAMPERSAND_RIGHT; + } goto magicalize; case ':': /* $: */ @@ -1842,7 +1908,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* magicalization must be done before require_tie_mod is called */ if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + { + if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0); + addmg = 0; require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); + } break; case '-': /* $- */ @@ -1859,13 +1929,18 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, SvREADONLY_on(av); if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + { + if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0); + addmg = 0; require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); + } break; } case '*': /* $* */ case '#': /* $# */ if (sv_type == SVt_PV) + /* diag_listed_as: $* is no longer supported */ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "$%c is no longer supported", *name); break; @@ -1879,6 +1954,15 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, hv_magic(hv, NULL, PERL_MAGIC_hints); } goto magicalize; + case '[': /* $[ */ + if ((sv_type == SVt_PV || sv_type == SVt_PVGV) + && FEATURE_ARYBASE_IS_ENABLED) { + if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0); + require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0); + addmg = 0; + } + else goto magicalize; + break; case '\023': /* $^S */ ro_magicalize: SvREADONLY_on(GvSVn(gv)); @@ -1893,7 +1977,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '7': /* $7 */ case '8': /* $8 */ case '9': /* $9 */ - case '[': /* $[ */ case '^': /* $^ */ case '~': /* $~ */ case '=': /* $= */ @@ -1923,7 +2006,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '\014': /* $^L */ sv_setpvs(GvSVn(gv),"\f"); - PL_formfeed = GvSVn(gv); + PL_formfeed = GvSV(gv); break; case ';': /* $; */ sv_setpvs(GvSVn(gv),"\034"); @@ -1963,25 +2046,21 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, void Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) { - SV *name; + const char *name; const HV * const hv = GvSTASH(gv); PERL_ARGS_ASSERT_GV_FULLNAME4; - if (!hv) { - SvOK_off(sv); - return; - } sv_setpv(sv, prefix ? prefix : ""); - name = HvNAME_get(hv) - ? sv_2mortal(newSVhek(HvNAME_HEK(hv))) - : newSVpvn_flags( "__ANON__", 8, SVs_TEMP ); - - if (keepmain || strnNE(SvPV_nolen(name), "main", SvCUR(name))) { - sv_catsv(sv,name); + if (hv && (name = HvNAME(hv))) { + const STRLEN len = HvNAMELEN(hv); + if (keepmain || strnNE(name, "main", len)) { + sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); sv_catpvs(sv,"::"); + } } + else sv_catpvs(sv,"__ANON__::"); sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv)))); } @@ -1999,7 +2078,7 @@ void Perl_gv_check(pTHX_ const HV *stash) { dVAR; - register I32 i; + I32 i; PERL_ARGS_ASSERT_GV_CHECK; @@ -2008,7 +2087,7 @@ Perl_gv_check(pTHX_ const HV *stash) for (i = 0; i <= (I32) HvMAX(stash); i++) { const HE *entry; for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { - register GV *gv; + GV *gv; HV *hv; if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) @@ -2016,7 +2095,8 @@ Perl_gv_check(pTHX_ const HV *stash) if (hv != PL_defstash && hv != stash) gv_check(hv); /* nested package */ } - else if (isALPHA(*HeKEY(entry))) { + else if ( *HeKEY(entry) != '_' + && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) { const char *file; gv = MUTABLE_GV(HeVAL(entry)); if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) @@ -2030,8 +2110,10 @@ Perl_gv_check(pTHX_ const HV *stash) = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); #endif Perl_warner(aTHX_ packWARN(WARN_ONCE), - "Name \"%s::%s\" used only once: possible typo", - HvNAME_get(stash), GvNAME(gv)); + "Name \"%"HEKf"::%"HEKf + "\" used only once: possible typo", + HEKfARG(HvNAME_HEK(stash)), + HEKfARG(GvNAME_HEK(gv))); } } } @@ -2194,8 +2276,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; if (mg) { const AMT * const amtp = (AMT*)mg->mg_ptr; - if (amtp->was_ok_am == PL_amagic_generation - && amtp->was_ok_sub == newgen) { + if (amtp->was_ok_sub == newgen) { return AMT_OVERLOADED(amtp) ? 1 : 0; } sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); @@ -2204,7 +2285,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); Zero(&amt,1,AMT); - amt.was_ok_am = PL_amagic_generation; amt.was_ok_sub = newgen; amt.fallback = AMGfallNO; amt.flags = 0; @@ -2221,16 +2301,28 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) CV* cv; if (!gv) + { + if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0)) lim = DESTROY_amg; /* Skip overloading entries. */ + } #ifdef PERL_DONT_CREATE_GVSV else if (!sv) { NOOP; /* Equivalent to !SvTRUE and !SvOK */ } #endif else if (SvTRUE(sv)) + /* don't need to set overloading here because fallback => 1 + * is the default setting for classes without overloading */ amt.fallback=AMGfallYES; - else if (SvOK(sv)) + 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; @@ -2276,12 +2368,19 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool 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\"", + const SV * const name = (gvsv && SvPOK(gvsv)) + ? gvsv + : newSVpvs_flags("???", SVs_TEMP); + /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */ + Perl_croak(aTHX_ "%s method \"%"SVf256 + "\" overloading \"%s\" "\ + "in package \"%"HEKf256"\"", (GvCVGEN(gv) ? "Stub found while resolving" : "Can't resolve"), - name, cp, HvNAME(stash)); + SVfARG(name), cp, + HEKfARG( + HvNAME_HEK(stash) + )); } } cv = GvCV(gv = ngv); @@ -2352,8 +2451,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) } assert(mg); amtp = (AMT*)mg->mg_ptr; - if ( amtp->was_ok_am != PL_amagic_generation - || amtp->was_ok_sub != newgen ) + if ( amtp->was_ok_sub != newgen ) goto do_update; if (AMT_AMAGIC(amtp)) { CV * const ret = amtp->table[id]; @@ -2499,6 +2597,31 @@ Perl_amagic_deref_call(pTHX_ SV *ref, int method) { return tmpsv ? tmpsv : ref; } +bool +Perl_amagic_is_enabled(pTHX_ int method) +{ + SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); + + assert(PL_curcop->cop_hints & HINT_NO_AMAGIC); + + if ( !lex_mask || !SvOK(lex_mask) ) + /* overloading lexically disabled */ + return FALSE; + 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 FALSE; + } + return TRUE; +} + SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { @@ -2512,6 +2635,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) int assign = AMGf_assign & flags; const int assignshift = assign ? 1 : 0; int use_default_op = 0; + int force_scalar = 0; #ifdef DEBUGGING int fl=0; #endif @@ -2520,27 +2644,11 @@ 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 (!amagic_is_enabled(method)) return NULL; } if (!(AMGf_noleft & flags) && SvAMAGIC(left) - && (stash = SvSTASH(SvRV(left))) + && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash) && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table @@ -2605,12 +2713,8 @@ 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; + /* No need to do SvAMAGIC_on here, as SvAMAGIC macros + delegate to the stash. */ SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); return newref; } @@ -2667,14 +2771,21 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) - && (stash = SvSTASH(SvRV(right))) + && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash) && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table : NULL)) - && (cv = cvp[off=method])) { /* Method for right - * argument found */ - lr=1; + && ((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; } else if (((cvp && amtp->fallback > AMGfallNEVER) || (ocvp && oamtp->fallback > AMGfallNEVER)) && !(flags & AMGf_unary)) { @@ -2744,25 +2855,25 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SV *msg; if (off==-1) off=method; msg = sv_2mortal(Perl_newSVpvf(aTHX_ - "Operation \"%s\": no method found,%sargument %s%s%s%s", - AMG_id2name(method + assignshift), - (flags & AMGf_unary ? " " : "\n\tleft "), - SvAMAGIC(left)? - "in overloaded package ": - "has no overloaded magic", - SvAMAGIC(left)? - HvNAME_get(SvSTASH(SvRV(left))): - "", - SvAMAGIC(right)? - ",\n\tright argument in overloaded package ": - (flags & AMGf_unary - ? "" - : ",\n\tright argument has no overloaded magic"), - SvAMAGIC(right)? - HvNAME_get(SvSTASH(SvRV(right))): - "")); + "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf, + AMG_id2name(method + assignshift), + (flags & AMGf_unary ? " " : "\n\tleft "), + SvAMAGIC(left)? + "in overloaded package ": + "has no overloaded magic", + SvAMAGIC(left)? + SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))): + SVfARG(&PL_sv_no), + SvAMAGIC(right)? + ",\n\tright argument in overloaded package ": + (flags & AMGf_unary + ? "" + : ",\n\tright argument has no overloaded magic"), + SvAMAGIC(right)? + SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))): + SVfARG(&PL_sv_no))); if (use_default_op) { - DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); + DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) ); } else { Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); } @@ -2771,10 +2882,68 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) force_cpy = force_cpy || assign; } } + + switch (method) { + /* in these cases, we're calling '+' or '-' as a fallback for a ++ or -- + * operation. we need this to return a value, so that it can be assigned + * later on, in the postpr block (case inc_amg/dec_amg), even if the + * increment or decrement was itself called in void context */ + case inc_amg: + if (off == add_amg) + force_scalar = 1; + break; + case dec_amg: + if (off == subtr_amg) + force_scalar = 1; + break; + /* in these cases, we're calling an assignment variant of an operator + * (+= rather than +, for instance). regardless of whether it's a + * fallback or not, it always has to return a value, which will be + * assigned to the proper variable later */ + case add_amg: + case subtr_amg: + case mult_amg: + case div_amg: + case modulo_amg: + case pow_amg: + case lshift_amg: + case rshift_amg: + case repeat_amg: + case concat_amg: + case band_amg: + case bor_amg: + case bxor_amg: + if (assign) + force_scalar = 1; + break; + /* the copy constructor always needs to return a value */ + case copy_amg: + force_scalar = 1; + break; + /* because of the way these are implemented (they don't perform the + * dereferencing themselves, they return a reference that perl then + * dereferences later), they always have to be in scalar context */ + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + force_scalar = 1; + break; + /* these don't have an op of their own; they're triggered by their parent + * op, so the context there isn't meaningful ('$a and foo()' in void + * context still needs to pass scalar context on to $a's bool overload) */ + case bool__amg: + case numer_amg: + case string_amg: + force_scalar = 1; + break; + } + #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ - "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n", + "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %"SVf"%s\n", AMG_id2name(off), method+assignshift==off? "" : " (initially \"", @@ -2784,7 +2953,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", flags & AMGf_unary? " for argument" : "", - stash ? HvNAME_get(stash) : "null", + stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), fl? ",\n\tassignment variant used": "") ); } #endif @@ -2810,9 +2979,9 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) /* off is method, method+assignshift, or a result of opcode substitution. * In the latter case assignshift==0, so only notfound case is important. */ - if (( (method + assignshift == off) + if ( (lr == -1) && ( ( (method + assignshift == off) && (assign || (method == inc_amg) || (method == dec_amg))) - || force_cpy) + || force_cpy) ) { /* newSVsv does not behave as advertised, so we copy missing * information by hand */ @@ -2830,12 +2999,29 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) BINOP myop; SV* res; const bool oldcatch = CATCH_GET; + I32 oldmark, nret; + int gimme = force_scalar ? G_SCALAR : GIMME_V; CATCH_SET(TRUE); Zero(&myop, 1, BINOP); myop.op_last = (OP *) &myop; myop.op_next = NULL; - myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; + myop.op_flags = OPf_STACKED; + + switch (gimme) { + case G_VOID: + myop.op_flags |= OPf_WANT_VOID; + break; + case G_ARRAY: + if (flags & AMGf_want_list) { + myop.op_flags |= OPf_WANT_LIST; + break; + } + /* FALLTHROUGH */ + default: + myop.op_flags |= OPf_WANT_SCALAR; + break; + } PUSHSTACKi(PERLSI_OVERLOAD); ENTER; @@ -2856,13 +3042,37 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } PUSHs(MUTABLE_SV(cv)); PUTBACK; + oldmark = TOPMARK; if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) CALLRUNOPS(aTHX); LEAVE; SPAGAIN; + nret = SP - (PL_stack_base + oldmark); + + switch (gimme) { + case G_VOID: + /* returning NULL has another meaning, and we check the context + * at the call site too, so this can be differentiated from the + * scalar case */ + res = &PL_sv_undef; + SP = PL_stack_base + oldmark; + break; + case G_ARRAY: { + if (flags & AMGf_want_list) { + res = sv_2mortal((SV *)newAV()); + av_extend((AV *)res, nret); + while (nret--) + av_store((AV *)res, nret, POPs); + break; + } + /* FALLTHROUGH */ + } + default: + res = POPs; + break; + } - res=POPs; PUTBACK; POPSTACK; CATCH_SET(oldcatch); @@ -2924,7 +3134,7 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) } PERL_HASH(hash, name, len); - GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -len : len), hash); + GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); } /* @@ -3016,8 +3226,8 @@ core_xsub(pTHX_ CV* cv) * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */