X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/218fa151b7edc486a27eb8ece21cda2538edf177..547ae1291622100dc17f3ab6cb5aac35f22c5e43:/op.c diff --git a/op.c b/op.c index 939b478..93a9678 100644 --- a/op.c +++ b/op.c @@ -1114,6 +1114,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_GGRGID: case OP_GETLOGIN: case OP_PROTOTYPE: + case OP_RUNCV: func_ops: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) /* Otherwise it's "Useless use of grep iterator" */ @@ -1467,7 +1468,7 @@ Perl_finalize_optree(pTHX_ OP* o) LEAVE; } -void +STATIC void S_finalize_op(pTHX_ OP* o) { PERL_ARGS_ASSERT_FINALIZE_OP; @@ -2558,11 +2559,26 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) || rtype == OP_TRANSR ) ? (int)rtype : OP_MATCH]; - const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV) + const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV; + GV *gv; + SV * const name = + (ltype == OP_RV2AV || ltype == OP_RV2HV) + ? cUNOPx(left)->op_first->op_type == OP_GV + && (gv = cGVOPx_gv(cUNOPx(left)->op_first)) + ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1) + : NULL + : varname(NULL, isary ? '@' : '%', left->op_targ, NULL, 0, 1); + if (name) + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Applying %s to %"SVf" will act on scalar(%"SVf")", + desc, name, name); + else { + const char * const sample = (isary ? "@array" : "%hash"); - Perl_warner(aTHX_ packWARN(WARN_MISC), + Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %s will act on scalar(%s)", desc, sample, sample); + } } if (rtype == OP_CONST && @@ -3091,6 +3107,7 @@ OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) { dVAR; + if (type < 0) type = -type, flags |= OPf_SPECIAL; if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, NULL); else @@ -3597,6 +3614,11 @@ Perl_newOP(pTHX_ I32 type, I32 flags) dVAR; OP *o; + if (type == -OP_ENTEREVAL) { + type = OP_ENTEREVAL; + flags |= OPpEVAL_BYTES<<8; + } + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP @@ -3639,6 +3661,11 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) dVAR; UNOP *unop; + if (type == -OP_ENTEREVAL) { + type = OP_ENTEREVAL; + flags |= OPpEVAL_BYTES<<8; + } + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP @@ -4508,10 +4535,10 @@ Perl_package(pTHX_ OP *o) PERL_ARGS_ASSERT_PACKAGE; - save_hptr(&PL_curstash); + SAVEGENERICSV(PL_curstash); save_item(PL_curstname); - PL_curstash = gv_stashsv(sv, GV_ADD); + PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD)); sv_setsv(PL_curstname, sv); @@ -6250,9 +6277,23 @@ void Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, const STRLEN len, const U32 flags) { + const char * const cvp = CvPROTO(cv); + const STRLEN clen = CvPROTOLEN(cv); + PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; - if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */ - || (p && !sv_eq((SV*)cv, newSVpvn_flags(p, len, flags | SVs_TEMP)))) + + if (((!p != !cvp) /* One has prototype, one has not. */ + || (p && ( + (flags & SVf_UTF8) == SvUTF8(cv) + ? len != clen || memNE(cvp, p, len) + : flags & SVf_UTF8 + ? bytes_cmp_utf8((const U8 *)cvp, clen, + (const U8 *)p, len) + : bytes_cmp_utf8((const U8 *)p, len, + (const U8 *)cvp, clen) + ) + ) + ) && ckWARN_d(WARN_PROTOTYPE)) { SV* const msg = sv_newmortal(); SV* name = NULL; @@ -6263,7 +6304,9 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, if (name) Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); if (SvPOK(cv)) - Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv)); + Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", + SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP)) + ); else sv_catpvs(msg, ": none"); sv_catpvs(msg, " vs "); @@ -6431,7 +6474,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; - const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL; + STRLEN namlen = 0; + const char * const name = o ? SvPV_const(cSVOPo->op_sv, namlen) : NULL; bool has_name; bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0; @@ -6540,19 +6584,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) && block->op_type != OP_NULL #endif ) { - if (ckWARN(WARN_REDEFINE) - || (CvCONST(cv) - && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) - { - const line_t oldline = CopLINE(PL_curcop); - if (PL_parser && PL_parser->copline != NOLINE) + const line_t oldline = CopLINE(PL_curcop); + if (PL_parser && PL_parser->copline != NOLINE) CopLINE_set(PL_curcop, PL_parser->copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - CvCONST(cv) ? "Constant subroutine %"SVf" redefined" - : "Subroutine %"SVf" redefined", - SVfARG(cSVOPo->op_sv)); - CopLINE_set(PL_curcop, oldline); - } + report_redefined_cv(cSVOPo->op_sv, cv, &const_sv); + CopLINE_set(PL_curcop, oldline); #ifdef PERL_MAD if (!PL_minus_c) /* keep old one around for madskills */ #endif @@ -6565,6 +6601,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } if (const_sv) { + HV *stash; SvREFCNT_inc_simple_void_NN(const_sv); if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); @@ -6576,15 +6613,19 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } else { GvCV_set(gv, NULL); - cv = newCONSTSUB_flags(NULL, name, name_is_utf8 ? SVf_UTF8 : 0, const_sv); + cv = newCONSTSUB_flags( + NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, + const_sv + ); } - mro_method_changed_in( /* sub Foo::Bar () { 123 } */ + stash = (CvGV(cv) && GvSTASH(CvGV(cv))) ? GvSTASH(CvGV(cv)) : CvSTASH(cv) ? CvSTASH(cv) - : PL_curstash - ); + : PL_curstash; + if (HvENAME_HEK(stash)) + mro_method_changed_in(stash); /* sub Foo::Bar () { 123 } */ if (PL_madskills) goto install_block; op_free(block); @@ -6646,7 +6687,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } GvCVGEN(gv) = 0; - mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */ + if (HvENAME_HEK(GvSTASH(gv))) + /* sub Foo::bar { (shift)+1 } */ + mro_method_changed_in(GvSTASH(gv)); } } if (!CvGV(cv)) { @@ -6654,12 +6697,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); } - attrs: - if (attrs) { - /* Need to do a C. */ - HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; - apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE); - } if (ps) { sv_setpvn(MUTABLE_SV(cv), ps, ps_len); @@ -6687,7 +6724,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } install_block: if (!block) - goto done; + goto attrs; /* If we assign an optree to a PVCV, then we've defined a subroutine that the debugger could be able to set a breakpoint in, so signal to @@ -6727,7 +6764,14 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvCONST_on(cv); } - if (has_name) { + attrs: + if (attrs) { + /* Need to do a C. */ + HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; + apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE); + } + + if (block && has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { SV * const tmpstr = sv_newmortal(); GV * const db_postponed = gv_fetchpvs("DB::postponed", @@ -6779,13 +6823,13 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, ENTER; SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); + SAVEVPTR(PL_curcop); DEBUG_x( dump_sub(gv) ); Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); GvCV_set(gv,0); /* cv has been hijacked */ call_list(oldscope, PL_beginav); - PL_curcop = &PL_compiling; CopHINTS_set(&PL_compiling, PL_hints); LEAVE; } @@ -6841,7 +6885,7 @@ See L. CV * Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) { - return newCONSTSUB_flags(stash, name, 0, sv); + return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv); } /* @@ -6861,7 +6905,8 @@ compile time.) */ CV * -Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv) +Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len, + U32 flags, SV *sv) { dVAR; CV* cv; @@ -6879,6 +6924,8 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv) * an op shared between threads. Use a non-shared COP for our * dirty work */ SAVEVPTR(PL_curcop); + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); PL_curcop = &PL_compiling; } SAVECOPLINE(PL_curcop); @@ -6888,9 +6935,9 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv) PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) { - SAVESPTR(PL_curstash); + SAVEGENERICSV(PL_curstash); SAVECOPSTASH(PL_curcop); - PL_curstash = stash; + PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash); CopSTASH_set(PL_curcop,stash); } @@ -6898,8 +6945,8 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv) and so doesn't get free()d. (It's expected to be from the C pre- processor __FILE__ directive). But we need a dynamically allocated one, and we need it to get freed. */ - cv = newXS_flags(name, const_sv_xsub, file ? file : "", "", - XS_DYNAMIC_FILENAME | flags); + cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "", + &sv, XS_DYNAMIC_FILENAME | flags); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); @@ -6917,12 +6964,28 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags) { + PERL_ARGS_ASSERT_NEWXS_FLAGS; + return newXS_len_flags( + name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags + ); +} + +CV * +Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, + XSUBADDR_t subaddr, const char *const filename, + const char *const proto, SV **const_svp, + U32 flags) +{ CV *cv; - PERL_ARGS_ASSERT_NEWXS_FLAGS; + PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS; { - GV * const gv = gv_fetchpv(name ? name : + GV * const gv = name + ? gv_fetchpvn( + name,len,GV_ADDMULTI|flags,SVt_PVCV + ) + : gv_fetchpv( (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), GV_ADDMULTI | flags, SVt_PVCV); @@ -6937,25 +7000,17 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, } else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ - if (ckWARN(WARN_REDEFINE)) { - GV * const gvcv = CvGV(cv); - if (gvcv) { - HV * const stash = GvSTASH(gvcv); - if (stash) { - const char *redefined_name = HvNAME_get(stash); - if ( redefined_name && - strEQ(redefined_name,"autouse") ) { - const line_t oldline = CopLINE(PL_curcop); - if (PL_parser && PL_parser->copline != NOLINE) - CopLINE_set(PL_curcop, PL_parser->copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - CvCONST(cv) ? "Constant subroutine %s redefined" - : "Subroutine %s redefined" - ,name); - CopLINE_set(PL_curcop, oldline); - } - } - } + /* Redundant check that allows us to avoid creating an SV + most of the time: */ + if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { + const line_t oldline = CopLINE(PL_curcop); + if (PL_parser && PL_parser->copline != NOLINE) + CopLINE_set(PL_curcop, PL_parser->copline); + report_redefined_cv(newSVpvn_flags( + name,len,(flags&SVf_UTF8)|SVs_TEMP + ), + cv, const_svp); + CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); cv = NULL; @@ -6969,7 +7024,8 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, if (name) { GvCV_set(gv,cv); GvCVGEN(gv) = 0; - mro_method_changed_in(GvSTASH(gv)); /* newXS */ + if (HvENAME_HEK(GvSTASH(gv))) + mro_method_changed_in(GvSTASH(gv)); /* newXS */ } } if (!name) @@ -7261,6 +7317,32 @@ Perl_ck_bitop(pTHX_ OP *o) return o; } +PERL_STATIC_INLINE bool +is_dollar_bracket(pTHX_ const OP * const o) +{ + const OP *kid; + return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS + && (kid = cUNOPx(o)->op_first) + && kid->op_type == OP_GV + && strEQ(GvNAME(cGVOPx_gv(kid)), "["); +} + +OP * +Perl_ck_cmp(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_CMP; + if (ckWARN(WARN_SYNTAX)) { + const OP *kid = cUNOPo->op_first; + if (kid && ( + is_dollar_bracket(aTHX_ kid) + || ((kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid)) + )) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "$[ used in %s (did you mean $] ?)", OP_DESC(o)); + } + return o; +} + OP * Perl_ck_concat(pTHX_ OP *o) { @@ -7420,21 +7502,28 @@ Perl_ck_eval(pTHX_ OP *o) } } else { + const U8 priv = o->op_private; #ifdef PERL_MAD OP* const oldo = o; #else op_free(o); #endif - o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP()); + o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); op_getmad(oldo,o,'O'); } o->op_targ = (PADOFFSET)PL_hints; - if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) { + if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8; + if ((PL_hints & HINT_LOCALIZE_HH) != 0 + && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) { /* Store a copy of %^H that pp_entereval can pick up. */ OP *hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv)))); cUNOPo->op_first->op_sibling = hhop; o->op_private |= OPpEVAL_HAS_HH; + + if (!(o->op_private & OPpEVAL_BYTES) + && FEATURE_IS_ENABLED("unieval")) + o->op_private |= OPpEVAL_UNICODE; } return o; } @@ -7966,6 +8055,7 @@ Perl_ck_glob(pTHX_ OP *o) { dVAR; GV *gv; + const bool core = o->op_flags & OPf_SPECIAL; PERL_ARGS_ASSERT_CK_GLOB; @@ -7973,7 +8063,8 @@ Perl_ck_glob(pTHX_ OP *o) if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */ - if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV)) + if (core) gv = NULL; + else if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV)) && GvCVu(gv) && GvIMPORTED_CV(gv))) { gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); @@ -7981,21 +8072,13 @@ Perl_ck_glob(pTHX_ OP *o) #if !defined(PERL_EXTERNAL_GLOB) if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) { - GV *glob_gv; ENTER; Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs("File::Glob"), NULL, NULL, NULL); - if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) { - gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); - GvCV_set(gv, GvCV(glob_gv)); - SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv))); - GvIMPORTED_CV_on(gv); - } LEAVE; } -#endif /* PERL_EXTERNAL_GLOB */ +#endif /* !PERL_EXTERNAL_GLOB */ - assert(!(o->op_flags & OPf_SPECIAL)); if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { /* convert * glob @@ -8022,8 +8105,12 @@ Perl_ck_glob(pTHX_ OP *o) o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */ return o; } + else o->op_flags &= ~OPf_SPECIAL; gv = newGVgen("main"); gv_IOadd(gv); +#ifndef PERL_EXTERNAL_GLOB + sv_setiv(GvSVn(gv),PL_glob_index++); +#endif op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); scalarkids(o); return o; @@ -8510,10 +8597,14 @@ Perl_ck_require(pTHX_ OP *o) } if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { - OP * const kid = cUNOPo->op_first; - OP * newop; - - cUNOPo->op_first = 0; + OP *kid, *newop; + if (o->op_flags & OPf_KIDS) { + kid = cUNOPo->op_first; + cUNOPo->op_first = NULL; + } + else { + kid = newDEFSVOP(); + } #ifndef PERL_MAD op_free(o); #endif @@ -8997,7 +9088,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO; if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto"); - proto = SvPV(protosv, proto_len); + if (SvTYPE(protosv) == SVt_PVCV) + proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); + else proto = SvPV(protosv, proto_len); proto_end = proto + proto_len; aop = cUNOPx(entersubop)->op_first; if (!aop->op_sibling) @@ -9305,7 +9398,7 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) } else { OP *prev, *cvop; - U32 paren; + U32 flags; #ifdef PERL_MAD bool seenarg = FALSE; #endif @@ -9324,16 +9417,20 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) #endif ; prev->op_sibling = NULL; - paren = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN); + flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN); op_free(cvop); if (aop == cvop) aop = NULL; op_free(entersubop); + if (opnum == OP_ENTEREVAL + && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9)) + flags |= OPpEVAL_BYTES <<8; + switch (PL_opargs[opnum] & OA_CLASS_MASK) { case OA_UNOP: case OA_BASEOP_OR_UNOP: case OA_FILESTATOP: - return aop ? newUNOP(opnum,paren,aop) : newOP(opnum,paren); + return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags); case OA_BASEOP: if (aop) { #ifdef PERL_MAD @@ -9595,6 +9692,57 @@ Perl_ck_each(pTHX_ OP *o) return o->op_type == ref_type ? o : ck_fun(o); } +OP * +Perl_ck_length(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_LENGTH; + + o = ck_fun(o); + + if (ckWARN(WARN_SYNTAX)) { + const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL; + + if (kid) { + SV *name = NULL; + const bool hash = kid->op_type == OP_PADHV + || kid->op_type == OP_RV2HV; + switch (kid->op_type) { + case OP_PADHV: + case OP_PADAV: + name = varname( + NULL, hash ? '%' : '@', kid->op_targ, NULL, 0, 1 + ); + break; + case OP_RV2HV: + case OP_RV2AV: + if (cUNOPx(kid)->op_first->op_type != OP_GV) break; + { + GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first); + if (!gv) break; + name = varname(gv, hash?'%':'@', 0, NULL, 0, 1); + } + break; + default: + return o; + } + if (name) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "length() used on %"SVf" (did you mean \"scalar(%s%"SVf + ")\"?)", + name, hash ? "keys " : "", name + ); + else if (hash) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)"); + else + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "length() used on @array (did you mean \"scalar(@array)\"?)"); + } + } + + return o; +} + /* caller is supposed to assign the return to the container of the rep_op var */ STATIC OP * @@ -9680,6 +9828,7 @@ S_inplace_aassign(pTHX_ OP *o) { if (oright->op_type != OP_RV2AV || !cUNOPx(oright)->op_first || cUNOPx(oright)->op_first->op_type != OP_GV + || cUNOPx(oleft )->op_first->op_type != OP_GV || cGVOPx_gv(cUNOPx(oleft)->op_first) != cGVOPx_gv(cUNOPx(oright)->op_first) ) @@ -10286,6 +10435,8 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, retsetpvs("+;$$@", OP_SPLICE); case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__: retsetpvs("", 0); + case KEY_evalbytes: + name = "entereval"; break; case KEY_readpipe: name = "backtick"; } @@ -10380,10 +10531,15 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, return op_append_elem( OP_LINESEQ, argop, newOP(opnum, - opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0) + opnum == OP_WANTARRAY || opnum == OP_RUNCV + ? OPpOFFBYONE << 8 : 0) ); case OA_BASEOP_OR_UNOP: - o = newUNOP(opnum,0,argop); + if (opnum == OP_ENTEREVAL) { + o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop); + if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES; + } + else o = newUNOP(opnum,0,argop); if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE; else { onearg: @@ -10406,6 +10562,45 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, } } +void +Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, + SV * const *new_const_svp) +{ + const char *hvname; + bool is_const = !!CvCONST(old_cv); + SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL; + + PERL_ARGS_ASSERT_REPORT_REDEFINED_CV; + + if (is_const && new_const_svp && old_const_sv == *new_const_svp) + return; + /* They are 2 constant subroutines generated from + the same constant. This probably means that + they are really the "same" proxy subroutine + instantiated in 2 places. Most likely this is + when a constant is exported twice. Don't warn. + */ + if ( + (ckWARN(WARN_REDEFINE) + && !( + CvGV(old_cv) && GvSTASH(CvGV(old_cv)) + && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7 + && (hvname = HvNAME(GvSTASH(CvGV(old_cv))), + strEQ(hvname, "autouse")) + ) + ) + || (is_const + && ckWARN_d(WARN_REDEFINE) + && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp)) + ) + ) + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + is_const + ? "Constant subroutine %"SVf" redefined" + : "Subroutine %"SVf" redefined", + name); +} + #include "XSUB.h" /* Efficient sub that returns a constant scalar value. */