X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7c864bb3ffceec4b5c696507d5fc0d4e9e2f13b3..778a861bb0a8d42e4be677cc40a39d1fac0babe5:/op.c?ds=sidebyside diff --git a/op.c b/op.c index 8727db4..a9296f3 100644 --- a/op.c +++ b/op.c @@ -102,6 +102,7 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #define PERL_IN_OP_C #include "perl.h" #include "keywords.h" +#include "feature.h" #define CALL_PEEP(o) PL_peepp(aTHX_ o) #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) @@ -836,7 +837,8 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context) case G_ARRAY: return list(o); case G_VOID: return scalarvoid(o); default: - Perl_croak(aTHX_ "panic: op_contextualize bad context"); + Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", + (long) context); return o; } } @@ -1114,6 +1116,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" */ @@ -1164,14 +1167,6 @@ Perl_scalarvoid(pTHX_ OP *o) no_bareword_allowed(o); else { if (ckWARN(WARN_VOID)) { - if (SvOK(sv)) { - SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ - "a constant (%"SVf")", sv)); - useless = SvPV_nolen(msv); - useless_is_utf8 = SvUTF8(msv); - } - else - useless = "a constant (undef)"; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) @@ -1193,7 +1188,24 @@ Perl_scalarvoid(pTHX_ OP *o) strnEQ(maybe_macro, "ds", 2) || strnEQ(maybe_macro, "ig", 2)) useless = NULL; + else { + SV * const dsv = newSVpvs(""); + SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ + "a constant (%s)", + pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT ))); + SvREFCNT_dec(dsv); + useless = SvPV_nolen(msv); + useless_is_utf8 = SvUTF8(msv); + } + } + else if (SvOK(sv)) { + SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_ + "a constant (%"SVf")", sv)); + useless = SvPV_nolen(msv); } + else + useless = "a constant (undef)"; } } op_null(o); /* don't execute or even remember it */ @@ -1729,6 +1741,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID ); + if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB; + switch (o->op_type) { case OP_UNDEF: localize = 0; @@ -1755,7 +1769,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV)); PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { - /* Backward compatibility mode: */ + /* Potential lvalue context: */ o->op_private |= OPpENTERSUB_INARGS; break; } @@ -1775,29 +1789,6 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) while (kid->op_sibling) kid = kid->op_sibling; if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) { - /* Indirect call */ - if (kid->op_type == OP_METHOD_NAMED - || kid->op_type == OP_METHOD) - { - UNOP *newop; - - NewOp(1101, newop, 1, UNOP); - newop->op_type = OP_RV2CV; - newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; - newop->op_first = NULL; - newop->op_next = (OP*)newop; - kid->op_sibling = (OP*)newop; - newop->op_private |= OPpLVAL_INTRO; - newop->op_private &= ~1; - break; - } - - if (kid->op_type != OP_RV2CV) - Perl_croak(aTHX_ - "panic: unexpected lvalue entersub " - "entry via type/targ %ld:%"UVuf, - (long)kid->op_type, (UV)kid->op_targ); - kid->op_private |= OPpLVAL_INTRO; break; /* Postpone until runtime */ } @@ -1811,25 +1802,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) "entry via type/targ %ld:%"UVuf, (long)kid->op_type, (UV)kid->op_targ); if (kid->op_type != OP_GV) { - /* Restore RV2CV to check lvalueness */ - restore_2cv: - if (kid->op_next && kid->op_next != kid) { /* Happens? */ - okid->op_next = kid->op_next; - kid->op_next = okid; - } - else - okid->op_next = NULL; - okid->op_type = OP_RV2CV; - okid->op_targ = 0; - okid->op_ppaddr = PL_ppaddr[OP_RV2CV]; - okid->op_private |= OPpLVAL_INTRO; - okid->op_private &= ~1; break; } cv = GvCV(kGVOP_gv); if (!cv) - goto restore_2cv; + break; if (CvLVALUE(cv)) break; } @@ -2424,6 +2402,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) my_kid(kid, attrs, imopsp); + return o; } else if (type == OP_UNDEF #ifdef PERL_MAD || type == OP_STUB @@ -2566,7 +2545,9 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) && (gv = cGVOPx_gv(cUNOPx(left)->op_first)) ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1) : NULL - : varname(NULL, isary ? '@' : '%', left->op_targ, NULL, 0, 1); + : varname( + (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1 + ); if (name) Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %"SVf" will act on scalar(%"SVf")", @@ -2965,7 +2946,7 @@ S_fold_constants(pTHX_ register OP *o) case OP_SCMP: case OP_SPRINTF: /* XXX what about the numeric ops? */ - if (PL_hints & HINT_LOCALE) + if (IN_LOCALE_COMPILETIME) goto nope; break; } @@ -4128,10 +4109,13 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) if (PL_hints & HINT_RE_TAINT) pmop->op_pmflags |= PMf_RETAINT; - if (PL_hints & HINT_LOCALE) { + if (IN_LOCALE_COMPILETIME) { set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); } - else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) { + else if ((! (PL_hints & HINT_BYTES)) + /* Both UNI_8_BIT and locale :not_characters imply Unicode */ + && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS))) + { set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); } if (PL_hints & HINT_RE_FLAGS) { @@ -4504,6 +4488,7 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) PVOP *pvop; assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || type == OP_RUNCV || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); NewOp(1101, pvop, 1, PVOP); @@ -4667,22 +4652,32 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) newSTATEOP(0, NULL, imop) )); if (use_version) { - /* If we request a version >= 5.9.5, load feature.pm with the + HV * const hinthv = GvHV(PL_hintgv); + const bool hhoff = !hinthv || !(PL_hints & HINT_LOCALIZE_HH); + + /* Enable the * feature bundle that corresponds to the required version. */ use_version = sv_2mortal(new_version(use_version)); + S_enable_feature_bundle(aTHX_ use_version); - if (vcmp(use_version, - sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { - SV *const importsv = vnormal(use_version); - *SvPVX_mutable(importsv) = ':'; - ENTER_with_name("load_feature"); - Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); - LEAVE_with_name("load_feature"); - } /* If a version >= 5.11.0 is requested, strictures are on by default! */ if (vcmp(use_version, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { - PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS); + if (hhoff || !hv_exists(hinthv, "strict/refs", 11)) + PL_hints |= HINT_STRICT_REFS; + if (hhoff || !hv_exists(hinthv, "strict/subs", 11)) + PL_hints |= HINT_STRICT_SUBS; + if (hhoff || !hv_exists(hinthv, "strict/vars", 11)) + PL_hints |= HINT_STRICT_VARS; + } + /* otherwise they are off */ + else { + if (hhoff || !hv_exists(hinthv, "strict/refs", 11)) + PL_hints &= ~HINT_STRICT_REFS; + if (hhoff || !hv_exists(hinthv, "strict/subs", 11)) + PL_hints &= ~HINT_STRICT_SUBS; + if (hhoff || !hv_exists(hinthv, "strict/vars", 11)) + PL_hints &= ~HINT_STRICT_VARS; } } @@ -4729,7 +4724,7 @@ Loads the module whose name is pointed to by the string part of name. Note that the actual module name, not its filename, should be given. Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS -(or 0 for no flags). ver, if specified, provides version semantics +(or 0 for no flags). ver, if specified and not NULL, provides version semantics similar to C. The optional trailing SV* arguments can be used to specify arguments to the module's import() method, similar to C. They must be @@ -4738,6 +4733,8 @@ be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. Otherwise at least a single NULL pointer to designate the default import list is required. +The reference count for each specified C parameter is decremented. + =cut */ void @@ -6121,6 +6118,7 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, /* This is a default {} block */ enterop->op_first = block; enterop->op_flags |= OPf_SPECIAL; + o ->op_flags |= OPf_SPECIAL; o->op_next = (OP *) enterop; } @@ -6457,6 +6455,13 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { + return newATTRSUB_flags(floor, o, proto, attrs, block, 0); +} + +CV * +Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, + OP *block, U32 flags) +{ dVAR; GV *gv; const char *ps; @@ -6473,9 +6478,12 @@ 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 bool o_is_gv = flags & 1; + const char * const name = + o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; - bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0; + bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); if (proto) { assert(proto->op_type == OP_CONST); @@ -6485,7 +6493,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else ps = NULL; - if (name) { + if (o_is_gv) { + gv = (GV*)o; + o = NULL; + has_name = TRUE; + } else if (name) { gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { @@ -6582,19 +6594,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 @@ -6619,7 +6623,10 @@ 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 + ); } stash = (CvGV(cv) && GvSTASH(CvGV(cv))) @@ -6855,6 +6862,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, } else if (*name == 'C') { if (strEQ(name, "CHECK")) { if (PL_main_start) + /* diag_listed_as: Too late to run %s block */ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); @@ -6864,6 +6872,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, } else if (*name == 'I') { if (strEQ(name, "INIT")) { if (PL_main_start) + /* diag_listed_as: Too late to run %s block */ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); @@ -6888,7 +6897,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); } /* @@ -6908,7 +6917,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; @@ -6926,6 +6936,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); @@ -6945,8 +6957,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); @@ -6964,12 +6976,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); @@ -6984,25 +7012,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; @@ -7085,6 +7105,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); } else { + /* diag_listed_as: Format %s redefined */ Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format STDOUT redefined"); } @@ -7326,8 +7347,12 @@ Perl_ck_cmp(pTHX_ OP *o) 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)) + ( + is_dollar_bracket(aTHX_ kid) + && kid->op_sibling && kid->op_sibling->op_type == OP_CONST + ) + || ( kid->op_type == OP_CONST + && (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid)) )) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "$[ used in %s (did you mean $] ?)", OP_DESC(o)); @@ -7432,6 +7457,7 @@ Perl_ck_eof(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_EOF; if (o->op_flags & OPf_KIDS) { + OP *kid; if (cLISTOPo->op_first->op_type == OP_STUB) { OP * const newop = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); @@ -7442,7 +7468,10 @@ Perl_ck_eof(pTHX_ OP *o) #endif o = newop; } - return ck_fun(o); + o = ck_fun(o); + kid = cLISTOPo->op_first; + if (kid->op_type == OP_RV2GV) + kid->op_private |= OPpALLOW_FAKE; } return o; } @@ -7504,6 +7533,7 @@ Perl_ck_eval(pTHX_ OP *o) op_getmad(oldo,o,'O'); } o->op_targ = (PADOFFSET)PL_hints; + 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. */ @@ -7513,7 +7543,7 @@ Perl_ck_eval(pTHX_ OP *o) o->op_private |= OPpEVAL_HAS_HH; if (!(o->op_private & OPpEVAL_BYTES) - && FEATURE_IS_ENABLED("unieval")) + && FEATURE_UNIEVAL_IS_ENABLED) o->op_private |= OPpEVAL_UNICODE; } return o; @@ -7721,6 +7751,11 @@ Perl_ck_ftst(pTHX_ OP *o) && kidtype != OP_STAT && kidtype != OP_LSTAT) { o->op_private |= OPpFT_STACKED; kid->op_private |= OPpFT_STACKING; + if (kidtype == OP_FTTTY && ( + !(kid->op_private & OPpFT_STACKED) + || kid->op_private & OPpFT_AFTER_t + )) + o->op_private |= OPpFT_AFTER_t; } } else { @@ -7910,6 +7945,7 @@ Perl_ck_fun(pTHX_ OP *o) const char *name = NULL; STRLEN len = 0; U32 name_utf8 = 0; + bool want_dollar = TRUE; flags = 0; /* Set a flag to tell rv2gv to vivify @@ -7976,6 +8012,7 @@ Perl_ck_fun(pTHX_ OP *o) if (!name) { name = "__ANONIO__"; len = 10; + want_dollar = FALSE; } op_lvalue(kid, type); } @@ -7984,7 +8021,7 @@ Perl_ck_fun(pTHX_ OP *o) targ = pad_alloc(OP_RV2GV, SVs_PADTMP); namesv = PAD_SVl(targ); SvUPGRADE(namesv, SVt_PV); - if (*name != '$') + if (want_dollar && *name != '$') sv_setpvs(namesv, "$"); sv_catpvn(namesv, name, len); if ( name_utf8 ) SvUTF8_on(namesv); @@ -8144,7 +8181,7 @@ Perl_ck_grep(pTHX_ OP *o) return o; kid = cLISTOPo->op_first->op_sibling; if (kid->op_type != OP_NULL) - Perl_croak(aTHX_ "panic: ck_grep"); + Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type); kid = kUNOP->op_first; if (!gwop) @@ -8210,11 +8247,6 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ if ((o->op_flags & OPf_KIDS)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: - /* This is needed for - if (defined %stash::) - to work. Do not break Tk. - */ - break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), @@ -8242,7 +8274,11 @@ Perl_ck_readline(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_READLINE; - if (!(o->op_flags & OPf_KIDS)) { + if (o->op_flags & OPf_KIDS) { + OP *kid = cLISTOPo->op_first; + if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; + } + else { OP * const newop = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); #ifdef PERL_MAD @@ -8294,6 +8330,7 @@ Perl_ck_listiob(pTHX_ OP *o) if (!kid) op_append_elem(o->op_type, o, newDEFSVOP()); + if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF); return listkids(o); } @@ -8751,8 +8788,6 @@ Perl_ck_sort(pTHX_ OP *o) kid->op_next = k; o->op_flags |= OPf_SPECIAL; } - else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - op_null(firstkid); firstkid = firstkid->op_sibling; } @@ -8854,7 +8889,7 @@ Perl_ck_split(pTHX_ OP *o) kid = cLISTOPo->op_first; if (kid->op_type != OP_NULL) - Perl_croak(aTHX_ "panic: ck_split"); + Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type); kid = kid->op_sibling; op_free(cLISTOPo->op_first); if (kid) @@ -9078,7 +9113,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) const char *e = NULL; 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"); + Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, " + "flags=%lx", (unsigned long) SvFLAGS(protosv)); if (SvTYPE(protosv) == SVt_PVCV) proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv); else proto = SvPV(protosv, proto_len); @@ -9110,7 +9146,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; case '_': /* _ must be at the end */ - if (proto[1] && proto[1] != ';') + if (proto[1] && !strchr(";@%", proto[1])) goto oops; case '$': proto++; @@ -9363,7 +9399,6 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) { aop = aop->op_sibling; - continue; } if (aop != cvop) (void)too_many_arguments(entersubop, GvNAME(namegv)); @@ -9430,7 +9465,9 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) (void)too_many_arguments(aop, GvNAME(namegv)); op_free(aop); } - return newOP(opnum,0); + return opnum == OP_RUNCV + ? newPVOP(OP_RUNCV,0,NULL) + : newOP(opnum,0); default: return convert(opnum,0,aop); } @@ -9645,6 +9682,19 @@ Perl_ck_substr(pTHX_ OP *o) } OP * +Perl_ck_tell(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CK_TELL; + o = ck_fun(o); + if (o->op_flags & OPf_KIDS) { + OP *kid = cLISTOPo->op_first; + if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling; + if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; + } + return o; +} + +OP * Perl_ck_each(pTHX_ OP *o) { dVAR; @@ -9701,7 +9751,8 @@ Perl_ck_length(pTHX_ OP *o) case OP_PADHV: case OP_PADAV: name = varname( - NULL, hash ? '%' : '@', kid->op_targ, NULL, 0, 1 + (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ, + NULL, 0, 1 ); break; case OP_RV2HV: @@ -9789,7 +9840,7 @@ S_inplace_aassign(pTHX_ OP *o) { return; assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK); - oright = cUNOPx(modop)->op_first->op_sibling; + if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return; if (modop->op_flags & OPf_STACKED) { /* skip sort subroutine/block */ @@ -10274,6 +10325,42 @@ Perl_rpeep(pTHX_ register OP *o) } break; + case OP_RUNCV: + if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) { + SV *sv; + if (CvUNIQUE(PL_compcv)) sv = &PL_sv_undef; + else { + sv = newRV((SV *)PL_compcv); + sv_rvweaken(sv); + SvREADONLY_on(sv); + } + o->op_type = OP_CONST; + o->op_ppaddr = PL_ppaddr[OP_CONST]; + o->op_flags |= OPf_SPECIAL; + cSVOPo->op_sv = sv; + } + break; + + case OP_SASSIGN: + if (OP_GIMME(o,0) == G_VOID) { + OP *right = cBINOP->op_first; + if (right) { + OP *left = right->op_sibling; + if (left->op_type == OP_SUBSTR + && (left->op_private & 7) < 4) { + op_null(o); + cBINOP->op_first = left; + right->op_sibling = + cBINOPx(left)->op_first->op_sibling; + cBINOPx(left)->op_first->op_sibling = right; + left->op_private |= OPpSUBSTR_REPL_FIRST; + left->op_flags = + (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + } + } + } + break; + case OP_CUSTOM: { Perl_cpeep_t cpeep = XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep); @@ -10522,7 +10609,8 @@ 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: if (opnum == OP_ENTEREVAL) { @@ -10552,6 +10640,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. */