X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4639a3a7d1d9f85f2e8510b689a8e047b15ed452..19fc2965b60669d7bc25548edb32e3cdd86a68de:/op.c?ds=sidebyside diff --git a/op.c b/op.c index 37d8656..93205fe 100644 --- a/op.c +++ b/op.c @@ -109,6 +109,8 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o) +static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar"; + /* Used to avoid recursion through the op tree in scalarvoid() and op_free() */ @@ -802,6 +804,7 @@ Perl_op_free(pTHX_ OP *o) /* S_op_clear_gv(): free a GV attached to an OP */ +STATIC #ifdef USE_ITHREADS void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp) #else @@ -1194,6 +1197,7 @@ Perl_op_null(pTHX_ OP *o) void Perl_op_refcnt_lock(pTHX) + PERL_TSA_ACQUIRE(PL_op_mutex) { #ifdef USE_ITHREADS dVAR; @@ -1204,6 +1208,7 @@ Perl_op_refcnt_lock(pTHX) void Perl_op_refcnt_unlock(pTHX) + PERL_TSA_RELEASE(PL_op_mutex) { #ifdef USE_ITHREADS dVAR; @@ -1405,7 +1410,7 @@ Perl_op_parent(OP *o) * Returns the new UNOP. */ -OP * +STATIC OP * S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags) { OP *kid, *newop; @@ -1423,7 +1428,7 @@ S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags) * being spread throughout this file. */ -LOGOP * +STATIC LOGOP * S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other) { dVAR; @@ -1545,7 +1550,7 @@ S_scalarboolean(pTHX_ OP *o) } static SV * -S_op_varname(pTHX_ const OP *o) +S_op_varname_subscript(pTHX_ const OP *o, int subscript_type) { assert(o); assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV || @@ -1558,13 +1563,19 @@ S_op_varname(pTHX_ const OP *o) if (cUNOPo->op_first->op_type != OP_GV || !(gv = cGVOPx_gv(cUNOPo->op_first))) return NULL; - return varname(gv, funny, 0, NULL, 0, 1); + return varname(gv, funny, 0, NULL, 0, subscript_type); } return - varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1); + varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type); } } +static SV * +S_op_varname(pTHX_ const OP *o) +{ + return S_op_varname_subscript(aTHX_ o, 1); +} + static void S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv) { /* or not so pretty :-) */ @@ -2301,7 +2312,7 @@ S_modkids(pTHX_ OP *o, I32 type) * key_op is the first key */ -void +STATIC void S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) { PADNAME *lexname; @@ -2341,6 +2352,13 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) continue; svp = cSVOPx_svp(key_op); + /* make sure it's not a bareword under strict subs */ + if (key_op->op_private & OPpCONST_BARE && + key_op->op_private & OPpCONST_STRICT) + { + no_bareword_allowed((OP*)key_op); + } + /* Make the CONST have a shared SV */ if ( !SvIsCOW_shared_hash(sv = *svp) && SvTYPE(sv) < SVt_PVMG @@ -2612,7 +2630,13 @@ S_mark_padname_lvalue(pTHX_ PADNAME *pn) PadnameLVALUE_on(pn); while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) { cv = CvOUTSIDE(cv); - assert(cv); + /* RT #127786: cv can be NULL due to an eval within the DB package + * called from an anon sub - anon subs don't have CvOUTSIDE() set + * unless they contain an eval, but calling eval within DB + * pretends the eval was done in the caller's scope. + */ + if (!cv) + break; assert(CvPADLIST(cv)); pn = PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)]; @@ -4046,7 +4070,7 @@ Perl_newPROG(pTHX_ OP *o) ((PL_in_eval & EVAL_KEEPERR) ? OPf_SPECIAL : 0), o); - cx = &cxstack[cxstack_ix]; + cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); if ((cx->blk_gimme & G_WANT) == G_VOID) @@ -4248,12 +4272,12 @@ S_fold_constants(pTHX_ OP *o) bool is_stringify; SV * VOL sv = NULL; int ret = 0; - I32 oldscope; OP *old_next; SV * const oldwarnhook = PL_warnhook; SV * const olddiehook = PL_diehook; COP not_compiling; U8 oldwarn = PL_dowarn; + I32 old_cxix; dJMPENV; PERL_ARGS_ASSERT_FOLD_CONSTANTS; @@ -4334,8 +4358,8 @@ S_fold_constants(pTHX_ OP *o) o->op_next = 0; PL_op = curop; - oldscope = PL_scopestack_ix; - create_eval_scope(G_FAKINGEVAL); + old_cxix = cxstack_ix; + create_eval_scope(NULL, G_FAKINGEVAL); /* Verify that we don't need to save it: */ assert(PL_curcop == &PL_compiling); @@ -4386,9 +4410,13 @@ S_fold_constants(pTHX_ OP *o) PL_diehook = olddiehook; PL_curcop = &PL_compiling; - if (PL_scopestack_ix > oldscope) - delete_eval_scope(); - + /* if we croaked, depending on how we croaked the eval scope + * may or may not have already been popped */ + if (cxstack_ix > old_cxix) { + assert(cxstack_ix == old_cxix + 1); + assert(CxTYPE(CX_CUR()) == CXt_EVAL); + delete_eval_scope(); + } if (ret) goto nope; @@ -7091,7 +7119,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) o->op_flags |= flags; o = op_scope(o); - o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/ + o->op_flags |= OPf_SPECIAL; /* suppress cx_popblock() curpm restoration*/ return o; } @@ -8379,6 +8407,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, : NULL; if (block) { + assert(PL_parser); /* This makes sub {}; work as expected. */ if (block->op_type == OP_STUB) { const line_t l = PL_parser->copline; @@ -8396,7 +8425,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, block->op_next = 0; if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv)) const_sv = - S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv)); + S_op_const_sv(aTHX_ start, PL_compcv, + cBOOL(CvCLONE(PL_compcv))); else const_sv = NULL; } @@ -8404,7 +8434,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, const_sv = NULL; if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { - assert (block); cv_ckproto_len_flags((const CV *)gv, o ? (const GV *)cSVOPo->op_sv : NULL, ps, ps_len, ps_utf8|CV_CKPROTO_CURSTASH); @@ -9712,6 +9741,19 @@ Perl_ck_ftst(pTHX_ OP *o) op_free(o); return newop; } + + if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) { + SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2); + if (name) { + /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)", + array_passed_to_stat, name); + } + else { + /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */ + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat); + } + } scalar((OP *) kid); if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) o->op_private |= OPpFT_ACCESS; @@ -10586,6 +10628,12 @@ Perl_ck_require(pTHX_ OP *o) s = SvPVX(sv); len = SvCUR(sv); end = s + len; + /* treat ::foo::bar as foo::bar */ + if (len >= 2 && s[0] == ':' && s[1] == ':') + DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s); + if (s == end) + DIE(aTHX_ "Bareword in require maps to empty filename"); + for (; s < end; s++) { if (*s == ':' && s[1] == ':') { *s = '/'; @@ -11156,11 +11204,20 @@ OP * Perl_ck_entersub_args_list(pTHX_ OP *entersubop) { OP *aop; + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; + aop = cUNOPx(entersubop)->op_first; if (!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { + /* skip the extra attributes->import() call implicitly added in + * something like foo(my $x : bar) + */ + if ( aop->op_type == OP_ENTERSUB + && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID + ) + continue; list(aop); op_lvalue(aop, OP_ENTERSUB); } @@ -12332,7 +12389,8 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p) default: if (PL_opargs[o->op_type] & OA_DANGEROUS) { (*scalars_p) += 2; - return AAS_DANGEROUS; + flags = AAS_DANGEROUS; + break; } if ( (PL_opargs[o->op_type] & OA_TARGLEX) @@ -12461,7 +12519,7 @@ S_inplace_aassign(pTHX_ OP *o) { * OPpHINT_STRICT_REFS) as found in any rv2av/hv skipped by the caller. */ -void +STATIC void S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) { dVAR; @@ -13115,6 +13173,11 @@ Perl_rpeep(pTHX_ OP *o) } redo: + + /* oldoldop -> oldop -> o should be a chain of 3 adjacent ops */ + assert(!oldoldop || oldoldop->op_next == oldop); + assert(!oldop || oldop->op_next == o); + /* By default, this op has now been optimised. A couple of cases below clear this again. */ o->op_opt = 1; @@ -13436,9 +13499,10 @@ Perl_rpeep(pTHX_ OP *o) op_null(o); if (oldop) oldop->op_next = nextop; + o = nextop; /* Skip (old)oldop assignment since the current oldop's op_next already points to the next op. */ - continue; + goto redo; } } break; @@ -13626,7 +13690,7 @@ Perl_rpeep(pTHX_ OP *o) /* Note that you'd normally expect targs to be * contiguous in my($a,$b,$c), but that's not the case * when external modules start doing things, e.g. - i* Function::Parameters */ + * Function::Parameters */ if (p->op_targ != base + count) break; assert(p->op_targ == base + count); @@ -13650,9 +13714,21 @@ Perl_rpeep(pTHX_ OP *o) break; /* there's a biggest base we can fit into a - * SAVEt_CLEARPADRANGE in pp_padrange */ - if (intro && base > - (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))) + * SAVEt_CLEARPADRANGE in pp_padrange. + * (The sizeof() stuff will be constant-folded, and is + * intended to avoid getting "comparison is always false" + * compiler warnings. See the comments above + * MEM_WRAP_CHECK for more explanation on why we do this + * in a weird way to avoid compiler warnings.) + */ + if ( intro + && (8*sizeof(base) > + 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT + ? base + : (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) + ) > + (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) + ) break; /* Success! We've got another valid pad op to optimise away */ @@ -13670,10 +13746,10 @@ Perl_rpeep(pTHX_ OP *o) * optimise away would have exactly the same effect as the * padrange. * In particular in void context, we can only optimise to - * a padrange if see see the complete sequence + * a padrange if we see the complete sequence * pushmark, pad*v, ...., list - * which has the net effect of of leaving the markstack as it - * was. Not pushing on to the stack (whereas padsv does touch + * which has the net effect of leaving the markstack as it + * was. Not pushing onto the stack (whereas padsv does touch * the stack) makes no difference in void context. */ assert(followop); @@ -13835,7 +13911,8 @@ Perl_rpeep(pTHX_ OP *o) oldoldop = NULL; goto redo; } - o = oldop; + o = oldop->op_next; + goto redo; } else if (o->op_next->op_type == OP_RV2SV) { if (!(o->op_next->op_private & OPpDEREF)) { @@ -13884,11 +13961,11 @@ Perl_rpeep(pTHX_ OP *o) || o->op_next->op_type == OP_NULL)) o->op_next = o->op_next->op_next; - /* if we're an OR and our next is a AND in void context, we'll - follow it's op_other on short circuit, same for reverse. + /* If we're an OR and our next is an AND in void context, we'll + follow its op_other on short circuit, same for reverse. We can't do this with OP_DOR since if it's true, its return value is the underlying value which must be evaluated - by the next op */ + by the next op. */ if (o->op_next && ( (IS_AND_OP(o) && IS_OR_OP(o->op_next)) @@ -14132,6 +14209,11 @@ Perl_rpeep(pTHX_ OP *o) op_null(o); enter->op_private |= OPpITER_REVERSED; iter->op_private |= OPpITER_REVERSED; + + oldoldop = NULL; + oldop = ourlast; + o = oldop->op_next; + goto redo; break; } @@ -14431,10 +14513,12 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) } } } - /* Some gcc releases emit a warning for this function: + /* On some platforms (HP-UX, IA64) gcc emits a warning for this function: * op.c: In function 'Perl_custom_op_get_field': * op.c:...: warning: 'any.xop_name' may be used uninitialized in this function [-Wmaybe-uninitialized] - * Whether this is true, is currently unknown. */ + * This is because on those platforms (with -DEBUGGING) NOT_REACHED + * expands to assert(0), which expands to ((0) ? (void)0 : + * __assert(...)), and gcc doesn't know that __assert can never return. */ return any; } }