X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c9a0dcdc162f48aff88d967bc239701e38e52680..9da7aa9d07dd772b041d4b02828d9969efdbc053:/gv.c diff --git a/gv.c b/gv.c index 81fa5de..92f0171 100644 --- a/gv.c +++ b/gv.c @@ -20,7 +20,7 @@ */ /* -=head1 GV Functions +=head1 GV Handling A GV is a structure which corresponds to to a Perl typeglob, ie *foo. It is a structure that holds a pointer to a scalar, an array, a hash etc, corresponding to $foo, @foo, %foo. @@ -28,6 +28,8 @@ corresponding to $foo, @foo, %foo. GVs are usually found as values in stashes (symbol table hashes) where Perl stores its global variables. +=for apidoc Ayh||GV + =cut */ @@ -53,43 +55,64 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) && SvTYPE((const SV *)gv) != SVt_PVLV ) ) { - const char *what; - if (type == SVt_PVIO) { - /* - * if it walks like a dirhandle, then let's assume that - * this is a dirhandle. - */ - what = OP_IS_DIRHOP(PL_op->op_type) ? - "dirhandle" : "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); + const char *what; + if (type == SVt_PVIO) { + /* + * if it walks like a dirhandle, then let's assume that + * this is a dirhandle. + */ + what = OP_IS_DIRHOP(PL_op->op_type) ? + "dirhandle" : "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); } if (type == SVt_PVHV) { - where = (SV **)&GvHV(gv); + where = (SV **)&GvHV(gv); } else if (type == SVt_PVAV) { - where = (SV **)&GvAV(gv); + where = (SV **)&GvAV(gv); } else if (type == SVt_PVIO) { - where = (SV **)&GvIOp(gv); + where = (SV **)&GvIOp(gv); } else { - where = &GvSV(gv); + where = &GvSV(gv); } if (!*where) { - *where = newSV_type(type); - if (type == SVt_PVAV && GvNAMELEN(gv) == 3 - && strEQs(GvNAME(gv), "ISA")) - sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); + *where = newSV_type(type); + if (type == SVt_PVAV + && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) + sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); } return gv; } +/* +=for apidoc gv_fetchfile +=for apidoc_item gv_fetchfile_flags + +These return the debugger glob for the file (compiled by Perl) whose name is +given by the C parameter. + +There are currently exactly two differences between these functions. + +The C parameter to C is a C string, meaning it is +C-terminated; whereas the C parameter to C is a +Perl string, whose length (in bytes) is passed in via the C parameter +This means the name may contain embedded C characters. +C doesn't exist in plain C). + +The other difference is that C has an extra C +parameter, which is currently completely ignored, but allows for possible +future extensions. + +=cut +*/ GV * Perl_gv_fetchfile(pTHX_ const char *name) { @@ -99,7 +122,7 @@ Perl_gv_fetchfile(pTHX_ const char *name) GV * Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, - const U32 flags) + const U32 flags) { char smallbuf[128]; char *tmpbuf; @@ -110,29 +133,35 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, PERL_UNUSED_ARG(flags); if (!PL_defstash) - return NULL; + return NULL; if (tmplen <= sizeof smallbuf) - tmpbuf = smallbuf; + tmpbuf = smallbuf; else - Newx(tmpbuf, tmplen, char); + Newx(tmpbuf, tmplen, char); /* This is where the debugger's %{"::_<$filename"} hash is created */ tmpbuf[0] = '_'; tmpbuf[1] = '<'; memcpy(tmpbuf + 2, name, namelen); - gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); - if (!isGV(gv)) { - gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); + GV **gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, (flags & GVF_NOADD) ? FALSE : TRUE); + if (gvp) { + gv = *gvp; + if (!isGV(gv)) { + gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); #ifdef PERL_DONT_CREATE_GVSV - GvSV(gv) = newSVpvn(name, namelen); + GvSV(gv) = newSVpvn(name, namelen); #else - sv_setpvn(GvSV(gv), name, namelen); + sv_setpvn(GvSV(gv), name, namelen); #endif + } + if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv)) + hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile); + } + else { + gv = NULL; } - if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv)) - hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile); if (tmpbuf != smallbuf) - Safefree(tmpbuf); + Safefree(tmpbuf); return gv; } @@ -154,7 +183,7 @@ Perl_gv_const_sv(pTHX_ GV *gv) PERL_UNUSED_CONTEXT; if (SvTYPE(gv) == SVt_PVGV) - return cv_const_sv(GvCVu(gv)); + return cv_const_sv(GvCVu(gv)); return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL; } @@ -168,7 +197,6 @@ Perl_newGP(pTHX_ GV *const gv) #ifndef USE_ITHREADS GV *filegv; #endif - dVAR; PERL_ARGS_ASSERT_NEWGP; Newxz(gp, 1, GP); @@ -178,29 +206,29 @@ Perl_newGP(pTHX_ GV *const gv) #endif /* PL_curcop may be null here. E.g., - INIT { bless {} and exit } + INIT { bless {} and exit } frees INIT before looking up DESTROY (and creating *DESTROY) */ if (PL_curcop) { - gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ + gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ #ifdef USE_ITHREADS - if (CopFILE(PL_curcop)) { - file = CopFILE(PL_curcop); - len = strlen(file); - } + if (CopFILE(PL_curcop)) { + file = CopFILE(PL_curcop); + len = strlen(file); + } #else - filegv = CopFILEGV(PL_curcop); - if (filegv) { - file = GvNAME(filegv)+2; - len = GvNAMELEN(filegv)-2; - } + filegv = CopFILEGV(PL_curcop); + if (filegv) { + file = GvNAME(filegv)+2; + len = GvNAMELEN(filegv)-2; + } #endif - else goto no_file; + else goto no_file; } else { - no_file: - file = ""; - len = 0; + no_file: + file = ""; + len = 0; } PERL_HASH(hash, file, len); @@ -221,20 +249,20 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) PERL_ARGS_ASSERT_CVGV_SET; if (oldgv == gv) - return; + return; if (oldgv) { - if (CvCVGV_RC(cv)) { - SvREFCNT_dec_NN(oldgv); - CvCVGV_RC_off(cv); - } - else { - sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); - } + if (CvCVGV_RC(cv)) { + SvREFCNT_dec_NN(oldgv); + CvCVGV_RC_off(cv); + } + else { + sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); + } } else if ((hek = CvNAME_HEK(cv))) { - unshare_hek(hek); - CvLEXICAL_off(cv); + unshare_hek(hek); + CvLEXICAL_off(cv); } CvNAMED_off(cv); @@ -242,13 +270,13 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) assert(!CvCVGV_RC(cv)); if (!gv) - return; + return; if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv)) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv)); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv)); else { - CvCVGV_RC_on(cv); - SvREFCNT_inc_simple_void_NN(gv); + CvCVGV_RC_on(cv); + SvREFCNT_inc_simple_void_NN(gv); } } @@ -268,12 +296,12 @@ Perl_cvgv_from_hek(pTHX_ CV *cv) svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0); gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0)); if (!isGV(gv)) - gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)), - HEK_LEN(CvNAME_HEK(cv)), - SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv))); + gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)), + HEK_LEN(CvNAME_HEK(cv)), + SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv))); if (!CvNAMED(cv)) { /* gv_init took care of it */ - assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv); - return gv; + assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv); + return gv; } unshare_hek(CvNAME_HEK(cv)); CvNAMED_off(cv); @@ -291,12 +319,12 @@ Perl_cvstash_set(pTHX_ CV *cv, HV *st) HV *oldst = CvSTASH(cv); PERL_ARGS_ASSERT_CVSTASH_SET; if (oldst == st) - return; + return; if (oldst) - sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv)); + sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv)); SvANY(cv)->xcv_stash = st; if (st) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); } /* @@ -323,6 +351,8 @@ the return value of SvUTF8(sv). It can also take the C flag, which means to pretend that the GV has been seen before (i.e., suppress "Used once" warnings). +=for apidoc Amnh||GV_ADDMULTI + =for apidoc gv_init The old form of C. It does not work with UTF-8 strings, as it @@ -367,94 +397,102 @@ 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)) - ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv)) - : NULL; + ? ((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; + const bool really_sub = + has_constant && SvTYPE(has_constant) == SVt_PVCV; + COP * const old = PL_curcop; PERL_ARGS_ASSERT_GV_INIT_PVN; assert (!(proto && has_constant)); if (has_constant) { - /* The constant has to be a scalar, array or subroutine. */ - switch (SvTYPE(has_constant)) { - case SVt_PVHV: - case SVt_PVFM: - case SVt_PVIO: + /* The constant has to be a scalar, array or subroutine. */ + switch (SvTYPE(has_constant)) { + case SVt_PVHV: + case SVt_PVFM: + case SVt_PVIO: Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", - sv_reftype(has_constant, 0)); + sv_reftype(has_constant, 0)); NOT_REACHED; /* NOTREACHED */ break; - default: NOOP; - } - SvRV_set(gv, NULL); - SvROK_off(gv); + default: NOOP; + } + SvRV_set(gv, NULL); + SvROK_off(gv); } if (old_type < SVt_PVGV) { - if (old_type >= SVt_PV) - SvCUR_set(gv, 0); - sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); + if (old_type >= SVt_PV) + SvCUR_set(gv, 0); + sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); } if (SvLEN(gv)) { - if (proto) { - SvPV_set(gv, NULL); - SvLEN_set(gv, 0); - SvPOK_off(gv); - } else - Safefree(SvPVX_mutable(gv)); + if (proto) { + SvPV_set(gv, NULL); + SvLEN_set(gv, 0); + SvPOK_off(gv); + } else + Safefree(SvPVX_mutable(gv)); } SvIOK_off(gv); isGV_with_GP_on(gv); + if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant) + && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE + || CvSTART(has_constant)->op_type == OP_DBSTATE)) + PL_curcop = (COP *)CvSTART(has_constant); GvGP_set(gv, Perl_newGP(aTHX_ gv)); + PL_curcop = old; GvSTASH(gv) = stash; if (stash) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); 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 (has_constant && SvTYPE(has_constant) == SVt_PVCV) { - /* Not actually a constant. Just a regular sub. */ - CV * const cv = (CV *)has_constant; - GvCV_set(gv,cv); - if (CvNAMED(cv) && CvSTASH(cv) == stash && ( - CvNAME_HEK(cv) == GvNAME_HEK(gv) - || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv)) - && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv)) - && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv)) - && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv)) - ) - )) - CvGV_set(cv,gv); + GvMULTI_on(gv); /* _was_ mentioned */ + if (really_sub) { + /* Not actually a constant. Just a regular sub. */ + CV * const cv = (CV *)has_constant; + GvCV_set(gv,cv); + if (CvNAMED(cv) && CvSTASH(cv) == stash && ( + CvNAME_HEK(cv) == GvNAME_HEK(gv) + || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv)) + && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv)) + && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv)) + && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv)) + ) + )) + CvGV_set(cv,gv); } else if (doproto) { - CV *cv; - if (has_constant) { - /* newCONSTSUB takes ownership of the reference from us. */ - 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 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 { - cv = newSTUB(gv,1); - } - if (proto) { - sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, - SV_HAS_TRAILING_NUL); + CV *cv; + if (has_constant) { + /* newCONSTSUB takes ownership of the reference from us. */ + 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 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 { + cv = newSTUB(gv,1); + } + if (proto) { + sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, + SV_HAS_TRAILING_NUL); if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); - } + } } } @@ -465,26 +503,26 @@ S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type) switch (sv_type) { case SVt_PVIO: - (void)GvIOn(gv); - break; + (void)GvIOn(gv); + break; case SVt_PVAV: - (void)GvAVn(gv); - break; + (void)GvAVn(gv); + break; case SVt_PVHV: - (void)GvHVn(gv); - break; + (void)GvHVn(gv); + break; #ifdef PERL_DONT_CREATE_GVSV case SVt_NULL: case SVt_PVCV: case SVt_PVFM: case SVt_PVGV: - break; + break; default: - if(GvSVn(gv)) { - /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 - If we just cast GvSVn(gv) to void, it ignores evaluating it for - its side effect */ - } + if(GvSVn(gv)) { + /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 + If we just cast GvSVn(gv) to void, it ignores evaluating it for + its side effect */ + } #endif } } @@ -512,24 +550,25 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, /* no support for \&CORE::infix; 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_default : case KEY_DESTROY: + case KEY_BEGIN : case KEY_CHECK : case KEY_catch : case KEY_cmp: + case KEY_default : case KEY_defer : 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_given : case KEY_goto : case KEY_grep : case KEY_gt : + case KEY_if : case KEY_isa : 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_tr : case KEY_try : 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; + return NULL; case KEY_chdir: case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete: case KEY_eof : case KEY_exec: case KEY_exists : @@ -538,33 +577,33 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, case KEY_stat: case KEY_system: case KEY_truncate: case KEY_unlink: - ampable = FALSE; + ampable = FALSE; } if (!gv) { - gv = (GV *)newSV(0); - gv_init(gv, stash, name, len, TRUE); + gv = (GV *)newSV(0); + gv_init(gv, stash, name, len, TRUE); } GvMULTI_on(gv); if (ampable) { - ENTER; - oldcurcop = PL_curcop; - oldparser = PL_parser; - lex_start(NULL, NULL, 0); - oldcompcv = PL_compcv; - PL_compcv = NULL; /* Prevent start_subparse from setting - CvOUTSIDE. */ - oldsavestack_ix = start_subparse(FALSE,0); - cv = PL_compcv; + ENTER; + oldcurcop = PL_curcop; + oldparser = PL_parser; + lex_start(NULL, NULL, 0); + oldcompcv = PL_compcv; + PL_compcv = NULL; /* Prevent start_subparse from setting + CvOUTSIDE. */ + oldsavestack_ix = start_subparse(FALSE,0); + cv = PL_compcv; } else { - /* Avoid calling newXS, as it calls us, and things start to - get hairy. */ - cv = MUTABLE_CV(newSV_type(SVt_PVCV)); - GvCV_set(gv,cv); - GvCVGEN(gv) = 0; - CvISXSUB_on(cv); - CvXSUB(cv) = core_xsub; - PoisonPADLIST(cv); + /* Avoid calling newXS, as it calls us, and things start to + get hairy. */ + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + GvCV_set(gv,cv); + GvCVGEN(gv) = 0; + CvISXSUB_on(cv); + CvXSUB(cv) = core_xsub; + PoisonPADLIST(cv); } CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE from PL_curcop. */ @@ -578,41 +617,42 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, new ATTRSUB. */ (void)core_prototype((SV *)cv, name, code, &opnum); if (stash) - (void)hv_store(stash,name,len,(SV *)gv,0); + (void)hv_store(stash,name,len,(SV *)gv,0); if (ampable) { #ifdef DEBUGGING CV *orig_cv = cv; #endif - CvLVALUE_on(cv); + CvLVALUE_on(cv); /* newATTRSUB will free the CV and return NULL if we're still compiling after a syntax error */ - if ((cv = newATTRSUB_x( - oldsavestack_ix, (OP *)gv, - NULL,NULL, - coresub_op( - opnum - ? newSVuv((UV)opnum) - : newSVpvn(name,len), - code, opnum - ), - TRUE + if ((cv = newATTRSUB_x( + oldsavestack_ix, (OP *)gv, + NULL,NULL, + coresub_op( + opnum + ? newSVuv((UV)opnum) + : newSVpvn(name,len), + code, opnum + ), + TRUE )) != NULL) { assert(GvCV(gv) == orig_cv); if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS && opnum != OP_UNDEF && opnum != OP_KEYS) CvLVALUE_off(cv); /* Now *that* was a neat trick. */ } - LEAVE; - PL_parser = oldparser; - PL_curcop = oldcurcop; - PL_compcv = oldcompcv; + LEAVE; + PL_parser = oldparser; + PL_curcop = oldcurcop; + PL_compcv = oldcompcv; } 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); + SV *opnumsv = newSViv( + (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ? + (OP_ENTEREVAL | (1<<16)) + : opnum ? opnum : (((I32)name[2]) << 16)); + cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0); + SvREFCNT_dec_NN(opnumsv); } return gv; @@ -638,7 +678,8 @@ Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) STRLEN namelen; PERL_ARGS_ASSERT_GV_FETCHMETH_SV; if (LIKELY(SvPOK_nog(namesv))) /* common case */ - return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, flags); + return gv_fetchmeth_internal(stash, namesv, NULL, 0, level, + flags | SvUTF8(namesv)); namepv = SvPV(namesv, namelen); if (SvUTF8(namesv)) flags |= SVf_UTF8; return gv_fetchmeth_pvn(stash, namepv, namelen, level, flags); @@ -647,7 +688,7 @@ Perl_gv_fetchmeth_sv(pTHX_ HV *stash, SV *namesv, I32 level, U32 flags) /* =for apidoc gv_fetchmeth_pv -Exactly like L, but takes a nul-terminated string +Exactly like L, but takes a nul-terminated string instead of a string/length pair. =cut @@ -672,17 +713,23 @@ side-effect creates a glob with the given C in the given C which in the case of success contains an alias for the subroutine, and sets up caching info for this glob. -The only significant values for C are C and C. +The only significant values for C are C, C, and +C. C indicates that we want to look up the method in the superclasses of the C. +C indicates that we do not want to look up the method in +the stash accessible by C. + The GV returned from C may be a method cache entry, which is not visible to Perl code. So when calling C, you should not use the GV directly; instead, you should use the method's CV, which can be obtained from the GV with the C macro. +=for apidoc Amnh||GV_SUPER + =cut */ @@ -701,6 +748,7 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, CV* cand_cv = NULL; GV* topgv = NULL; const char *hvname; + STRLEN hvnamelen; I32 create = (level >= 0) ? HV_FETCH_LVALUE : 0; I32 items; U32 topgen_cmp; @@ -708,14 +756,15 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, /* UNIVERSAL methods should be callable without a stash */ if (!stash) { - create = 0; /* probably appropriate */ - if(!(stash = gv_stashpvs("UNIVERSAL", 0))) - return 0; + create = 0; /* probably appropriate */ + if(!(stash = gv_stashpvs("UNIVERSAL", 0))) + return 0; } assert(stash); hvname = HvNAME_get(stash); + hvnamelen = HvNAMELEN_get(stash); if (!hvname) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); @@ -723,15 +772,15 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, assert(name || meth); DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n", - flags & GV_SUPER ? "SUPER " : "", - name ? name : SvPV_nolen(meth), hvname) ); + flags & GV_SUPER ? "SUPER " : "", + name ? name : SvPV_nolen(meth), hvname) ); topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; if (flags & GV_SUPER) { - if (!HvAUX(stash)->xhv_mro_meta->super) - HvAUX(stash)->xhv_mro_meta->super = newHV(); - cachestash = HvAUX(stash)->xhv_mro_meta->super; + if (!HvAUX(stash)->xhv_mro_meta->super) + HvAUX(stash)->xhv_mro_meta->super = newHV(); + cachestash = HvAUX(stash)->xhv_mro_meta->super; } else cachestash = stash; @@ -759,21 +808,21 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, } else { /* stale cache entry, junk it and move on */ - SvREFCNT_dec_NN(cand_cv); - GvCV_set(topgv, NULL); - cand_cv = NULL; - GvCVGEN(topgv) = 0; + SvREFCNT_dec_NN(cand_cv); + GvCV_set(topgv, NULL); + cand_cv = NULL; + GvCVGEN(topgv) = 0; } } else if (GvCVGEN(topgv) == topgen_cmp) { /* cache indicates no such method definitively */ return 0; } - else if (stash == cachestash - && len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4 - && strEQs(hvname, "CORE") + else if (stash == cachestash + && len > 1 /* shortest is uc */ + && memEQs(hvname, HvNAMELEN_get(stash), "CORE") && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len)) - goto have_gv; + goto have_gv; } linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ @@ -785,20 +834,42 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, cstash = gv_stashsv(linear_sv, 0); if (!cstash) { - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %" SVf " for @%" HEKf "::ISA", - SVfARG(linear_sv), - HEKfARG(HvNAME_HEK(stash))); + if ( ckWARN(WARN_SYNTAX)) { + if( /* these are loaded from Perl_Gv_AMupdate() one way or another */ + ( len && name[0] == '(' ) /* overload.pm related, in particular "()" */ + || ( memEQs( name, len, "DESTROY") ) + ) { + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Can't locate package %" SVf " for @%" HEKf "::ISA", + SVfARG(linear_sv), + HEKfARG(HvNAME_HEK(stash))); + + } else if( memEQs( name, len, "AUTOLOAD") ) { + /* gobble this warning */ + } else { + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "While trying to resolve method call %.*s->%.*s()" + " can not locate package \"%" SVf "\" yet it is mentioned in @%.*s::ISA" + " (perhaps you forgot to load \"%" SVf "\"?)", + (int) hvnamelen, hvname, + (int) len, name, + SVfARG(linear_sv), + (int) hvnamelen, hvname, + SVfARG(linear_sv)); + } + } continue; } assert(cstash); - gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0); + gvp = (GV**)hv_common( + cstash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, HV_FETCH_JUST_SV, NULL, 0 + ); if (!gvp) { if (len > 1 && HvNAMELEN_get(cstash) == 4) { const char *hvname = HvNAME(cstash); assert(hvname); - if (strEQs(hvname, "CORE") + if (strBEGINs(hvname, "CORE") && (candidate = S_maybe_add_coresub(aTHX_ cstash,NULL,name,len) )) @@ -824,12 +895,12 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, GvCV_set(topgv, cand_cv); GvCVGEN(topgv) = topgen_cmp; } - return candidate; + return candidate; } } /* Check UNIVERSAL without caching */ - if(level == 0 || level == -1) { + if((level == 0 || level == -1) && !(flags & GV_NOUNIVERSAL)) { candidate = gv_fetchmeth_internal(NULL, meth, name, len, 1, flags &~GV_SUPER); if(candidate) { @@ -925,26 +996,26 @@ Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I3 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD; if (!gv) { - CV *cv; - GV **gvp; - - if (!stash) - return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ - if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) - return NULL; - if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) - return NULL; - cv = GvCV(gv); - if (!(CvROOT(cv) || CvXSUB(cv))) - return NULL; - /* 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, + CV *cv; + GV **gvp; + + if (!stash) + return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ + if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) + return NULL; + if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) + return NULL; + cv = GvCV(gv); + if (!(CvROOT(cv) || CvXSUB(cv))) + return NULL; + /* 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, (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0)); - if (!gvp) - return NULL; - return *gvp; + if (!gvp) + return NULL; + return *gvp; } return gv; } @@ -1020,11 +1091,11 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS; if (SvTYPE(stash) < SVt_PVHV) - stash = NULL; + stash = NULL; else { - /* The only way stash can become NULL later on is if last_separator is set, - which in turn means that there is no need for a SVt_PVHV case - the error reporting code. */ + /* The only way stash can become NULL later on is if last_separator is set, + which in turn means that there is no need for a SVt_PVHV case + the error reporting code. */ } { @@ -1057,99 +1128,100 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le if (last_separator) { STRLEN sep_len= last_separator - origname; if ( memEQs(origname, sep_len, "SUPER")) { - /* ->SUPER::method should really be looked up in original stash */ - stash = CopSTASH(PL_curcop); - flags |= GV_SUPER; - DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", - origname, HvENAME_get(stash), name) ); - } + /* ->SUPER::method should really be looked up in original stash */ + stash = CopSTASH(PL_curcop); + flags |= GV_SUPER; + DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", + origname, HvENAME_get(stash), name) ); + } else if ( sep_len >= 7 && - strEQs(last_separator - 7, "::SUPER")) { + strBEGINs(last_separator - 7, "::SUPER")) { /* don't autovifify if ->NoSuchStash::SUPER::method */ stash = gv_stashpvn(origname, sep_len - 7, is_utf8); - if (stash) flags |= GV_SUPER; - } - else { + if (stash) flags |= GV_SUPER; + } + else { /* don't autovifify if ->NoSuchStash::method */ stash = gv_stashpvn(origname, sep_len, is_utf8); - } - ostash = stash; + } + ostash = stash; } gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); if (!gv) { - /* This is the special case that exempts Foo->import and - Foo->unimport from being an error even if there's no - import/unimport subroutine */ - if (strEQ(name,"import") || strEQ(name,"unimport")) - gv = MUTABLE_GV(&PL_sv_yes); - else if (autoload) - gv = gv_autoload_pvn( - ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags - ); - if (!gv && do_croak) { - /* Right now this is exclusively for the benefit of S_method_common - in pp_hot.c */ - if (stash) { - /* If we can't find an IO::File method, it might be a call on - * a filehandle. If IO:File has not been loaded, try to - * require it first instead of croaking */ - const char *stash_name = HvNAME_get(stash); - if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") - && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, - STR_WITH_LEN("IO/File.pm"), 0, - HV_FETCH_ISEXISTS, NULL, 0) - ) { - require_pv("IO/File.pm"); - gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); - if (gv) - return gv; - } - Perl_croak(aTHX_ - "Can't locate object method \"%" UTF8f - "\" via package \"%" HEKf "\"", - UTF8fARG(is_utf8, name_end - name, name), + /* This is the special case that exempts Foo->import and + Foo->unimport from being an error even if there's no + import/unimport subroutine */ + if (strEQ(name,"import") || strEQ(name,"unimport")) { + gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL, + NULL, 0, 0, NULL)); + } else if (autoload) + gv = gv_autoload_pvn( + ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags + ); + if (!gv && do_croak) { + /* Right now this is exclusively for the benefit of S_method_common + in pp_hot.c */ + if (stash) { + /* If we can't find an IO::File method, it might be a call on + * a filehandle. If IO:File has not been loaded, try to + * require it first instead of croaking */ + const char *stash_name = HvNAME_get(stash); + if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") + && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, + STR_WITH_LEN("IO/File.pm"), 0, + HV_FETCH_ISEXISTS, NULL, 0) + ) { + require_pv("IO/File.pm"); + gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); + if (gv) + return gv; + } + Perl_croak(aTHX_ + "Can't locate object method \"%" UTF8f + "\" via package \"%" HEKf "\"", + UTF8fARG(is_utf8, name_end - name, name), HEKfARG(HvNAME_HEK(stash))); - } - else { + } + else { SV* packnamesv; - if (last_separator) { - packnamesv = newSVpvn_flags(origname, last_separator - origname, + if (last_separator) { + packnamesv = newSVpvn_flags(origname, last_separator - origname, SVs_TEMP | is_utf8); - } else { - packnamesv = error_report; - } - - Perl_croak(aTHX_ - "Can't locate object method \"%" UTF8f - "\" via package \"%" SVf "\"" - " (perhaps you forgot to load \"%" SVf "\"?)", - UTF8fARG(is_utf8, name_end - name, name), + } else { + packnamesv = error_report; + } + + Perl_croak(aTHX_ + "Can't locate object method \"%" UTF8f + "\" via package \"%" SVf "\"" + " (perhaps you forgot to load \"%" SVf "\"?)", + UTF8fARG(is_utf8, name_end - name, name), SVfARG(packnamesv), SVfARG(packnamesv)); - } - } + } + } } else if (autoload) { - CV* const cv = GvCV(gv); - if (!CvROOT(cv) && !CvXSUB(cv)) { - GV* stubgv; - GV* autogv; - - if (CvANON(cv) || CvLEXICAL(cv)) - stubgv = gv; - else { - stubgv = CvGV(cv); - if (GvCV(stubgv) != cv) /* orphaned import */ - stubgv = gv; - } + CV* const cv = GvCV(gv); + if (!CvROOT(cv) && !CvXSUB(cv)) { + GV* stubgv; + GV* autogv; + + if (CvANON(cv) || CvLEXICAL(cv)) + stubgv = gv; + else { + stubgv = CvGV(cv); + if (GvCV(stubgv) != cv) /* orphaned import */ + stubgv = gv; + } autogv = gv_autoload_pvn(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), GV_AUTOLOAD_ISMETHOD | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0)); - if (autogv) - gv = autogv; - } + if (autogv) + gv = autogv; + } } return gv; @@ -1188,39 +1260,37 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN; if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) - return NULL; + return NULL; if (stash) { - if (SvTYPE(stash) < SVt_PVHV) { + if (SvTYPE(stash) < SVt_PVHV) { STRLEN packname_len = 0; const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len); packname = newSVpvn_flags(packname_ptr, packname_len, SVs_TEMP | SvUTF8(stash)); - stash = NULL; - } - else - packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); - if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); + stash = NULL; + } + else + packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); + if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); } if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, - is_utf8 | (flags & GV_SUPER)))) - return NULL; + is_utf8 | (flags & GV_SUPER)))) + return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) - return NULL; + return NULL; /* - * Inheriting AUTOLOAD for non-methods works ... for now. + * Inheriting AUTOLOAD for non-methods no longer works */ if ( !(flags & GV_AUTOLOAD_ISMETHOD) && (GvCVGEN(gv) || GvSTASH(gv) != stash) ) - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Use of inherited AUTOLOAD for non-method %" SVf - "::%" UTF8f "() is deprecated. This will be " - "fatal in Perl 5.28", - SVfARG(packname), + Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf + "::%" UTF8f "() is no longer allowed", + SVfARG(packname), UTF8fARG(is_utf8, len, name)); if (CvISXSUB(cv)) { @@ -1246,34 +1316,34 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) * We use SvUTF8 for both prototypes and sub names, so if one is * UTF8, the other must be upgraded. */ - CvSTASH_set(cv, stash); - if (SvPOK(cv)) { /* Ouch! */ - SV * const 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_NN(tmpsv); - SvLEN(cv) = SvCUR(cv) + 1; - SvCUR(cv) = ulen; - } - else { - sv_setpvn((SV *)cv, name, len); - SvPOK_off(cv); - if (is_utf8) + CvSTASH_set(cv, stash); + if (SvPOK(cv)) { /* Ouch! */ + SV * const 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_set(tmpsv, SvCUR(tmpsv) + 1); /* 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_NN(tmpsv); + SvLEN_set(cv, SvCUR(cv) + 1); + SvCUR_set(cv, ulen); + } + else { + sv_setpvn((SV *)cv, name, len); + SvPOK_off(cv); + if (is_utf8) SvUTF8_on(cv); - else SvUTF8_off(cv); - } - CvAUTOLOAD_on(cv); + else SvUTF8_off(cv); + } + CvAUTOLOAD_on(cv); } /* @@ -1287,9 +1357,9 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) ENTER; if (!isGV(vargv)) { - gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); + gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); #ifdef PERL_DONT_CREATE_GVSV - GvSV(vargv) = newSV(0); + GvSV(vargv) = newSV(0); #endif } LEAVE; @@ -1301,8 +1371,8 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */ sv_catpvn_flags( - varsv, name, len, - SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES) + varsv, name, len, + SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES) ); if (is_utf8) SvUTF8_on(varsv); @@ -1339,35 +1409,42 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, GV **gvp; dSP; + PUSHSTACKi(PERLSI_MAGIC); ENTER; -#define HV_FETCH_TIE_FUNC (GV **)hv_fetchs(stash, "_tie_it", 0) +#define GET_HV_FETCH_TIE_FUNC \ + ( (gvp = (GV **)hv_fetchs(stash, "_tie_it", 0)) \ + && *gvp \ + && ( (isGV(*gvp) && GvCV(*gvp)) \ + || (SvROK(*gvp) && SvTYPE(SvRV(*gvp)) == SVt_PVCV) ) \ + ) /* Load the module if it is not loaded. */ if (!(stash = gv_stashpvn(name, len, 0)) - || !(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) + || ! GET_HV_FETCH_TIE_FUNC) { - SV * const module = newSVpvn(name, len); - const char type = varname == '[' ? '$' : '%'; - if ( flags & 1 ) - save_scalar(gv); - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); - assert(sp == PL_stack_sp); - stash = gv_stashpvn(name, len, 0); - if (!stash) - Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", - type, varname, name); - else if (!(gvp = HV_FETCH_TIE_FUNC) || !*gvp || !GvCV(*gvp)) - Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", - type, varname, name); + SV * const module = newSVpvn(name, len); + const char type = varname == '[' ? '$' : '%'; + if ( flags & 1 ) + save_scalar(gv); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); + assert(sp == PL_stack_sp); + stash = gv_stashpvn(name, len, 0); + if (!stash) + Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", + type, varname, name); + else if (! GET_HV_FETCH_TIE_FUNC) + Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", + type, varname, name); } /* Now call the tie function. It should be in *gvp. */ - assert(gvp); assert(*gvp); assert(GvCV(*gvp)); + assert(gvp); assert(*gvp); PUSHMARK(SP); XPUSHs((SV *)gv); PUTBACK; call_sv((SV *)*gvp, G_VOID|G_DISCARD); LEAVE; + POPSTACK; } } @@ -1406,18 +1483,26 @@ is returned. Flags may be one of: - GV_ADD - SVf_UTF8 - GV_NOADD_NOINIT - GV_NOINIT - GV_NOEXPAND - GV_ADDMG + GV_ADD Create and initialize the package if doesn't + already exist + GV_NOADD_NOINIT Don't create the package, + GV_ADDMG GV_ADD iff the GV is magical + GV_NOINIT GV_ADD, but don't initialize + GV_NOEXPAND Don't expand SvOK() entries to PVGV + SVf_UTF8 The name is in UTF-8 The most important of which are probably C and C. Note, use of C instead of C where possible is strongly recommended for performance reasons. +=for apidoc Amnh||GV_ADD +=for apidoc Amnh||GV_NOADD_NOINIT +=for apidoc Amnh||GV_NOINIT +=for apidoc Amnh||GV_NOEXPAND +=for apidoc Amnh||GV_ADDMG +=for apidoc Amnh||SVf_UTF8 + =cut */ @@ -1441,51 +1526,57 @@ S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags) PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL; if (tmplen <= sizeof smallbuf) - tmpbuf = smallbuf; + tmpbuf = smallbuf; else - Newx(tmpbuf, tmplen, char); + Newx(tmpbuf, tmplen, char); Copy(name, tmpbuf, namelen, char); tmpbuf[namelen] = ':'; tmpbuf[namelen+1] = ':'; tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV); if (tmpbuf != smallbuf) - Safefree(tmpbuf); + Safefree(tmpbuf); if (!tmpgv || !isGV_with_GP(tmpgv)) - return NULL; + return NULL; stash = GvHV(tmpgv); if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; assert(stash); if (!HvNAME_get(stash)) { - hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); - - /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ - /* If the containing stash has multiple effective - names, see that this one gets them, too. */ - if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) - mro_package_moved(stash, NULL, tmpgv, 1); + hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); + + /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ + /* If the containing stash has multiple effective + names, see that this one gets them, too. */ + if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) + mro_package_moved(stash, NULL, tmpgv, 1); } return stash; } /* -gv_stashsvpvn_cached +=for apidoc gv_stashsvpvn_cached Returns a pointer to the stash for a specified package, possibly -cached. Implements both C and C. +cached. Implements both L> and +L>. + +Requires one of either C or C to be non-null. -Requires one of either namesv or namepv to be non-null. +If the flag C is set, return the stash only if found in the +cache; see L> for details on the other C. -See C> for details on "flags". +Note it is strongly preferred for C to be non-null, for performance +reasons. -Note the sv interface is strongly preferred for performance reasons. +=for apidoc Emnh||GV_CACHE_ONLY +=cut */ #define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \ assert(namesv || name) -PERL_STATIC_INLINE HV* -S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags) +HV* +Perl_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags) { HV* stash; HE* he; @@ -1553,12 +1644,10 @@ Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) PERL_ARGS_ASSERT_GV_STASHSV; return gv_stashsvpvn_cached(sv, NULL, 0, flags); } - - GV * -Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) { +Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 flags, const svtype sv_type) { PERL_ARGS_ASSERT_GV_FETCHPV; - return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); + return gv_fetchpvn_flags(nambeg, strlen(nambeg), flags, sv_type); } GV * @@ -1580,12 +1669,12 @@ S_gv_magicalize_isa(pTHX_ GV *gv) av = GvAVn(gv); GvMULTI_on(gv); sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, - NULL, 0); + NULL, 0); } /* This function grabs name and tries to split a stash and glob * from its contents. TODO better description, comments - * + * * If the function returns TRUE and 'name == name_end', then * 'gv' can be directly returned to the caller of gv_fetchpvn_flags */ @@ -1594,12 +1683,14 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, STRLEN *len, const char *nambeg, STRLEN full_len, const U32 is_utf8, const I32 add) { + char *tmpfullbuf = NULL; /* only malloc one big chunk of memory when the smallbuff is not large enough */ const char *name_cursor; const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; + char smallbuf[64]; /* small buffer to avoid a malloc when possible */ PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME; - + if ( full_len > 2 && **name == '*' && isIDFIRST_lazy_if_safe(*name + 1, name_end, is_utf8)) @@ -1616,7 +1707,7 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, if (!*stash) *stash = PL_defstash; if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */ - return FALSE; + goto notok; *len = name_cursor - *name; if (name_cursor > nambeg) { /* Skip for initial :: or ' */ @@ -1626,9 +1717,17 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, key = *name; *len += 2; } - else { + else { /* using ' for package separator */ + /* use our pre-allocated buffer when possible to save a malloc */ char *tmpbuf; - Newx(tmpbuf, *len+2, char); + if ( *len+2 <= sizeof smallbuf) + tmpbuf = smallbuf; + else { + /* only malloc once if needed */ + if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */ + Newx(tmpfullbuf, full_len+2, char); + tmpbuf = tmpfullbuf; + } Copy(*name, tmpbuf, *len, char); tmpbuf[(*len)++] = ':'; tmpbuf[(*len)++] = ':'; @@ -1636,22 +1735,20 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, } gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add); *gv = gvp ? *gvp : NULL; - if (*gv && *gv != (const GV *)&PL_sv_undef) { - if (SvTYPE(*gv) != SVt_PVGV) - gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8); - else - GvMULTI_on(*gv); + if (!*gv || *gv == (const GV *)&PL_sv_undef) { + goto notok; } - if (key != *name) - Safefree(key); - if (!*gv || *gv == (const GV *)&PL_sv_undef) - return FALSE; + /* here we know that *gv && *gv != &PL_sv_undef */ + if (SvTYPE(*gv) != SVt_PVGV) + gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8); + else + GvMULTI_on(*gv); if (!(*stash = GvHV(*gv))) { *stash = GvHV(*gv) = newHV(); if (!HvNAME_get(*stash)) { if (GvSTASH(*gv) == PL_defstash && *len == 6 - && strEQs(*name, "CORE")) + && strBEGINs(*name, "CORE")) hv_name_sets(*stash, "CORE", 0); else hv_name_set( @@ -1672,28 +1769,34 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, *name = name_cursor+1; if (*name == name_end) { if (!*gv) { - *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); - if (SvTYPE(*gv) != SVt_PVGV) { - gv_init_pvn(*gv, PL_defstash, "main::", 6, - GV_ADDMULTI); - GvHV(*gv) = - MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); - } - } - return TRUE; + *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); + if (SvTYPE(*gv) != SVt_PVGV) { + gv_init_pvn(*gv, PL_defstash, "main::", 6, + GV_ADDMULTI); + GvHV(*gv) = + MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); + } + } + goto ok; } } } *len = name_cursor - *name; + ok: + Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */ return TRUE; + notok: + Safefree(tmpfullbuf); /* free our tmpfullbuf if it was used */ + return FALSE; } + /* Checks if an unqualified name is in the main stash */ PERL_STATIC_INLINE bool S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8) { PERL_ARGS_ASSERT_GV_IS_IN_MAIN; - + /* If it's an alphanumeric variable */ if ( len && isIDFIRST_lazy_if_safe(name, name + len, is_utf8) ) { /* Some "normal" variables are always in main::, @@ -1737,7 +1840,7 @@ S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8) /* *{""}, or a special variable like $@ */ else return TRUE; - + return FALSE; } @@ -1745,7 +1848,7 @@ S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8) /* This function is called if parse_gv_stash_name() failed to * find a stash, or if GV_NOTQUAL or an empty name was passed * to gv_fetchpvn_flags. - * + * * It returns FALSE if the default stash can't be found nor created, * which might happen during global destruction. */ @@ -1755,7 +1858,7 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, const svtype sv_type) { PERL_ARGS_ASSERT_FIND_DEFAULT_STASH; - + /* No stash in name, so see how we can default */ if ( gv_is_in_main(name, len, is_utf8) ) { @@ -1852,9 +1955,9 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, * a new GV. * Note that it does not insert the GV into the stash prior to * magicalization, which some variables require need in order - * to work (like $[, %+, %-, %!), so callers must take care of + * to work (like %+, %-, %!), so callers must take care of * that. - * + * * It returns true if the gv did turn out to be magical one; i.e., * if gv_magicalize actually did something. */ @@ -1865,14 +1968,14 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, SSize_t paren; PERL_ARGS_ASSERT_GV_MAGICALIZE; - + if (stash != PL_defstash) { /* not the main stash */ - /* We only have to check for a few names here: a, b, EXPORT, ISA - and VERSION. All the others apply only to the main stash or to - CORE (which is checked right after this). */ - if (len) { - switch (*name) { - case 'E': + /* We only have to check for a few names here: a, b, EXPORT, ISA + and VERSION. All the others apply only to the main stash or to + CORE (which is checked right after this). */ + if (len) { + switch (*name) { + case 'E': if ( len >= 6 && name[1] == 'X' && (memEQs(name, len, "EXPORT") @@ -1880,46 +1983,46 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, ||memEQs(name, len, "EXPORT_FAIL") ||memEQs(name, len, "EXPORT_TAGS")) ) - GvMULTI_on(gv); - break; - case 'I': + GvMULTI_on(gv); + break; + case 'I': if (memEQs(name, len, "ISA")) - gv_magicalize_isa(gv); - break; - case 'V': + gv_magicalize_isa(gv); + break; + case 'V': if (memEQs(name, len, "VERSION")) - GvMULTI_on(gv); - break; - case 'a': + GvMULTI_on(gv); + break; + case 'a': if (stash == PL_debstash && memEQs(name, len, "args")) { - GvMULTI_on(gv_AVadd(gv)); - break; + GvMULTI_on(gv_AVadd(gv)); + break; } /* FALLTHROUGH */ - case 'b': - if (len == 1 && sv_type == SVt_PV) - GvMULTI_on(gv); - /* FALLTHROUGH */ - default: - goto try_core; - } - goto ret; - } + case 'b': + if (len == 1 && sv_type == SVt_PV) + GvMULTI_on(gv); + /* FALLTHROUGH */ + default: + goto try_core; + } + goto ret; + } try_core: - if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { - /* Avoid null warning: */ - const char * const stashname = HvNAME(stash); assert(stashname); - if (strEQs(stashname, "CORE")) - S_maybe_add_coresub(aTHX_ 0, gv, name, len); - } + if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { + /* Avoid null warning: */ + const char * const stashname = HvNAME(stash); assert(stashname); + if (strBEGINs(stashname, "CORE")) + S_maybe_add_coresub(aTHX_ 0, gv, name, len); + } } else if (len > 1) { #ifndef EBCDIC - if (*name > 'V' ) { - 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 + if (*name > 'V' ) { + 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 the common case of lower case variable names. (On EBCDIC platforms, we can't just do: if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) { @@ -1927,19 +2030,19 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, C1 (non-ASCII) controls on those platforms, so the remapping would make them larger than 'V') */ - } else + } else #endif - { - switch (*name) { - case 'A': + { + switch (*name) { + case 'A': if (memEQs(name, len, "ARGV")) { - IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; - } + IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; + } else if (memEQs(name, len, "ARGVOUT")) { - GvMULTI_on(gv); - } - break; - case 'E': + GvMULTI_on(gv); + } + break; + case 'E': if ( len >= 6 && name[1] == 'X' && (memEQs(name, len, "EXPORT") @@ -1947,91 +2050,89 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, ||memEQs(name, len, "EXPORT_FAIL") ||memEQs(name, len, "EXPORT_TAGS")) ) - GvMULTI_on(gv); - break; - case 'I': + GvMULTI_on(gv); + break; + case 'I': if (memEQs(name, len, "ISA")) { - gv_magicalize_isa(gv); - } - break; - case 'S': + gv_magicalize_isa(gv); + } + break; + case 'S': if (memEQs(name, len, "SIG")) { - HV *hv; - I32 i; - if (!PL_psig_name) { - Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); - Newxz(PL_psig_pend, SIG_SIZE, int); - PL_psig_ptr = PL_psig_name + SIG_SIZE; - } else { - /* I think that the only way to get here is to re-use an - embedded perl interpreter, where the previous - use didn't clean up fully because - PL_perl_destruct_level was 0. I'm not sure that we - "support" that, in that I suspect in that scenario - there are sufficient other garbage values left in the - interpreter structure that something else will crash - before we get here. I suspect that this is one of - those "doctor, it hurts when I do this" bugs. */ - Zero(PL_psig_name, 2 * SIG_SIZE, SV*); - Zero(PL_psig_pend, SIG_SIZE, int); - } - GvMULTI_on(gv); - hv = GvHVn(gv); - hv_magic(hv, NULL, PERL_MAGIC_sig); - for (i = 1; i < SIG_SIZE; i++) { - SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); - if (init) - sv_setsv(*init, &PL_sv_undef); - } - } - break; - case 'V': + HV *hv; + I32 i; + if (!PL_psig_name) { + Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); + Newxz(PL_psig_pend, SIG_SIZE, int); + PL_psig_ptr = PL_psig_name + SIG_SIZE; + } else { + /* I think that the only way to get here is to re-use an + embedded perl interpreter, where the previous + use didn't clean up fully because + PL_perl_destruct_level was 0. I'm not sure that we + "support" that, in that I suspect in that scenario + there are sufficient other garbage values left in the + interpreter structure that something else will crash + before we get here. I suspect that this is one of + those "doctor, it hurts when I do this" bugs. */ + Zero(PL_psig_name, 2 * SIG_SIZE, SV*); + Zero(PL_psig_pend, SIG_SIZE, int); + } + GvMULTI_on(gv); + hv = GvHVn(gv); + hv_magic(hv, NULL, PERL_MAGIC_sig); + for (i = 1; i < SIG_SIZE; i++) { + SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); + if (init) + sv_setsv(*init, &PL_sv_undef); + } + } + break; + case 'V': if (memEQs(name, len, "VERSION")) - GvMULTI_on(gv); - break; + GvMULTI_on(gv); + break; case '\003': /* $^CHILD_ERROR_NATIVE */ if (memEQs(name, len, "\003HILD_ERROR_NATIVE")) - goto magicalize; + goto magicalize; /* @{^CAPTURE} %{^CAPTURE} */ if (memEQs(name, len, "\003APTURE")) { AV* const av = GvAVn(gv); - UV uv= *name; + const Size_t n = *name; - sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0); + sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0); SvREADONLY_on(av); - if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) - require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0); + require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0); } else /* %{^CAPTURE_ALL} */ if (memEQs(name, len, "\003APTURE_ALL")) { - if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) - require_tie_mod_s(gv, '+', "Tie::Hash::NamedCapture",0); + require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0); } - break; - case '\005': /* $^ENCODING */ + break; + case '\005': /* $^ENCODING */ if (memEQs(name, len, "\005NCODING")) - goto magicalize; - break; - case '\007': /* $^GLOBAL_PHASE */ + goto magicalize; + break; + case '\007': /* $^GLOBAL_PHASE */ if (memEQs(name, len, "\007LOBAL_PHASE")) - goto ro_magicalize; - break; - case '\014': /* $^LAST_FH */ + goto ro_magicalize; + break; + case '\014': /* $^LAST_FH */ if (memEQs(name, len, "\014AST_FH")) - goto ro_magicalize; - break; + goto ro_magicalize; + break; case '\015': /* $^MATCH */ if (memEQs(name, len, "\015ATCH")) { paren = RX_BUFF_IDX_CARET_FULLMATCH; goto storeparen; } break; - case '\017': /* $^OPEN */ + case '\017': /* $^OPEN */ if (memEQs(name, len, "\017PEN")) - goto magicalize; - break; - case '\020': /* $^PREMATCH $^POSTMATCH */ + goto magicalize; + break; + case '\020': /* $^PREMATCH $^POSTMATCH */ if (memEQs(name, len, "\020REMATCH")) { paren = RX_BUFF_IDX_CARET_PREMATCH; goto storeparen; @@ -2040,69 +2141,73 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, paren = RX_BUFF_IDX_CARET_POSTMATCH; goto storeparen; } - break; - case '\024': /* ${^TAINT} */ + break; + case '\023': + if (memEQs(name, len, "\023AFE_LOCALES")) + goto ro_magicalize; + break; + case '\024': /* ${^TAINT} */ if (memEQs(name, len, "\024AINT")) - goto ro_magicalize; - break; - case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ + goto ro_magicalize; + break; + case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ if (memEQs(name, len, "\025NICODE")) - goto ro_magicalize; + goto ro_magicalize; if (memEQs(name, len, "\025TF8LOCALE")) - goto ro_magicalize; + goto ro_magicalize; if (memEQs(name, len, "\025TF8CACHE")) - goto magicalize; - break; - case '\027': /* $^WARNING_BITS */ + goto magicalize; + break; + case '\027': /* $^WARNING_BITS */ if (memEQs(name, len, "\027ARNING_BITS")) - goto magicalize; + goto magicalize; #ifdef WIN32 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT")) - goto magicalize; + goto magicalize; #endif - break; - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - { - /* Ensures that we have an all-digit variable, ${"1foo"} fails - this test */ + break; + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + { + /* Ensures that we have an all-digit variable, ${"1foo"} fails + this test */ UV uv; if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX) goto ret; /* XXX why are we using a SSize_t? */ paren = (SSize_t)(I32)uv; goto storeparen; - } - } - } + } + } + } } else { - /* Names of length 1. (Or 0. But name is NUL terminated, so that will - be case '\0' in this switch statement (ie a default case) */ - switch (*name) { - case '&': /* $& */ + /* Names of length 1. (Or 0. But name is NUL terminated, so that will + be case '\0' in this switch statement (ie a default case) */ + switch (*name) { + case '&': /* $& */ paren = RX_BUFF_IDX_FULLMATCH; goto sawampersand; - case '`': /* $` */ + case '`': /* $` */ paren = RX_BUFF_IDX_PREMATCH; goto sawampersand; - case '\'': /* $' */ + case '\'': /* $' */ paren = RX_BUFF_IDX_POSTMATCH; sawampersand: #ifdef PERL_SAWAMPERSAND - if (!( - sv_type == SVt_PVAV || - sv_type == SVt_PVHV || - sv_type == SVt_PVCV || - sv_type == SVt_PVFM || - sv_type == SVt_PVIO - )) { PL_sawampersand |= + if (!( + sv_type == SVt_PVAV || + sv_type == SVt_PVHV || + sv_type == SVt_PVCV || + sv_type == SVt_PVFM || + sv_type == SVt_PVIO + )) { PL_sawampersand |= (*name == '`') ? SAWAMPERSAND_LEFT : (*name == '&') @@ -2128,29 +2233,29 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren); break; - case ':': /* $: */ - sv_setpv(GvSVn(gv),PL_chopset); - goto magicalize; + case ':': /* $: */ + sv_setpv(GvSVn(gv),PL_chopset); + goto magicalize; - case '?': /* $? */ + case '?': /* $? */ #ifdef COMPLEX_STATUS - SvUPGRADE(GvSVn(gv), SVt_PVLV); + SvUPGRADE(GvSVn(gv), SVt_PVLV); #endif - goto magicalize; + goto magicalize; - case '!': /* $! */ - GvMULTI_on(gv); - /* If %! has been used, automatically load Errno.pm. */ + case '!': /* $! */ + GvMULTI_on(gv); + /* If %! has been used, automatically load Errno.pm. */ - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); /* magicalization must be done before require_tie_mod_s is called */ - if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) require_tie_mod_s(gv, '!', "Errno", 1); - break; - case '-': /* $-, %-, @- */ - case '+': /* $+, %+, @+ */ + break; + case '-': /* $-, %-, @- */ + case '+': /* $+, %+, @+ */ GvMULTI_on(gv); /* no used once warnings here */ { /* $- $+ */ sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); @@ -2163,95 +2268,87 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, } { /* @- @+ */ AV* const av = GvAVn(gv); - const UV uv = (UV)*name; + const Size_t n = *name; - sv_magic(MUTABLE_SV(av), (SV*)uv, PERL_MAGIC_regdata, NULL, 0); + sv_magic(MUTABLE_SV(av), (SV*)n, PERL_MAGIC_regdata, NULL, 0); SvREADONLY_on(av); } break; - case '*': /* $* */ - case '#': /* $# */ - if (sv_type == SVt_PV) - /* diag_listed_as: $* is no longer supported. Its use will be fatal in Perl 5.30 */ - Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "$%c is no longer supported. Its use " - "will be fatal in Perl 5.30", *name); - break; - case '\010': /* $^H */ - { - HV *const hv = GvHVn(gv); - hv_magic(hv, NULL, PERL_MAGIC_hints); - } - goto magicalize; - case '[': /* $[ */ - if ((sv_type == SVt_PV || sv_type == SVt_PVGV) - && FEATURE_ARYBASE_IS_ENABLED) { - require_tie_mod_s(gv,'[',"arybase",0); - } - else goto magicalize; + case '*': /* $* */ + case '#': /* $# */ + if (sv_type == SVt_PV) + /* diag_listed_as: $* is no longer supported as of Perl 5.30 */ + Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name); + break; + case '\010': /* $^H */ + { + HV *const hv = GvHVn(gv); + hv_magic(hv, NULL, PERL_MAGIC_hints); + } + goto magicalize; + case '\023': /* $^S */ + ro_magicalize: + SvREADONLY_on(GvSVn(gv)); + /* FALLTHROUGH */ + case '0': /* $0 */ + case '^': /* $^ */ + case '~': /* $~ */ + case '=': /* $= */ + case '%': /* $% */ + case '.': /* $. */ + case '(': /* $( */ + case ')': /* $) */ + case '<': /* $< */ + case '>': /* $> */ + case '\\': /* $\ */ + case '/': /* $/ */ + case '|': /* $| */ + case '$': /* $$ */ + case '[': /* $[ */ + case '\001': /* $^A */ + case '\003': /* $^C */ + case '\004': /* $^D */ + case '\005': /* $^E */ + case '\006': /* $^F */ + case '\011': /* $^I, NOT \t in EBCDIC */ + case '\016': /* $^N */ + case '\017': /* $^O */ + case '\020': /* $^P */ + case '\024': /* $^T */ + case '\027': /* $^W */ + magicalize: + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + break; + + case '\014': /* $^L */ + sv_setpvs(GvSVn(gv),"\f"); break; - case '\023': /* $^S */ - ro_magicalize: - SvREADONLY_on(GvSVn(gv)); - /* FALLTHROUGH */ - case '0': /* $0 */ - case '^': /* $^ */ - case '~': /* $~ */ - case '=': /* $= */ - case '%': /* $% */ - case '.': /* $. */ - case '(': /* $( */ - case ')': /* $) */ - case '<': /* $< */ - case '>': /* $> */ - case '\\': /* $\ */ - case '/': /* $/ */ - case '|': /* $| */ - case '$': /* $$ */ - case '\001': /* $^A */ - case '\003': /* $^C */ - case '\004': /* $^D */ - case '\005': /* $^E */ - case '\006': /* $^F */ - case '\011': /* $^I, NOT \t in EBCDIC */ - case '\016': /* $^N */ - case '\017': /* $^O */ - case '\020': /* $^P */ - case '\024': /* $^T */ - case '\027': /* $^W */ - magicalize: - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); - break; - - case '\014': /* $^L */ - sv_setpvs(GvSVn(gv),"\f"); - break; - case ';': /* $; */ - sv_setpvs(GvSVn(gv),"\034"); - break; - case ']': /* $] */ - { - SV * const sv = GvSV(gv); - if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel, TRUE); - GvSV(gv) = vnumify(PL_patchlevel); - SvREADONLY_on(GvSV(gv)); - SvREFCNT_dec(sv); - } - break; - case '\026': /* $^V */ - { - SV * const sv = GvSV(gv); - GvSV(gv) = new_version(PL_patchlevel); - SvREADONLY_on(GvSV(gv)); - SvREFCNT_dec(sv); - } - break; - case 'a': - case 'b': - if (sv_type == SVt_PV) - GvMULTI_on(gv); - } + case ';': /* $; */ + sv_setpvs(GvSVn(gv),"\034"); + break; + case ']': /* $] */ + { + SV * const sv = GvSV(gv); + if (!sv_derived_from(PL_patchlevel, "version")) + upg_version(PL_patchlevel, TRUE); + GvSV(gv) = vnumify(PL_patchlevel); + SvREADONLY_on(GvSV(gv)); + SvREFCNT_dec(sv); + } + break; + case '\026': /* $^V */ + { + SV * const sv = GvSV(gv); + GvSV(gv) = new_version(PL_patchlevel); + SvREADONLY_on(GvSV(gv)); + SvREFCNT_dec(sv); + } + break; + case 'a': + case 'b': + if (sv_type == SVt_PV) + GvMULTI_on(gv); + } } ret: @@ -2285,18 +2382,12 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0); } else if (sv_type == SVt_PV) { if (*name == '*' || *name == '#') { - /* diag_listed_as: $# is no longer supported. Its use will be fatal in Perl 5.30 */ - Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, - WARN_SYNTAX), - "$%c is no longer supported. Its use " - "will be fatal in Perl 5.30", *name); + /* diag_listed_as: $* is no longer supported as of Perl 5.30 */ + Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name); } } if (sv_type==SVt_PV || sv_type==SVt_PVGV) { switch (*name) { - case '[': - require_tie_mod_s(gv,'[',"arybase",0); - break; #ifdef PERL_SAWAMPERSAND case '`': PL_sawampersand |= SAWAMPERSAND_LEFT; @@ -2315,9 +2406,78 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) } } +/* +=for apidoc gv_fetchpv +=for apidoc_item |GV *|gv_fetchpvn|const char * nambeg|STRLEN full_len|I32 flags|const svtype sv_type +=for apidoc_item ||gv_fetchpvn_flags +=for apidoc_item |GV *|gv_fetchpvs|"name"|I32 flags|const svtype sv_type +=for apidoc_item ||gv_fetchsv +=for apidoc_item |GV *|gv_fetchsv_nomg|SV *name|I32 flags|const svtype sv_type + +These all return the GV of type C whose name is given by the inputs, +or NULL if no GV of that name and type could be found. See L. + +The only differences are how the input name is specified, and if 'get' magic is +normally used in getting that name. + +Don't be fooled by the fact that only one form has C in its name. They +all have a C parameter in fact, and all the flag bits have the same +meanings for all + +If any of the flags C, C, C, C, or +C is set, a GV is created if none already exists for the input name +and type. However, C will only do the creation for magical GV's. +For all of these flags except C, C> is called after +the addition. C is used when the caller expects that adding won't +be necessary because the symbol should already exist; but if not, add it +anyway, with a warning that it was unexpectedly absent. The C +flag means to pretend that the GV has been seen before (I, suppress "Used +once" warnings). + +The flag C causes C> not be to called if the +GV existed but isn't PVGV. + +If the C bit is set, the name is treated as being encoded in UTF-8; +otherwise the name won't be considered to be UTF-8 in the C-named forms, +and the UTF-8ness of the underlying SVs will be used in the C forms. + +If the flag C is set, the caller warrants that the input name is a +plain symbol name, not qualified with a package, otherwise the name is checked +for being a qualified one. + +In C, C is a C string, NUL-terminated with no intermediate +NULs. + +In C, C is a literal C string, hence is enclosed in +double quotes. + +C and C are identical. In these, is +a Perl string whose byte length is given by C, and may contain +embedded NULs. + +In C and C, the name is extracted from the PV of +the input C SV. The only difference between these two forms is that +'get' magic is normally done on C in C, and always skipped +with C. Including C in the C parameter +to C makes it behave identically to C. + +=for apidoc Amnh||GV_ADD +=for apidoc Amnh||GV_ADDMG +=for apidoc Amnh||GV_ADDMULTI +=for apidoc Amnh||GV_ADDWARN +=for apidoc Amnh||GV_NOADD_NOINIT +=for apidoc Amnh||GV_NOINIT +=for apidoc Amnh||GV_NOTQUAL +=for apidoc Amnh||GV_NO_SVGMAGIC +=for apidoc Amnh||SVf_UTF8 + +=cut +*/ + GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, - const svtype sv_type) + const svtype sv_type) { const char *name = nambeg; GV *gv = NULL; @@ -2352,12 +2512,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) { return NULL; } - + /* By this point we should have a stash and a name */ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add); if (!gvp || *gvp == (const GV *)&PL_sv_undef) { - if (addmg) gv = (GV *)newSV(0); - else return NULL; + if (addmg) gv = (GV *)newSV(0); /* tentatively */ + else return NULL; } else gv = *gvp, addmg = 0; /* From this point on, addmg means gv has not been inserted in the @@ -2367,7 +2527,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* The GV already exists, so return it, but check if we need to do * anything else with it before that. */ - if (add) { + if (add) { /* This is the heuristic that handles if a variable triggers the * 'used only once' warning. If there's already a GV in the stash * with this name, then we assume that the variable has been used @@ -2376,24 +2536,24 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, * BEGIN { $a = 1; $::{foo} = *a }; () = $foo * not warning about $main::foo being used just once */ - GvMULTI_on(gv); - gv_init_svtype(gv, sv_type); + 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 (len == 1 && stash == PL_defstash) { maybe_multimagic_gv(gv, name, sv_type); - } - else if (len == 3 && sv_type == SVt_PVAV - && strEQs(name, "ISA") - && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) - gv_magicalize_isa(gv); - } - return gv; + } + else if (sv_type == SVt_PVAV + && memEQs(name, len, "ISA") + && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) + gv_magicalize_isa(gv); + } + return gv; } else if (no_init) { - assert(!addmg); - return gv; + assert(!addmg); + return gv; } /* If GV_NOEXPAND is true and what we got off the stash is a ref, * don't expand it to a glob. This is an optimization so that things @@ -2402,8 +2562,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, * stashes. */ else if (no_expand && SvROK(gv)) { - assert(!addmg); - return gv; + assert(!addmg); + return gv; } /* Adding a new symbol. @@ -2416,9 +2576,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 %" UTF8f " unexpectedly", - UTF8fARG(is_utf8, name_end-nambeg, nambeg)); + 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 ( full_len != 0 @@ -2434,7 +2594,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (addmg) { /* gv_magicalize magicalised this gv, so we want it * stored in the symtab. - * Effectively the caller is asking, ‘Does this gv exist?’ + * Effectively the caller is asking, ‘Does this gv exist?’ * And we respond, ‘Er, *now* it does!’ */ (void)hv_store(stash,name,len,(SV *)gv,0); @@ -2445,7 +2605,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, SvREFCNT_dec_NN(gv); gv = NULL; } - + if (gv) gv_init_svtype(gv, faking_it ? SVt_PVCV : sv_type); return gv; } @@ -2462,9 +2622,9 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) 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,"::"); + if (keepmain || ! memBEGINs(name, len, "main")) { + sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); + sv_catpvs(sv,"::"); } } else sv_catpvs(sv,"__ANON__::"); @@ -2494,29 +2654,29 @@ Perl_gv_check(pTHX_ HV *stash) PERL_ARGS_ASSERT_GV_CHECK; if (!SvOOK(stash)) - return; + return; assert(HvARRAY(stash)); + /* mark stash is being scanned, to avoid recursing */ + HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH; for (i = 0; i <= (I32) HvMAX(stash); i++) { const HE *entry; - /* mark stash is being scanned, to avoid recursing */ - HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH; - for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { GV *gv; HV *hv; - STRLEN keylen = HeKLEN(entry); + STRLEN keylen = HeKLEN(entry); const char * const key = HeKEY(entry); - if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' && - (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) - { - if (hv != PL_defstash && hv != stash + if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' && + (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) + { + if (hv != PL_defstash && hv != stash && !(SvOOK(hv) && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH)) ) - gv_check(hv); /* nested package */ - } + gv_check(hv); /* nested package */ + } else if ( HeKLEN(entry) != 0 && *HeKEY(entry) != '_' && isIDFIRST_lazy_if_safe(HeKEY(entry), @@ -2524,26 +2684,26 @@ Perl_gv_check(pTHX_ HV *stash) HeUTF8(entry)) ) { const char *file; - gv = MUTABLE_GV(HeVAL(entry)); - if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) - continue; - file = GvFILE(gv); - CopLINE_set(PL_curcop, GvLINE(gv)); + gv = MUTABLE_GV(HeVAL(entry)); + if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) + continue; + file = GvFILE(gv); + CopLINE_set(PL_curcop, GvLINE(gv)); #ifdef USE_ITHREADS - CopFILE(PL_curcop) = (char *)file; /* set for warning */ + CopFILE(PL_curcop) = (char *)file; /* set for warning */ #else - CopFILEGV(PL_curcop) - = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); + CopFILEGV(PL_curcop) + = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); #endif - Perl_warner(aTHX_ packWARN(WARN_ONCE), - "Name \"%" HEKf "::%" HEKf - "\" used only once: possible typo", + Perl_warner(aTHX_ packWARN(WARN_ONCE), + "Name \"%" HEKf "::%" HEKf + "\" used only once: possible typo", HEKfARG(HvNAME_HEK(stash)), HEKfARG(GvNAME_HEK(gv))); - } - } - HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH; + } + } } + HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH; } GV * @@ -2564,17 +2724,17 @@ GP* Perl_gp_ref(pTHX_ GP *gp) { if (!gp) - return NULL; + return NULL; gp->gp_refcnt++; if (gp->gp_cv) { - if (gp->gp_cvgen) { - /* If the GP they asked for a reference to contains + if (gp->gp_cvgen) { + /* 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_NN(gp->gp_cv); - gp->gp_cv = NULL; - gp->gp_cvgen = 0; - } + SvREFCNT_dec_NN(gp->gp_cv); + gp->gp_cv = NULL; + gp->gp_cvgen = 0; + } } return gp; } @@ -2584,21 +2744,22 @@ Perl_gp_free(pTHX_ GV *gv) { GP* gp; int attempts = 100; + bool in_global_destruction = PL_phase == PERL_PHASE_DESTRUCT; if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) - return; + return; if (gp->gp_refcnt == 0) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free unreferenced glob pointers" - pTHX__FORMAT pTHX__VALUE); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free unreferenced glob pointers" + pTHX__FORMAT pTHX__VALUE); return; } if (gp->gp_refcnt > 1) { borrowed: - if (gp->gp_egv == gv) - gp->gp_egv = 0; - gp->gp_refcnt--; - GvGP_set(gv, NULL); + if (gp->gp_egv == gv) + gp->gp_egv = 0; + gp->gp_refcnt--; + GvGP_set(gv, NULL); return; } @@ -2606,12 +2767,14 @@ Perl_gp_free(pTHX_ GV *gv) /* Copy and null out all the glob slots, so destructors do not see freed SVs. */ HEK * const file_hek = gp->gp_file_hek; - SV * const sv = gp->gp_sv; - AV * const av = gp->gp_av; - HV * const hv = gp->gp_hv; - IO * const io = gp->gp_io; - CV * const cv = gp->gp_cv; - CV * const form = gp->gp_form; + SV * sv = gp->gp_sv; + AV * av = gp->gp_av; + HV * hv = gp->gp_hv; + IO * io = gp->gp_io; + CV * cv = gp->gp_cv; + CV * form = gp->gp_form; + + int need = 0; gp->gp_file_hek = NULL; gp->gp_sv = NULL; @@ -2622,10 +2785,56 @@ Perl_gp_free(pTHX_ GV *gv) gp->gp_form = NULL; if (file_hek) - unshare_hek(file_hek); - - SvREFCNT_dec(sv); - SvREFCNT_dec(av); + unshare_hek(file_hek); + + /* Storing the SV on the temps stack (instead of freeing it immediately) + is an admitted bodge that attempt to compensate for the lack of + reference counting on the stack. The motivation is that typeglob syntax + is extremely short hence programs such as '$a += (*a = 2)' are often + found randomly by researchers running fuzzers. Previously these + programs would trigger errors, that the researchers would + (legitimately) report, and then we would spend time figuring out that + the cause was "stack not reference counted" and so not a dangerous + security hole. This consumed a lot of researcher time, our time, and + prevents "interesting" security holes being uncovered. + + Typeglob assignment is rarely used in performance critical production + code, so we aren't causing much slowdown by doing extra work here. + + In turn, the need to check for SvOBJECT (and references to objects) is + because we have regression tests that rely on timely destruction that + happens *within this while loop* to demonstrate behaviour, and + potentially there is also *working* code in the wild that relies on + such behaviour. + + And we need to avoid doing this in global destruction else we can end + up with "Attempt to free temp prematurely ... Unbalanced string table + refcount". + + Hence the whole thing is a heuristic intended to mitigate against + simple problems likely found by fuzzers but never written by humans, + whilst leaving working code unchanged. */ + if (sv) { + SV *referant; + if (SvREFCNT(sv) > 1 || SvOBJECT(sv) || UNLIKELY(in_global_destruction)) { + SvREFCNT_dec_NN(sv); + sv = NULL; + } else if (SvROK(sv) && (referant = SvRV(sv)) + && (SvREFCNT(referant) > 1 || SvOBJECT(referant))) { + SvREFCNT_dec_NN(sv); + sv = NULL; + } else { + ++need; + } + } + if (av) { + if (SvREFCNT(av) > 1 || SvOBJECT(av) || UNLIKELY(in_global_destruction)) { + SvREFCNT_dec_NN(av); + av = NULL; + } else { + ++need; + } + } /* FIXME - another reference loop GV -> symtab -> GV ? Somehow gp->gp_hv can end up pointing at freed garbage. */ if (hv && SvTYPE(hv) == SVt_PVHV) { @@ -2636,21 +2845,84 @@ Perl_gp_free(pTHX_ GV *gv) HEKfARG(hvname_hek))); (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD); } - SvREFCNT_dec(hv); + if (SvREFCNT(hv) > 1 || SvOBJECT(hv) || UNLIKELY(in_global_destruction)) { + SvREFCNT_dec_NN(hv); + hv = NULL; + } else { + ++need; + } } if (io && SvREFCNT(io) == 1 && IoIFP(io) - && (IoTYPE(io) == IoTYPE_WRONLY || - IoTYPE(io) == IoTYPE_RDWR || - IoTYPE(io) == IoTYPE_APPEND) - && ckWARN_d(WARN_IO) - && IoIFP(io) != PerlIO_stdin() - && IoIFP(io) != PerlIO_stdout() - && IoIFP(io) != PerlIO_stderr() - && !(IoFLAGS(io) & IOf_FAKE_DIRP)) - io_close(io, gv, FALSE, TRUE); - SvREFCNT_dec(io); - SvREFCNT_dec(cv); - SvREFCNT_dec(form); + && (IoTYPE(io) == IoTYPE_WRONLY || + IoTYPE(io) == IoTYPE_RDWR || + IoTYPE(io) == IoTYPE_APPEND) + && ckWARN_d(WARN_IO) + && IoIFP(io) != PerlIO_stdin() + && IoIFP(io) != PerlIO_stdout() + && IoIFP(io) != PerlIO_stderr() + && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + io_close(io, gv, FALSE, TRUE); + if (io) { + if (SvREFCNT(io) > 1 || SvOBJECT(io) || UNLIKELY(in_global_destruction)) { + SvREFCNT_dec_NN(io); + io = NULL; + } else { + ++need; + } + } + if (cv) { + if (SvREFCNT(cv) > 1 || SvOBJECT(cv) || UNLIKELY(in_global_destruction)) { + SvREFCNT_dec_NN(cv); + cv = NULL; + } else { + ++need; + } + } + if (form) { + if (SvREFCNT(form) > 1 || SvOBJECT(form) || UNLIKELY(in_global_destruction)) { + SvREFCNT_dec_NN(form); + form = NULL; + } else { + ++need; + } + } + + if (need) { + /* We don't strictly need to defer all this to the end, but it's + easiest to do so. The subtle problems we have are + 1) any of the actions triggered by the various SvREFCNT_dec()s in + any of the intermediate blocks can cause more items to be added + to the temps stack. So we can't "cache" its state locally + 2) We'd have to re-check the "extend by 1?" for each time. + Whereas if we don't NULL out the values that we want to put onto + the save stack until here, we can do it in one go, with one + one size check. */ + + SSize_t max_ix = PL_tmps_ix + need; + + if (max_ix >= PL_tmps_max) { + tmps_grow_p(max_ix); + } + + if (sv) { + PL_tmps_stack[++PL_tmps_ix] = sv; + } + if (av) { + PL_tmps_stack[++PL_tmps_ix] = (SV *) av; + } + if (hv) { + PL_tmps_stack[++PL_tmps_ix] = (SV *) hv; + } + if (io) { + PL_tmps_stack[++PL_tmps_ix] = (SV *) io; + } + if (cv) { + PL_tmps_stack[++PL_tmps_ix] = (SV *) cv; + } + if (form) { + PL_tmps_stack[++PL_tmps_ix] = (SV *) form; + } + } /* Possibly reallocated by a destructor */ gp = GvGP(gv); @@ -2664,10 +2936,10 @@ Perl_gp_free(pTHX_ GV *gv) && !gp->gp_form) break; if (--attempts == 0) { - Perl_die(aTHX_ - "panic: gp_free failed to free glob pointer - " - "something is repeatedly re-creating entries" - ); + Perl_die(aTHX_ + "panic: gp_free failed to free glob pointer - " + "something is repeatedly re-creating entries" + ); } } @@ -2686,14 +2958,14 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; if (amtp && AMT_AMAGIC(amtp)) { - int i; - for (i = 1; i < NofAMmeth; i++) { - CV * const cv = amtp->table[i]; - if (cv) { - SvREFCNT_dec_NN(MUTABLE_SV(cv)); - amtp->table[i] = NULL; - } - } + int i; + for (i = 1; i < NofAMmeth; i++) { + CV * const cv = amtp->table[i]; + if (cv) { + SvREFCNT_dec_NN(MUTABLE_SV(cv)); + amtp->table[i] = NULL; + } + } } return 0; } @@ -2719,7 +2991,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_AMAGIC(amtp) ? 1 : 0; + return AMT_AMAGIC(amtp) ? 1 : 0; } sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); } @@ -2747,19 +3019,19 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (!gv) { if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0)) - goto no_table; + goto no_table; } #ifdef PERL_DONT_CREATE_GVSV else if (!sv) { - NOOP; /* Equivalent to !SvTRUE and !SvOK */ + 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; + amt.fallback=AMGfallYES; else if (SvOK(sv)) { - amt.fallback=AMGfallNEVER; + amt.fallback=AMGfallNEVER; filled = 1; } else { @@ -2771,73 +3043,72 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; for (i = 1; i < NofAMmeth; i++) { - const char * const cooky = PL_AMG_names[i]; - /* Human-readable form, for debugging: */ - 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", - cp, HvNAME_get(stash)) ); - /* don't fill the cache while looking up! - Creation of inheritance stubs in intermediate packages may - conflict with the logic of runtime method substitution. - Indeed, for inheritance A -> B -> C, if C overloads "+0", - 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". */ - gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); + const char * const cooky = PL_AMG_names[i]; + /* Human-readable form, for debugging: */ + 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", + cp, HvNAME_get(stash)) ); + /* don't fill the cache while looking up! + Creation of inheritance stubs in intermediate packages may + conflict with the logic of runtime method substitution. + Indeed, for inheritance A -> B -> C, if C overloads "+0", + 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". */ + gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); cv = 0; if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) { - const HEK * const gvhek = - CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv)); + const HEK * const gvhek = CvGvNAME_HEK(cv); const HEK * const stashek = HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv))); - if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil") - && stashek && HEK_LEN(stashek) == 8 - && strEQ(HEK_KEY(stashek), "overload")) { - /* This is a hack to support autoloading..., while - knowing *which* methods were declared as overloaded. */ - /* GvSV contains the name of the method. */ - GV *ngv = NULL; - SV *gvsv = GvSV(gv); - - DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\ - "\" for overloaded \"%s\" in package \"%.256s\"\n", - (void*)GvSV(gv), cp, HvNAME(stash)) ); - if (!gvsv || !SvPOK(gvsv) - || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) - { - /* Can be an import stub (created by "can"). */ - if (destructing) { - return -1; - } - else { - const SV * const name = (gvsv && SvPOK(gvsv)) + if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil") + && stashek + && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) { + /* This is a hack to support autoloading..., while + knowing *which* methods were declared as overloaded. */ + /* GvSV contains the name of the method. */ + GV *ngv = NULL; + SV *gvsv = GvSV(gv); + + DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\ + "\" for overloaded \"%s\" in package \"%.256s\"\n", + (void*)GvSV(gv), cp, HvNAME(stash)) ); + if (!gvsv || !SvPOK(gvsv) + || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) + { + /* Can be an import stub (created by "can"). */ + if (destructing) { + return -1; + } + else { + 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"), - SVfARG(name), cp, + /* 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"), + SVfARG(name), cp, HEKfARG( - HvNAME_HEK(stash) - )); - } - } - cv = GvCV(gv = ngv); - } - DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", - cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), - GvNAME(CvGV(cv))) ); - filled = 1; - } else if (gv) { /* Autoloaded... */ - cv = MUTABLE_CV(gv); - filled = 1; - } - amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); + HvNAME_HEK(stash) + )); + } + } + cv = GvCV(gv = ngv); + } + DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", + cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), + GvNAME(CvGV(cv))) ); + filled = 1; + } else if (gv) { /* Autoloaded... */ + cv = MUTABLE_CV(gv); + filled = 1; + } + amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); if (gv) { switch (i) { @@ -2861,7 +3132,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (filled) { AMT_AMAGIC_on(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, - (char*)&amt, sizeof(AMT)); + (char*)&amt, sizeof(AMT)); return TRUE; } } @@ -2869,7 +3140,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) no_table: AMT_AMAGIC_off(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, - (char*)&amt, sizeof(AMTS)); + (char*)&amt, sizeof(AMTS)); return 0; } @@ -2891,27 +3162,27 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: - if (Gv_AMupdate(stash, 0) == -1) - return NULL; - mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); + if (Gv_AMupdate(stash, 0) == -1) + return NULL; + mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); } assert(mg); amtp = (AMT*)mg->mg_ptr; if ( amtp->was_ok_sub != newgen ) - goto do_update; + goto do_update; if (AMT_AMAGIC(amtp)) { - CV * const ret = amtp->table[id]; - if (ret && isGV(ret)) { /* Autoloading stab */ - /* Passing it through may have resulted in a warning - "Inherited AUTOLOAD for a non-method deprecated", since - our caller is going through a function call, not a method call. - So return the CV for AUTOLOAD, setting $AUTOLOAD. */ - GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); - - if (gv && GvCV(gv)) - return GvCV(gv); - } - return ret; + CV * const ret = amtp->table[id]; + if (ret && isGV(ret)) { /* Autoloading stab */ + /* Passing it through may have resulted in a warning + "Inherited AUTOLOAD for a non-method deprecated", since + our caller is going through a function call, not a method call. + So return the CV for AUTOLOAD, setting $AUTOLOAD. */ + GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); + + if (gv && GvCV(gv)) + return GvCV(gv); + } + return ret; } return NULL; @@ -2921,9 +3192,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) /* Implement tryAMAGICun_MG macro. Do get magic, then see if the stack arg is overloaded and if so call it. Flags: - AMGf_set return the arg using SETs rather than assigning to - the targ - AMGf_numeric apply sv_2num to the stack arg. + AMGf_numeric apply sv_2num to the stack arg. */ bool @@ -2935,27 +3204,30 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { SvGETMAGIC(arg); if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method, - AMGf_noright | AMGf_unary - | (flags & AMGf_numarg)))) + AMGf_noright | AMGf_unary + | (flags & AMGf_numarg)))) { - if (flags & AMGf_set) { - SETs(tmpsv); - } - else { - dTARGET; - if (SvPADMY(TARG)) { - sv_setsv(TARG, tmpsv); - SETTARG; - } - else - SETs(tmpsv); - } - PUTBACK; - return TRUE; + /* where the op is of the form: + * $lex = $x op $y (where the assign is optimised away) + * then assign the returned value to targ and return that; + * otherwise return the value directly + */ + if ( (PL_opargs[PL_op->op_type] & OA_TARGLEX) + && (PL_op->op_private & OPpTARGET_MY)) + { + dTARGET; + sv_setsv(TARG, tmpsv); + SETTARG; + } + else + SETs(tmpsv); + + PUTBACK; + return TRUE; } if ((flags & AMGf_numeric) && SvROK(arg)) - *sp = sv_2num(arg); + *sp = sv_2num(arg); return FALSE; } @@ -2964,10 +3236,8 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { Do get magic, then see if the two stack args are overloaded and if so call it. Flags: - AMGf_set return the arg using SETs rather than assigning to - the targ - AMGf_assign op may be called as mutator (eg +=) - AMGf_numeric apply sv_2num to the stack arg. + AMGf_assign op may be called as mutator (eg +=) + AMGf_numeric apply sv_2num to the stack arg. */ bool @@ -2978,48 +3248,58 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { SvGETMAGIC(left); if (left != right) - SvGETMAGIC(right); + SvGETMAGIC(right); if (SvAMAGIC(left) || SvAMAGIC(right)) { - SV * const tmpsv = amagic_call(left, right, method, - ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0) - | (flags & AMGf_numarg)); - if (tmpsv) { - if (flags & AMGf_set) { - (void)POPs; - SETs(tmpsv); - } - else { - dATARGET; - (void)POPs; - if (opASSIGN || SvPADMY(TARG)) { - sv_setsv(TARG, tmpsv); - SETTARG; - } - else - SETs(tmpsv); - } - PUTBACK; - return TRUE; - } + SV * tmpsv; + /* STACKED implies mutator variant, e.g. $x += 1 */ + bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED); + + tmpsv = amagic_call(left, right, method, + (mutator ? AMGf_assign: 0) + | (flags & AMGf_numarg)); + if (tmpsv) { + (void)POPs; + /* where the op is one of the two forms: + * $x op= $y + * $lex = $x op $y (where the assign is optimised away) + * then assign the returned value to targ and return that; + * otherwise return the value directly + */ + if ( mutator + || ( (PL_opargs[PL_op->op_type] & OA_TARGLEX) + && (PL_op->op_private & OPpTARGET_MY))) + { + dTARG; + TARG = mutator ? *SP : PAD_SV(PL_op->op_targ); + sv_setsv(TARG, tmpsv); + SETTARG; + } + else + SETs(tmpsv); + + PUTBACK; + return TRUE; + } } + if(left==right && SvGMAGICAL(left)) { - SV * const left = sv_newmortal(); - *(sp-1) = left; - /* Print the uninitialized warning now, so it includes the vari- - able name. */ - if (!SvOK(right)) { - if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); - sv_setsv_flags(left, &PL_sv_no, 0); - } - else sv_setsv_flags(left, right, 0); - SvGETMAGIC(right); + SV * const left = sv_newmortal(); + *(sp-1) = left; + /* Print the uninitialized warning now, so it includes the vari- + able name. */ + if (!SvOK(right)) { + if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); + sv_setbool(left, FALSE); + } + else sv_setsv_flags(left, right, 0); + SvGETMAGIC(right); } if (flags & AMGf_numeric) { - if (SvROK(TOPm1s)) - *(sp-1) = sv_2num(TOPm1s); - if (SvROK(right)) - *sp = sv_2num(right); + if (SvROK(TOPm1s)) + *(sp-1) = sv_2num(TOPm1s); + if (SvROK(right)) + *sp = sv_2num(right); } return FALSE; } @@ -3040,14 +3320,14 @@ Perl_amagic_deref_call(pTHX_ SV *ref, int method) { return ref; while ((tmpsv = amagic_call(ref, &PL_sv_undef, method, - AMGf_noright | AMGf_unary))) { - if (!SvROK(tmpsv)) - Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); - if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { - /* Bail out if it returns us the same reference. */ - return tmpsv; - } - ref = tmpsv; + AMGf_noright | AMGf_unary))) { + if (!SvROK(tmpsv)) + Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); + if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { + /* Bail out if it returns us the same reference. */ + return tmpsv; + } + ref = tmpsv; if (!SvAMAGIC(ref)) break; } @@ -3062,19 +3342,19 @@ Perl_amagic_is_enabled(pTHX_ int method) assert(PL_curcop->cop_hints & HINT_NO_AMAGIC); if ( !lex_mask || !SvOK(lex_mask) ) - /* overloading lexically disabled */ - return FALSE; + /* 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; + /* 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; } @@ -3082,7 +3362,6 @@ Perl_amagic_is_enabled(pTHX_ int method) SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { - dVAR; MAGIC *mg; CV *cv=NULL; CV **cvp=NULL, **ocvp=NULL; @@ -3108,16 +3387,16 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) && (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 - : NULL)) + ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table + : NULL)) && ((cv = cvp[off=method+assignshift]) - || (assign && amtp->fallback > AMGfallNEVER && /* fallback to - * usual method */ - ( + || (assign && amtp->fallback > AMGfallNEVER && /* fallback to + * usual method */ + ( #ifdef DEBUGGING - fl = 1, + fl = 1, #endif - cv = cvp[off=method])))) { + cv = cvp[off=method])))) { lr = -1; /* Call method for left argument */ } else { if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { @@ -3125,30 +3404,32 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) /* look for substituted methods */ /* In all the covered cases we should be called with assign==0. */ - switch (method) { - case inc_amg: - force_cpy = 1; - if ((cv = cvp[off=add_ass_amg]) - || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { - right = &PL_sv_yes; lr = -1; assign = 1; - } - break; - case dec_amg: - force_cpy = 1; - if ((cv = cvp[off = subtr_ass_amg]) - || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { - right = &PL_sv_yes; lr = -1; assign = 1; - } - break; - case bool__amg: - (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); - break; - case numer_amg: - (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); - break; - case string_amg: - (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); - break; + switch (method) { + case inc_amg: + force_cpy = 1; + if ((cv = cvp[off=add_ass_amg]) + || ((cv = cvp[off = add_amg]) + && (force_cpy = 0, (postpr = 1)))) { + right = &PL_sv_yes; lr = -1; assign = 1; + } + break; + case dec_amg: + force_cpy = 1; + if ((cv = cvp[off = subtr_ass_amg]) + || ((cv = cvp[off = subtr_amg]) + && (force_cpy = 0, (postpr=1)))) { + right = &PL_sv_yes; lr = -1; assign = 1; + } + break; + case bool__amg: + (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); + break; + case numer_amg: + (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); + break; + case string_amg: + (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); + break; case not_amg: (void)((cv = cvp[off=bool__amg]) || (cv = cvp[off=numer_amg]) @@ -3156,115 +3437,115 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (cv) postpr = 1; break; - case copy_amg: - { - /* - * SV* ref causes confusion with the interpreter variable of - * the same name - */ - SV* const tmpRef=SvRV(left); - if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { - /* - * Just to be extra cautious. Maybe in some - * additional cases sv_setsv is safe, too. - */ - SV* const newref = newSVsv(tmpRef); - SvOBJECT_on(newref); - /* 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; - } - } - break; - case abs_amg: - if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) - && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { - SV* const nullsv=sv_2mortal(newSViv(0)); - if (off1==lt_amg) { - SV* const lessp = amagic_call(left,nullsv, - lt_amg,AMGf_noright); - logic = SvTRUE(lessp); - } else { - SV* const lessp = amagic_call(left,nullsv, - ncmp_amg,AMGf_noright); - logic = (SvNV(lessp) < 0); - } - if (logic) { - if (off==subtr_amg) { - right = left; - left = nullsv; - lr = 1; - } - } else { - return left; - } - } - break; - case neg_amg: - if ((cv = cvp[off=subtr_amg])) { - right = left; - left = sv_2mortal(newSViv(0)); - lr = 1; - } - break; - case int_amg: - case iter_amg: /* XXXX Eventually should do to_gv. */ - case ftest_amg: /* XXXX Eventually should do to_gv. */ - case regexp_amg: - /* FAIL safe */ - return NULL; /* Delegate operation to standard mechanisms. */ - - case to_sv_amg: - case to_av_amg: - case to_hv_amg: - case to_gv_amg: - case to_cv_amg: - /* FAIL safe */ - return left; /* Delegate operation to standard mechanisms. */ - - default: - goto not_found; - } - if (!cv) goto not_found; + case copy_amg: + { + /* + * SV* ref causes confusion with the interpreter variable of + * the same name + */ + SV* const tmpRef=SvRV(left); + if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { + /* + * Just to be extra cautious. Maybe in some + * additional cases sv_setsv is safe, too. + */ + SV* const newref = newSVsv(tmpRef); + SvOBJECT_on(newref); + /* 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; + } + } + break; + case abs_amg: + if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) + && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { + SV* const nullsv=&PL_sv_zero; + if (off1==lt_amg) { + SV* const lessp = amagic_call(left,nullsv, + lt_amg,AMGf_noright); + logic = SvTRUE_NN(lessp); + } else { + SV* const lessp = amagic_call(left,nullsv, + ncmp_amg,AMGf_noright); + logic = (SvNV(lessp) < 0); + } + if (logic) { + if (off==subtr_amg) { + right = left; + left = nullsv; + lr = 1; + } + } else { + return left; + } + } + break; + case neg_amg: + if ((cv = cvp[off=subtr_amg])) { + right = left; + left = &PL_sv_zero; + lr = 1; + } + break; + case int_amg: + case iter_amg: /* XXXX Eventually should do to_gv. */ + case ftest_amg: /* XXXX Eventually should do to_gv. */ + case regexp_amg: + /* FAIL safe */ + return NULL; /* Delegate operation to standard mechanisms. */ + + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return left; /* Delegate operation to standard mechanisms. */ + + default: + goto not_found; + } + if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(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 */ + && (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; } else if (((cvp && amtp->fallback > AMGfallNEVER) || (ocvp && oamtp->fallback > AMGfallNEVER)) - && !(flags & AMGf_unary)) { - /* We look for substitution for - * comparison operations and - * concatenation */ + && !(flags & AMGf_unary)) { + /* We look for substitution for + * comparison operations and + * concatenation */ if (method==concat_amg || method==concat_ass_amg - || method==repeat_amg || method==repeat_ass_amg) { - return NULL; /* Delegate operation to string conversion */ + || method==repeat_amg || method==repeat_ass_amg) { + return NULL; /* Delegate operation to string conversion */ } off = -1; switch (method) { - case lt_amg: - case le_amg: - case gt_amg: - case ge_amg: - case eq_amg: - case ne_amg: + case lt_amg: + case le_amg: + case gt_amg: + case ge_amg: + case eq_amg: + case ne_amg: off = ncmp_amg; break; - case slt_amg: - case sle_amg: - case sgt_amg: - case sge_amg: - case seq_amg: - case sne_amg: + case slt_amg: + case sle_amg: + case sgt_amg: + case sge_amg: + case seq_amg: + case sne_amg: off = scmp_amg; break; - } + } if (off != -1) { if (ocvp && (oamtp->fallback > AMGfallNEVER)) { cv = ocvp[off]; @@ -3282,51 +3563,51 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } else { not_found: /* No method found, either report or croak */ switch (method) { - case to_sv_amg: - case to_av_amg: - case to_hv_amg: - case to_gv_amg: - case to_cv_amg: - /* FAIL safe */ - return left; /* Delegate operation to standard mechanisms. */ + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return left; /* Delegate operation to standard mechanisms. */ } if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ - notfound = 1; lr = -1; + notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { - notfound = 1; lr = 1; + notfound = 1; lr = 1; } else if ((use_default_op = (!ocvp || oamtp->fallback >= AMGfallYES) && (!cvp || amtp->fallback >= AMGfallYES)) && !DEBUG_o_TEST) { - /* Skip generating the "no method found" message. */ - return NULL; + /* Skip generating the "no method found" message. */ + return NULL; } else { - SV *msg; - if (off==-1) off=method; - msg = sv_2mortal(Perl_newSVpvf(aTHX_ - "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))); + SV *msg; + if (off==-1) off=method; + msg = sv_2mortal(Perl_newSVpvf(aTHX_ + "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_ "%" SVf, SVfARG(msg)) ); - } else { - Perl_croak(aTHX_ "%" SVf, SVfARG(msg)); - } - return NULL; + DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) ); + } else { + Perl_croak(aTHX_ "%" SVf, SVfARG(msg)); + } + return NULL; } force_cpy = force_cpy || assign; } @@ -3395,18 +3676,18 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ - "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n", - AMG_id2name(off), - method+assignshift==off? "" : - " (initially \"", - method+assignshift==off? "" : - AMG_id2name(method+assignshift), - method+assignshift==off? "" : "\")", - flags & AMGf_unary? "" : - lr==1 ? " for right argument": " for left argument", - flags & AMGf_unary? " for argument" : "", - stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), - fl? ",\n\tassignment variant used": "") ); + "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n", + AMG_id2name(off), + method+assignshift==off? "" : + " (initially \"", + method+assignshift==off? "" : + AMG_id2name(method+assignshift), + method+assignshift==off? "" : "\")", + flags & AMGf_unary? "" : + lr==1 ? " for right argument": " for left argument", + flags & AMGf_unary? " for argument" : "", + stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), + fl? ",\n\tassignment variant used": "") ); } #endif /* Since we use shallow copy during assignment, we need @@ -3432,7 +3713,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) * In the latter case assignshift==0, so only notfound case is important. */ if ( (lr == -1) && ( ( (method + assignshift == off) - && (assign || (method == inc_amg) || (method == dec_amg))) + && (assign || (method == inc_amg) || (method == dec_amg))) || force_cpy) ) { /* newSVsv does not behave as advertised, so we copy missing @@ -3440,9 +3721,9 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SV *tmpRef = SvRV(left); SV *rv_copy; if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) { - SvRV_set(left, rv_copy); - SvSETMAGIC(left); - SvREFCNT_dec_NN(tmpRef); + SvRV_set(left, rv_copy); + SvSETMAGIC(left); + SvREFCNT_dec_NN(tmpRef); } } @@ -3452,7 +3733,12 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SV* res; const bool oldcatch = CATCH_GET; I32 oldmark, nret; - U8 gimme = force_scalar ? G_SCALAR : GIMME_V; + /* for multiconcat, we may call overload several times, + * with the context of individual concats being scalar, + * regardless of the overall context of the multiconcat op + */ + U8 gimme = (force_scalar || PL_op->op_type == OP_MULTICONCAT) + ? G_SCALAR : GIMME_V; CATCH_SET(TRUE); Zero(&myop, 1, BINOP); @@ -3464,7 +3750,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case G_VOID: myop.op_flags |= OPf_WANT_VOID; break; - case G_ARRAY: + case G_LIST: if (flags & AMGf_want_list) { myop.op_flags |= OPf_WANT_LIST; break; @@ -3480,7 +3766,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SAVEOP(); PL_op = (OP *) &myop; if (PERLDB_SUB && PL_curstash != PL_debstash) - PL_op->op_private |= OPpENTERSUB_DB; + PL_op->op_private |= OPpENTERSUB_DB; Perl_pp_pushmark(aTHX); EXTEND(SP, notfound + 5); @@ -3489,7 +3775,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), - AMG_id2namelen(method + assignshift), SVs_TEMP)); + AMG_id2namelen(method + assignshift), SVs_TEMP)); } else if (flags & AMGf_numarg) PUSHs(&PL_sv_undef); @@ -3513,7 +3799,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) res = &PL_sv_undef; SP = PL_stack_base + oldmark; break; - case G_ARRAY: { + case G_LIST: if (flags & AMGf_want_list) { res = sv_2mortal((SV *)newAV()); av_extend((AV *)res, nret); @@ -3522,7 +3808,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) break; } /* FALLTHROUGH */ - } default: res = POPs; break; @@ -3537,34 +3822,34 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) switch (method) { case le_amg: case sle_amg: - ans=SvIV(res)<=0; break; + ans=SvIV(res)<=0; break; case lt_amg: case slt_amg: - ans=SvIV(res)<0; break; + ans=SvIV(res)<0; break; case ge_amg: case sge_amg: - ans=SvIV(res)>=0; break; + ans=SvIV(res)>=0; break; case gt_amg: case sgt_amg: - ans=SvIV(res)>0; break; + ans=SvIV(res)>0; break; case eq_amg: case seq_amg: - ans=SvIV(res)==0; break; + ans=SvIV(res)==0; break; case ne_amg: case sne_amg: - ans=SvIV(res)!=0; break; + ans=SvIV(res)!=0; break; case inc_amg: case dec_amg: - SvSetSV(left,res); return left; + SvSetSV(left,res); return left; case not_amg: - ans=!SvTRUE(res); break; + ans=!SvTRUE_NN(res); break; default: ans=0; break; } return boolSV(ans); } else if (method==copy_amg) { if (!SvROK(res)) { - Perl_croak(aTHX_ "Copy method did not return a reference"); + Perl_croak(aTHX_ "Copy method did not return a reference"); } return SvREFCNT_inc(SvRV(res)); } else { @@ -3576,16 +3861,15 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) void Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) { - dVAR; U32 hash; PERL_ARGS_ASSERT_GV_NAME_SET; if (len > I32_MAX) - Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len); + Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len); if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { - unshare_hek(GvNAME_HEK(gv)); + unshare_hek(GvNAME_HEK(gv)); } PERL_HASH(hash, name, len); @@ -3626,47 +3910,47 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) if (PL_phase == PERL_PHASE_DESTRUCT) return; if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && - !SvOBJECT(gv) && !SvREADONLY(gv) && - isGV_with_GP(gv) && GvGP(gv) && - !GvINTRO(gv) && GvREFCNT(gv) == 1 && - !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && - GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) - return; + !SvOBJECT(gv) && !SvREADONLY(gv) && + isGV_with_GP(gv) && GvGP(gv) && + !GvINTRO(gv) && GvREFCNT(gv) == 1 && + !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && + GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) + return; if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv) - return; + return; if (SvMAGICAL(gv)) { MAGIC *mg; - /* only backref magic is allowed */ - if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) - return; + /* only backref magic is allowed */ + if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) + return; for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) { if (mg->mg_type != PERL_MAGIC_backref) return; - } + } } cv = GvCV(gv); if (!cv) { - HEK *gvnhek = GvNAME_HEK(gv); - (void)hv_deletehek(stash, gvnhek, G_DISCARD); + HEK *gvnhek = GvNAME_HEK(gv); + (void)hv_deletehek(stash, gvnhek, G_DISCARD); } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 && - !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && - CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv && - CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && - !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && - (namehek = GvNAME_HEK(gv)) && - (gvp = hv_fetchhek(stash, namehek, 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|SVprv_PCS_IMPORTED * imported; + !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && + CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv && + CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && + !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && + (namehek = GvNAME_HEK(gv)) && + (gvp = hv_fetchhek(stash, namehek, 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|SVprv_PCS_IMPORTED * imported; /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */ - SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - - STRUCT_OFFSET(XPVIV, xiv_iv)); - SvRV_set(gv, value); + SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - + STRUCT_OFFSET(XPVIV, xiv_iv)); + SvRV_set(gv, value); } } @@ -3680,9 +3964,9 @@ Perl_gv_override(pTHX_ const char * const name, const STRLEN len) gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE); gv = gvp ? *gvp : NULL; if (gv && !isGV(gv)) { - if (!SvPCS_IMPORTED(gv)) return NULL; - gv_init(gv, PL_globalstash, name, len, 0); - return gv; + if (!SvPCS_IMPORTED(gv)) return NULL; + gv_init(gv, PL_globalstash, name, len, 0); + return gv; } return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL; }