X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ffdb8bcde21504a3efe208b4d47bea445e7e23fd..2723c0fb189e0e7ba1d917fdb4a00e30bf979b62:/gv.c?ds=sidebyside diff --git a/gv.c b/gv.c index 9da6c1a..ba8e85e 100644 --- a/gv.c +++ b/gv.c @@ -318,7 +318,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag const U32 old_type = SvTYPE(gv); const bool doproto = old_type > SVt_NULL; char * const proto = (doproto && SvPOK(gv)) - ? (SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0), SvPVX(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; @@ -368,9 +368,8 @@ 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) { /* newCONSTSUB takes ownership of the reference from us. */ cv = newCONSTSUB_flags(stash, name, len, flags, has_constant); @@ -383,17 +382,10 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag 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); @@ -452,25 +444,38 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, assert(gv || stash); assert(name); - 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: @@ -482,6 +487,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; @@ -516,18 +522,20 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, (void)hv_store(stash,name,len,(SV *)gv,0); if (ampable) { CvLVALUE_on(cv); - newATTRSUB(oldsavestack_ix, - newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(gv)), + 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; @@ -907,15 +915,8 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags) 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, newSVpvn_flags(CopSTASHPV(PL_curcop), - strlen(CopSTASHPV(PL_curcop)), - CopSTASH_flags(PL_curcop) - )); -#else av_push(superisa, newSVhek(CopSTASH(PL_curcop) ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL)); -#endif return stash; } @@ -1399,18 +1400,6 @@ 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) @@ -1693,7 +1682,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* 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) { @@ -1707,10 +1696,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); @@ -1758,11 +1743,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; @@ -1913,7 +1893,11 @@ 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; } @@ -1986,7 +1970,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"); @@ -2256,8 +2240,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); @@ -2266,7 +2249,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; @@ -2283,16 +2265,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; @@ -2421,8 +2415,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]; @@ -2568,6 +2561,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) { @@ -2581,6 +2599,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 @@ -2589,27 +2608,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 @@ -2674,12 +2677,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; } @@ -2736,14 +2735,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)) { @@ -2840,6 +2846,64 @@ 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_ @@ -2899,12 +2963,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; @@ -2925,13 +3006,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); @@ -3085,8 +3190,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: */