X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/81b96c32839f3fa3ae70bddf441b4e6827eb93c8..754e15cfc175f0e2e1299d27fd387a0d868c2764:/op.c diff --git a/op.c b/op.c index 0fbee48..51ffac2 100644 --- a/op.c +++ b/op.c @@ -487,13 +487,13 @@ void Perl_opslab_force_free(pTHX_ OPSLAB *slab) { OPSLAB *slab2; - OPSLOT *slot; #ifdef DEBUGGING size_t savestack_count = 0; #endif PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE; slab2 = slab; do { + OPSLOT *slot; for (slot = slab2->opslab_first; slot->opslot_next; slot = slot->opslot_next) { @@ -622,7 +622,7 @@ S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t) SV * const namesv = cv_name((CV *)gv, NULL, 0); PERL_ARGS_ASSERT_BAD_TYPE_GV; - yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", + yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)", (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv)); } @@ -632,7 +632,7 @@ S_no_bareword_allowed(pTHX_ OP *o) PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; qerror(Perl_mess(aTHX_ - "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", + "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use", SVfARG(cSVOPo_sv))); o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */ } @@ -652,11 +652,12 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) (UV)flags); /* complain about "my $" etc etc */ - if (len && - !(is_our || - isALPHA(name[1]) || - ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) || - (name[1] == '_' && len > 2))) + if ( len + && !( is_our + || isALPHA(name[1]) + || ( (flags & SVf_UTF8) + && isIDFIRST_utf8_safe((U8 *)name+1, name + len)) + || (name[1] == '_' && len > 2))) { if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) && isASCII(name[1]) @@ -853,10 +854,8 @@ Perl_op_free(pTHX_ OP *o) op_clear(o); FreeOp(o); -#ifdef DEBUG_LEAKING_SCALARS if (PL_op == o) PL_op = NULL; -#endif } while ( (o = POP_DEFERRED_OP()) ); Safefree(defer_stack); @@ -995,8 +994,9 @@ Perl_op_clear(pTHX_ OP *o) /* FALLTHROUGH */ case OP_TRANS: case OP_TRANSR: - if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { - assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR); + if ( (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) + && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))) + { #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { pad_swipe(cPADOPo->op_padix, TRUE); @@ -1015,14 +1015,20 @@ Perl_op_clear(pTHX_ OP *o) case OP_SUBST: op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); goto clear_pmop; - case OP_PUSHRE: + + case OP_SPLIT: + if ( (o->op_private & OPpSPLIT_ASSIGN) /* @array = split */ + && !(o->op_flags & OPf_STACKED)) /* @{expr} = split */ + { + if (o->op_private & OPpSPLIT_LEX) + pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff); + else #ifdef USE_ITHREADS - if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { - pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); - } + pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); #else - SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); + SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); #endif + } /* FALLTHROUGH */ case OP_MATCH: case OP_QR: @@ -1226,7 +1232,7 @@ S_find_and_forget_pmops(pTHX_ OP *o) while (kid) { switch (kid->op_type) { case OP_SUBST: - case OP_PUSHRE: + case OP_SPLIT: case OP_MATCH: case OP_QR: forget_pmop((PMOP*)kid); @@ -1665,10 +1671,12 @@ static void S_scalar_slice_warning(pTHX_ const OP *o) { OP *kid; + const bool h = o->op_type == OP_HSLICE + || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE); const char lbrack = - o->op_type == OP_HSLICE ? '{' : '['; + h ? '{' : '['; const char rbrack = - o->op_type == OP_HSLICE ? '}' : ']'; + h ? '}' : ']'; SV *name; SV *keysv = NULL; /* just to silence compiler warnings */ const char *key = NULL; @@ -1722,15 +1730,15 @@ S_scalar_slice_warning(pTHX_ const OP *o) if (key) /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Scalar value @%"SVf"%c%s%c better written as $%"SVf + "Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c", SVfARG(name), lbrack, key, rbrack, SVfARG(name), lbrack, key, rbrack); else /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Scalar value @%"SVf"%c%"SVf"%c better written as $%" - SVf"%c%"SVf"%c", + "Scalar value @%" SVf "%c%" SVf "%c better written as $%" + SVf "%c%" SVf "%c", SVfARG(name), lbrack, SVfARG(keysv), rbrack, SVfARG(name), lbrack, SVfARG(keysv), rbrack); } @@ -1835,15 +1843,15 @@ Perl_scalar(pTHX_ OP *o) if (key) /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "%%%"SVf"%c%s%c in scalar context better written " - "as $%"SVf"%c%s%c", + "%%%" SVf "%c%s%c in scalar context better written " + "as $%" SVf "%c%s%c", SVfARG(name), lbrack, key, rbrack, SVfARG(name), lbrack, key, rbrack); else /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "%%%"SVf"%c%"SVf"%c in scalar context better " - "written as $%"SVf"%c%"SVf"%c", + "%%%" SVf "%c%" SVf "%c in scalar context better " + "written as $%" SVf "%c%" SVf "%c", SVfARG(name), lbrack, SVfARG(keysv), rbrack, SVfARG(name), lbrack, SVfARG(keysv), rbrack); } @@ -1857,7 +1865,6 @@ Perl_scalarvoid(pTHX_ OP *arg) dVAR; OP *kid; SV* sv; - U8 want; SSize_t defer_stack_alloc = 0; SSize_t defer_ix = -1; OP **defer_stack = NULL; @@ -1866,6 +1873,7 @@ Perl_scalarvoid(pTHX_ OP *arg) PERL_ARGS_ASSERT_SCALARVOID; do { + U8 want; SV *useless_sv = NULL; const char* useless = NULL; @@ -1992,16 +2000,7 @@ Perl_scalarvoid(pTHX_ OP *arg) break; case OP_SPLIT: - kid = cLISTOPo->op_first; - if (kid && kid->op_type == OP_PUSHRE - && !kid->op_targ - && !(o->op_flags & OPf_STACKED) -#ifdef USE_ITHREADS - && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff -#else - && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv -#endif - ) + if (!(o->op_private & OPpSPLIT_ASSIGN)) useless = OP_DESC(o); break; @@ -2061,7 +2060,7 @@ Perl_scalarvoid(pTHX_ OP *arg) SvREFCNT_dec_NN(dsv); } else if (SvOK(sv)) { - useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv)); + useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv)); } else useless = "a constant (undef)"; @@ -2215,7 +2214,7 @@ Perl_scalarvoid(pTHX_ OP *arg) if (useless_sv) { /* mortalise it, in case warnings are fatal. */ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), - "Useless use of %"SVf" in void context", + "Useless use of %" SVf " in void context", SVfARG(sv_2mortal(useless_sv))); } else if (useless) { @@ -2443,8 +2442,8 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) if ( check_fields && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) { - Perl_croak(aTHX_ "No such class field \"%"SVf"\" " - "in variable %"PNf" of type %"HEKf, + Perl_croak(aTHX_ "No such class field \"%" SVf "\" " + "in variable %" PNf " of type %" HEKf, SVfARG(*svp), PNfARG(lexname), HEKfARG(HvNAME_HEK(PadnameTYPE(lexname)))); } @@ -2452,6 +2451,39 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) } +/* do all the final processing on an optree (e.g. running the peephole + * optimiser on it), then attach it to cv (if cv is non-null) + */ + +static void +S_process_optree(pTHX_ CV *cv, OP *optree, OP* start) +{ + OP **startp; + + /* XXX for some reason, evals, require and main optrees are + * never attached to their CV; instead they just hang off + * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start + * and get manually freed when appropriate */ + if (cv) + startp = &CvSTART(cv); + else + startp = PL_in_eval? &PL_eval_start : &PL_main_start; + + *startp = start; + optree->op_private |= OPpREFCOUNTED; + OpREFCNT_set(optree, 1); + CALL_PEEP(*startp); + finalize_optree(optree); + S_prune_chain_head(startp); + + if (cv) { + /* now that optimizer has done its work, adjust pad values */ + pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT + : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + } +} + + /* =for apidoc finalize_optree @@ -2537,7 +2569,7 @@ S_finalize_op(pTHX_ OP* o) SV * const sv = sv_newmortal(); gv_efullname3(sv, gv, NULL); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), - "%"SVf"() called too early to check prototype", + "%" SVf "() called too early to check prototype", SVfARG(sv)); } } @@ -2600,6 +2632,10 @@ S_finalize_op(pTHX_ OP* o) S_check_hash_fields_and_hekify(aTHX_ rop, key_op); break; } + case OP_NULL: + if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE) + break; + /* FALLTHROUGH */ case OP_ASLICE: S_scalar_slice_warning(aTHX_ o); break; @@ -2648,8 +2684,6 @@ S_finalize_op(pTHX_ OP* o) || family == OA_FILESTATOP || family == OA_LOOPEXOP || family == OA_METHOP - /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */ - || type == OP_SASSIGN || type == OP_CUSTOM || type == OP_NULL /* new_logop does this */ ); @@ -2911,7 +2945,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " - "args: type/targ %ld:%"UVuf, + "args: type/targ %ld:%" UVuf, (long)kid->op_type, (UV)kid->op_targ); kid = kLISTOP->op_first; } @@ -2927,7 +2961,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if (kid->op_type == OP_NULL) Perl_croak(aTHX_ "Unexpected constant lvalue entersub " - "entry via type/targ %ld:%"UVuf, + "entry via type/targ %ld:%" UVuf, (long)kid->op_type, (UV)kid->op_targ); if (kid->op_type != OP_GV) { break; @@ -2948,7 +2982,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) namesv = cv_name(cv, NULL, 0); yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue " - "subroutine call of &%"SVf" in %s", + "subroutine call of &%" SVf " in %s", SVfARG(namesv), PL_op_desc[type]), SvUTF8(namesv)); return o; @@ -3101,7 +3135,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_PADSV: PL_modcount++; if (!type) /* local() */ - Perl_croak(aTHX_ "Can't localize lexical variable %"PNf, + Perl_croak(aTHX_ "Can't localize lexical variable %" PNf, PNfARG(PAD_COMPNAME(o->op_targ))); if (!(o->op_private & OPpLVAL_INTRO) || ( type != OP_SASSIGN && type != OP_AASSIGN @@ -3170,9 +3204,32 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) goto nomod; else if (!(o->op_flags & OPf_KIDS)) break; + if (o->op_targ != OP_LIST) { - op_lvalue(cBINOPo->op_first, type); - break; + OP *sib = OpSIBLING(cLISTOPo->op_first); + /* OP_TRANS and OP_TRANSR with argument have a weird optree + * that looks like + * + * null + * arg + * trans + * + * compared with things like OP_MATCH which have the argument + * as a child: + * + * match + * arg + * + * so handle specially to correctly get "Can't modify" croaks etc + */ + + if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR)) + { + /* this should trigger a "Can't modify transliteration" err */ + op_lvalue(sib, type); + } + op_lvalue(cBINOPo->op_first, type); + break; } /* FALLTHROUGH */ case OP_LIST: @@ -3240,16 +3297,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) return o; case OP_SPLIT: - kid = cLISTOPo->op_first; - if (kid && kid->op_type == OP_PUSHRE && - ( kid->op_targ - || o->op_flags & OPf_STACKED -#ifdef USE_ITHREADS - || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff -#else - || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv -#endif - )) { + if ((o->op_private & OPpSPLIT_ASSIGN)) { /* This is actually @array = split. */ PL_modcount = RETURN_UNLIMITED_NUMBER; break; @@ -3678,7 +3726,7 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) STRLEN new_len; const char * newp = SvPV(cSVOPo_sv, new_len); Perl_warner(aTHX_ packWARN(WARN_MISC), - "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub", + "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub", UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp)); op_free(new_proto); } @@ -3719,8 +3767,8 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) const char * newp = SvPV(cSVOPx_sv(new_proto), new_len); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), - "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'" - " in %"SVf, + "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'" + " in %" SVf, UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp), UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp), SVfARG(svname)); @@ -3905,7 +3953,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) S_op_varname(aTHX_ left); if (name) Perl_warner(aTHX_ packWARN(WARN_MISC), - "Applying %s to %"SVf" will act on scalar(%"SVf")", + "Applying %s to %" SVf " will act on scalar(%" SVf ")", desc, SVfARG(name), SVfARG(name)); else { const char * const sample = (isary @@ -4183,6 +4231,8 @@ Perl_blockhook_register(pTHX_ BHK *hk) void Perl_newPROG(pTHX_ OP *o) { + OP *start; + PERL_ARGS_ASSERT_NEWPROG; if (PL_in_eval) { @@ -4204,16 +4254,12 @@ Perl_newPROG(pTHX_ OP *o) else scalar(PL_eval_root); - PL_eval_start = op_linklist(PL_eval_root); - PL_eval_root->op_private |= OPpREFCOUNTED; - OpREFCNT_set(PL_eval_root, 1); + start = op_linklist(PL_eval_root); PL_eval_root->op_next = 0; i = PL_savestack_ix; SAVEFREEOP(o); ENTER; - CALL_PEEP(PL_eval_start); - finalize_optree(PL_eval_root); - S_prune_chain_head(&PL_eval_start); + S_process_optree(aTHX_ NULL, PL_eval_root, start); LEAVE; PL_savestack_ix = i; } @@ -4252,13 +4298,9 @@ Perl_newPROG(pTHX_ OP *o) } PL_main_root = op_scope(sawparens(scalarvoid(o))); PL_curcop = &PL_compiling; - PL_main_start = LINKLIST(PL_main_root); - PL_main_root->op_private |= OPpREFCOUNTED; - OpREFCNT_set(PL_main_root, 1); + start = LINKLIST(PL_main_root); PL_main_root->op_next = 0; - CALL_PEEP(PL_main_start); - finalize_optree(PL_main_root); - S_prune_chain_head(&PL_main_start); + S_process_optree(aTHX_ NULL, PL_main_root, start); cv_forget_slab(PL_compcv); PL_compcv = 0; @@ -4387,7 +4429,7 @@ S_op_integerize(pTHX_ OP *o) } static OP * -S_fold_constants(pTHX_ OP *o) +S_fold_constants(pTHX_ OP *const o) { dVAR; OP * VOL curop; @@ -4579,27 +4621,86 @@ static OP * S_gen_constant_list(pTHX_ OP *o) { dVAR; - OP *curop; - const SSize_t oldtmps_floor = PL_tmps_floor; + OP *curop, *old_next; + SV * const oldwarnhook = PL_warnhook; + SV * const olddiehook = PL_diehook; + COP *old_curcop; + U8 oldwarn = PL_dowarn; SV **svp; AV *av; + I32 old_cxix; + COP not_compiling; + int ret = 0; + dJMPENV; + bool op_was_null; list(o); if (PL_parser && PL_parser->error_count) return o; /* Don't attempt to run with errors */ curop = LINKLIST(o); + old_next = o->op_next; o->op_next = 0; + op_was_null = o->op_type == OP_NULL; + if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */ + o->op_type = OP_CUSTOM; CALL_PEEP(curop); + if (op_was_null) + o->op_type = OP_NULL; S_prune_chain_head(&curop); PL_op = curop; - Perl_pp_pushmark(aTHX); - CALLRUNOPS(aTHX); - PL_op = curop; - assert (!(curop->op_flags & OPf_SPECIAL)); - assert(curop->op_type == OP_RANGE); - Perl_pp_anonlist(aTHX); - PL_tmps_floor = oldtmps_floor; + + old_cxix = cxstack_ix; + create_eval_scope(NULL, G_FAKINGEVAL); + + old_curcop = PL_curcop; + StructCopy(old_curcop, ¬_compiling, COP); + PL_curcop = ¬_compiling; + /* The above ensures that we run with all the correct hints of the + current COP, but that IN_PERL_RUNTIME is true. */ + assert(IN_PERL_RUNTIME); + PL_warnhook = PERL_WARNHOOK_FATAL; + PL_diehook = NULL; + JMPENV_PUSH(ret); + + /* Effective $^W=1. */ + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) + PL_dowarn |= G_WARN_ON; + + switch (ret) { + case 0: + Perl_pp_pushmark(aTHX); + CALLRUNOPS(aTHX); + PL_op = curop; + assert (!(curop->op_flags & OPf_SPECIAL)); + assert(curop->op_type == OP_RANGE); + Perl_pp_anonlist(aTHX); + break; + case 3: + CLEAR_ERRSV(); + o->op_next = old_next; + break; + default: + JMPENV_POP; + PL_warnhook = oldwarnhook; + PL_diehook = olddiehook; + Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d", + ret); + } + + JMPENV_POP; + PL_dowarn = oldwarn; + PL_warnhook = oldwarnhook; + PL_diehook = olddiehook; + PL_curcop = old_curcop; + + if (cxstack_ix > old_cxix) { + assert(cxstack_ix == old_cxix + 1); + assert(CxTYPE(CX_CUR()) == CXt_EVAL); + delete_eval_scope(); + } + if (ret) + return o; OpTYPE_set(o, OP_RV2AV); o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */ @@ -4774,7 +4875,13 @@ Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) } } - OpTYPE_set(o, type); + if (type != OP_SPLIT) + /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let + * ck_split() create a real PMOP and leave the op's type as listop + * for now. Otherwise op_free() etc will crash. + */ + OpTYPE_set(o, type); + o->op_flags |= flags; if (flags & OPf_FOLDED) o->op_folded = 1; @@ -5121,7 +5228,7 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) BINOP *binop; ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP - || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM); + || type == OP_NULL || type == OP_CUSTOM); NewOp(1101, binop, 1, BINOP); @@ -5436,7 +5543,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) tbl[i] = (short)i; } else { - if (i < 128 && r[j] >= 128) + if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j])) grows = 1; tbl[i] = r[j++]; } @@ -5483,7 +5590,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) --j; } if (tbl[t[i]] == -1) { - if (t[i] < 128 && r[j] >= 128) + if ( UVCHR_IS_INVARIANT(t[i]) + && ! UVCHR_IS_INVARIANT(r[j])) grows = 1; tbl[t[i]] = r[j]; } @@ -5602,10 +5710,12 @@ S_set_haseval(pTHX) * constant), or convert expr into a runtime regcomp op sequence (if it's * not) * - * isreg indicates that the pattern is part of a regex construct, eg + * Flags currently has 2 bits of meaning: + * 1: isreg indicates that the pattern is part of a regex construct, eg * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or * split "pattern", which aren't. In the former case, expr will be a list * if the pattern contains more than one term (eg /a$b/). + * 2: The pattern is for a split. * * When the pattern has been compiled within a new anon CV (for * qr/(?{...})/ ), then floor indicates the savestack level just before @@ -5613,7 +5723,7 @@ S_set_haseval(pTHX) */ OP * -Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) +Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor) { PMOP *pm; LOGOP *rcop; @@ -5621,6 +5731,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR); bool is_compiletime; bool has_code; + bool isreg = cBOOL(flags & 1); + bool is_split = cBOOL(flags & 2); PERL_ARGS_ASSERT_PMRUNTIME; @@ -5725,8 +5837,16 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; regexp_engine const *eng = current_re_engine(); - if (o->op_flags & OPf_SPECIAL) + if (is_split) { + /* make engine handle split ' ' specially */ + pm->op_pmflags |= PMf_SPLIT; rx_flags |= RXf_SPLIT; + } + + /* Skip compiling if parser found an error for this pattern */ + if (pm->op_pmflags & PMf_HAS_ERROR) { + return o; + } if (!has_code || !eng->op_comp) { /* compile-time simple constant pattern */ @@ -5815,7 +5935,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, bool isreg, I32 floor) pm->op_pmflags |= PMf_CODELIST_PRIVATE; } - if (o->op_flags & OPf_SPECIAL) + if (is_split) + /* make engine handle split ' ' specially */ pm->op_pmflags |= PMf_SPLIT; /* the OP_REGCMAYBE is a placeholder in the non-threaded case @@ -6275,21 +6396,30 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) =for apidoc load_module -Loads the module whose name is pointed to by the string part of name. +Loads the module whose name is pointed to by the string part of C. 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 +Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL, +provides version semantics similar to C. The optional +trailing arguments can be used to specify arguments to the module's C +method, similar to C; their precise handling depends +on the flags. The flags argument is a bitwise-ORed collection of any of C, C, or C -(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 C -method, similar to C. They must be -terminated with a final C pointer. Note that this list can only -be omitted when the C flag has been used. -Otherwise at least a single C pointer to designate the default -import list is required. - -The reference count for each specified C parameter is decremented. +(or 0 for no flags). + +If C is set, the module is loaded as if with an empty +import list, as in C; this is the only circumstance in which +the trailing optional arguments may be omitted entirely. Otherwise, if +C is set, the trailing arguments must consist of +exactly one C, containing the op tree that produces the relevant import +arguments. Otherwise, the trailing arguments must all be C values that +will be used as import arguments; and the list must be terminated with C<(SV*) +NULL>. If neither C nor C is +set, the trailing C pointer is needed even if no import arguments are +desired. The reference count for each specified C argument is +decremented. In addition, the C argument is modified. + +If C is set, the module is loaded as if with C rather +than C. =cut */ @@ -6508,9 +6638,10 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (optype) { if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { + right = scalar(right); return newLOGOP(optype, 0, op_lvalue(scalar(left), optype), - newUNOP(OP_SASSIGN, 0, scalar(right))); + newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right)); } else { return newBINOP(optype, OPf_STACKED, @@ -6566,91 +6697,94 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) yyerror(no_list_state); } - if (right && right->op_type == OP_SPLIT - && !(right->op_flags & OPf_STACKED)) { - OP* tmpop = ((LISTOP*)right)->op_first; - PMOP * const pm = (PMOP*)tmpop; - assert (tmpop && (tmpop->op_type == OP_PUSHRE)); - if ( -#ifdef USE_ITHREADS - !pm->op_pmreplrootu.op_pmtargetoff -#else - !pm->op_pmreplrootu.op_pmtargetgv -#endif - && !pm->op_targ - ) { - if (!(left->op_private & OPpLVAL_INTRO) && - ( (left->op_type == OP_RV2AV && - (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV) - || left->op_type == OP_PADAV ) - ) { - if (tmpop != (OP *)pm) { + /* optimise @a = split(...) into: + * @{expr}: split(..., @{expr}) (where @a is not flattened) + * @a, my @a, local @a: split(...) (where @a is attached to + * the split op itself) + */ + + if ( right + && right->op_type == OP_SPLIT + /* don't do twice, e.g. @b = (@a = split) */ + && !(right->op_private & OPpSPLIT_ASSIGN)) + { + OP *gvop = NULL; + + if ( ( left->op_type == OP_RV2AV + && (gvop=((UNOP*)left)->op_first)->op_type==OP_GV) + || left->op_type == OP_PADAV) + { + /* @pkg or @lex or local @pkg' or 'my @lex' */ + OP *tmpop; + if (gvop) { #ifdef USE_ITHREADS - pm->op_pmreplrootu.op_pmtargetoff - = cPADOPx(tmpop)->op_padix; - cPADOPx(tmpop)->op_padix = 0; /* steal it */ + ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff + = cPADOPx(gvop)->op_padix; + cPADOPx(gvop)->op_padix = 0; /* steal it */ #else - pm->op_pmreplrootu.op_pmtargetgv - = MUTABLE_GV(cSVOPx(tmpop)->op_sv); - cSVOPx(tmpop)->op_sv = NULL; /* steal it */ -#endif - right->op_private |= - left->op_private & OPpOUR_INTRO; - } - else { - pm->op_targ = left->op_targ; - left->op_targ = 0; /* filch it */ - } - detach_split: - tmpop = cUNOPo->op_first; /* to list (nulled) */ - tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ - /* detach rest of siblings from o subtree, - * and free subtree */ - op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL); - op_free(o); /* blow off assign */ - right->op_flags &= ~OPf_WANT; - /* "I don't know and I don't care." */ - return right; - } - else if (left->op_type == OP_RV2AV - || left->op_type == OP_PADAV) - { - /* Detach the array. */ -#ifdef DEBUGGING - OP * const ary = + ((PMOP*)right)->op_pmreplrootu.op_pmtargetgv + = MUTABLE_GV(cSVOPx(gvop)->op_sv); + cSVOPx(gvop)->op_sv = NULL; /* steal it */ #endif - op_sibling_splice(cBINOPo->op_last, - cUNOPx(cBINOPo->op_last) - ->op_first, 1, NULL); - assert(ary == left); - /* Attach it to the split. */ - op_sibling_splice(right, cLISTOPx(right)->op_last, - 0, left); - right->op_flags |= OPf_STACKED; - /* Detach split and expunge aassign as above. */ - goto detach_split; - } - else if (PL_modcount < RETURN_UNLIMITED_NUMBER && - ((LISTOP*)right)->op_last->op_type == OP_CONST) - { - SV ** const svp = - &((SVOP*)((LISTOP*)right)->op_last)->op_sv; - SV * const sv = *svp; - if (SvIOK(sv) && SvIVX(sv) == 0) - { - if (right->op_private & OPpSPLIT_IMPLIM) { - /* our own SV, created in ck_split */ - SvREADONLY_off(sv); - sv_setiv(sv, PL_modcount+1); - } - else { - /* SV may belong to someone else */ - SvREFCNT_dec(sv); - *svp = newSViv(PL_modcount+1); - } - } - } - } + right->op_private |= + left->op_private & OPpOUR_INTRO; + } + else { + ((PMOP*)right)->op_pmreplrootu.op_pmtargetoff = left->op_targ; + left->op_targ = 0; /* steal it */ + right->op_private |= OPpSPLIT_LEX; + } + right->op_private |= left->op_private & OPpLVAL_INTRO; + + detach_split: + tmpop = cUNOPo->op_first; /* to list (nulled) */ + tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ + assert(OpSIBLING(tmpop) == right); + assert(!OpHAS_SIBLING(right)); + /* detach the split subtreee from the o tree, + * then free the residual o tree */ + op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL); + op_free(o); /* blow off assign */ + right->op_private |= OPpSPLIT_ASSIGN; + right->op_flags &= ~OPf_WANT; + /* "I don't know and I don't care." */ + return right; + } + else if (left->op_type == OP_RV2AV) { + /* @{expr} */ + + OP *pushop = cUNOPx(cBINOPo->op_last)->op_first; + assert(OpSIBLING(pushop) == left); + /* Detach the array ... */ + op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL); + /* ... and attach it to the split. */ + op_sibling_splice(right, cLISTOPx(right)->op_last, + 0, left); + right->op_flags |= OPf_STACKED; + /* Detach split and expunge aassign as above. */ + goto detach_split; + } + else if (PL_modcount < RETURN_UNLIMITED_NUMBER && + ((LISTOP*)right)->op_last->op_type == OP_CONST) + { + /* convert split(...,0) to split(..., PL_modcount+1) */ + SV ** const svp = + &((SVOP*)((LISTOP*)right)->op_last)->op_sv; + SV * const sv = *svp; + if (SvIOK(sv) && SvIVX(sv) == 0) + { + if (right->op_private & OPpSPLIT_IMPLIM) { + /* our own SV, created in ck_split */ + SvREADONLY_off(sv); + sv_setiv(sv, PL_modcount+1); + } + else { + /* SV may belong to someone else */ + SvREFCNT_dec(sv); + *svp = newSViv(PL_modcount+1); + } + } + } } return o; } @@ -6932,7 +7066,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) && !(o2->op_private & OPpPAD_STATE)) { Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Deprecated use of my() in false conditional"); + "Deprecated use of my() in false conditional. " + "This will be a fatal error in Perl 5.30"); } *otherp = NULL; @@ -6985,9 +7120,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } } - if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) - other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ - /* optimize AND and OR ops that have NOTs as children */ if (first->op_type == OP_NOT && (first->op_flags & OPf_KIDS) @@ -7881,19 +8013,19 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, } sv_setpvs(msg, "Prototype mismatch:"); if (name) - Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); + Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name)); if (cvp) - Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")", + Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")", UTF8fARG(SvUTF8(cv),clen,cvp) ); else sv_catpvs(msg, ": none"); sv_catpvs(msg, " vs "); if (p) - Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p)); + Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p)); else sv_catpvs(msg, "none"); - Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg)); + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg)); } static void const_sv_xsub(pTHX_ CV* cv); @@ -8205,7 +8337,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvSTASH_set(cv, PL_curstash); *spot = cv; } - sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ + SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */ CvXSUBANY(cv).any_ptr = const_sv; CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); @@ -8312,8 +8444,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_breakable_sub_gen++; CvROOT(cv) = block; - CvROOT(cv)->op_private |= OPpREFCOUNTED; - OpREFCNT_set(CvROOT(cv), 1); /* The cv no longer needs to hold a refcount on the slab, as CvROOT itself has a refcount. */ CvSLABBED_off(cv); @@ -8321,14 +8451,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) #ifdef PERL_DEBUG_READONLY_OPS slab = (OPSLAB *)CvSTART(cv); #endif - CvSTART(cv) = start; - CALL_PEEP(start); - finalize_optree(CvROOT(cv)); - S_prune_chain_head(&CvSTART(cv)); - - /* now that optimizer has done its work, adjust pad values */ - - pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + S_process_optree(aTHX_ cv, block, start); } attrs: @@ -8462,7 +8585,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", + Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" IVdf "]", PL_curstash ? "__ANON__" : "__ANON__::__ANON__", CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); @@ -8518,7 +8641,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, SV * const errsv = ERRSV; /* force display of errors found but not reported */ sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted"); - Perl_croak_nocontext("%"SVf, SVfARG(errsv)); + Perl_croak_nocontext("%" SVf, SVfARG(errsv)); } } } @@ -8617,7 +8740,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, || sv_cmp(SvRV(gv), const_sv) ))) { assert(cSVOPo); Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - "Constant subroutine %"SVf" redefined", + "Constant subroutine %" SVf " redefined", SVfARG(cSVOPo->op_sv)); } @@ -8657,7 +8780,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); cv_forget_slab(cv); - sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ + SvPVCLEAR(MUTABLE_SV(cv)); /* prototype is "" */ CvXSUBANY(cv).any_ptr = const_sv; CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); @@ -8805,8 +8928,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, PL_breakable_sub_gen++; CvROOT(cv) = block; - CvROOT(cv)->op_private |= OPpREFCOUNTED; - OpREFCNT_set(CvROOT(cv), 1); /* The cv no longer needs to hold a refcount on the slab, as CvROOT itself has a refcount. */ CvSLABBED_off(cv); @@ -8814,14 +8935,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, #ifdef PERL_DEBUG_READONLY_OPS slab = (OPSLAB *)CvSTART(cv); #endif - CvSTART(cv) = start; - CALL_PEEP(start); - finalize_optree(CvROOT(cv)); - S_prune_chain_head(&CvSTART(cv)); - - /* now that optimizer has done its work, adjust pad values */ - - pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + S_process_optree(aTHX_ cv, block, start); } attrs: @@ -9227,8 +9341,9 @@ void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { CV *cv; - GV *gv; + OP *root; + OP *start; if (PL_parser && PL_parser->error_count) { op_free(block); @@ -9247,7 +9362,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CopLINE_set(PL_curcop, PL_parser->copline); if (o) { Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); + "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv)); } else { /* diag_listed_as: Format %s redefined */ Perl_warner(aTHX_ packWARN(WARN_REDEFINE), @@ -9263,15 +9378,11 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CvFILE_set_from_cop(cv, PL_curcop); - pad_tidy(padtidy_FORMAT); - CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); - CvROOT(cv)->op_private |= OPpREFCOUNTED; - OpREFCNT_set(CvROOT(cv), 1); - CvSTART(cv) = LINKLIST(CvROOT(cv)); - CvROOT(cv)->op_next = 0; - CALL_PEEP(CvSTART(cv)); - finalize_optree(CvROOT(cv)); - S_prune_chain_head(&CvSTART(cv)); + root = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); + CvROOT(cv) = root; + start = LINKLIST(root); + root->op_next = 0; + S_process_optree(aTHX_ cv, root, start); cv_forget_slab(cv); finish: @@ -9841,7 +9952,7 @@ Perl_ck_rvconst(pTHX_ OP *o) } if (badthing) Perl_croak(aTHX_ - "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", + "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use", SVfARG(kidsv), badthing); } /* @@ -10162,7 +10273,7 @@ Perl_ck_fun(pTHX_ OP *o) if (want_dollar && *name != '$') sv_setpvs(namesv, "$"); else - sv_setpvs(namesv, ""); + SvPVCLEAR(namesv); sv_catpvn(namesv, name, len); if ( name_utf8 ) SvUTF8_on(namesv); } @@ -10351,11 +10462,13 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ case OP_PADAV: Perl_croak(aTHX_ "Can't use 'defined(@array)'" " (Maybe you should just omit the defined()?)"); - break; + NOT_REACHED; /* NOTREACHED */ + break; case OP_RV2HV: case OP_PADHV: Perl_croak(aTHX_ "Can't use 'defined(%%hash)'" " (Maybe you should just omit the defined()?)"); + NOT_REACHED; /* NOTREACHED */ break; default: /* no warning */ @@ -10450,10 +10563,10 @@ Perl_ck_smartmatch(pTHX_ OP *o) op_sibling_splice(o, NULL, 0, first); /* Implicitly take a reference to a regular expression */ - if (first->op_type == OP_MATCH) { + if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) { OpTYPE_set(first, OP_QR); } - if (second->op_type == OP_MATCH) { + if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) { OpTYPE_set(second, OP_QR); } } @@ -10497,7 +10610,7 @@ OP * Perl_ck_sassign(pTHX_ OP *o) { dVAR; - OP * const kid = cLISTOPo->op_first; + OP * const kid = cBINOPo->op_first; PERL_ARGS_ASSERT_CK_SASSIGN; @@ -10547,8 +10660,6 @@ Perl_ck_match(pTHX_ OP *o) PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_CK_MATCH; - if (o->op_type == OP_MATCH || o->op_type == OP_QR) - o->op_private |= OPpRUNTIME; return o; } @@ -10784,7 +10895,6 @@ Perl_ck_require(pTHX_ OP *o) if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP * const kid = (SVOP*)cUNOPo->op_first; - HEK *hek; U32 hash; char *s; STRLEN len; @@ -10794,6 +10904,7 @@ Perl_ck_require(pTHX_ OP *o) if (kid->op_private & OPpCONST_BARE) { dVAR; const char *end; + HEK *hek; if (was_readonly) { SvREADONLY_off(sv); @@ -10836,6 +10947,7 @@ Perl_ck_require(pTHX_ OP *o) } else { dVAR; + HEK *hek; if (was_readonly) SvREADONLY_off(sv); PERL_HASH(hash, s, len); hek = share_hek(s, @@ -10876,7 +10988,7 @@ Perl_ck_return(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_RETURN; kid = OpSIBLING(cLISTOPo->op_first); - if (CvLVALUE(PL_compcv)) { + if (PL_compcv && CvLVALUE(PL_compcv)) { for (; kid; kid = OpSIBLING(kid)) op_lvalue(kid, OP_LEAVESUBLV); } @@ -11131,52 +11243,75 @@ Perl_ck_split(pTHX_ OP *o) { dVAR; OP *kid; + OP *sibs; PERL_ARGS_ASSERT_CK_SPLIT; + assert(o->op_type == OP_LIST); + if (o->op_flags & OPf_STACKED) return no_fh_allowed(o); kid = cLISTOPo->op_first; - if (kid->op_type != OP_NULL) - Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type); /* delete leading NULL node, then add a CONST if no other nodes */ + assert(kid->op_type == OP_NULL); op_sibling_splice(o, NULL, 1, OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" "))); op_free(kid); kid = cLISTOPo->op_first; if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { - /* remove kid, and replace with new optree */ + /* remove match expression, and replace with new optree with + * a match op at its head */ op_sibling_splice(o, NULL, 1, NULL); - /* OPf_SPECIAL is used to trigger split " " behavior */ - kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, NULL, 0, 0); + /* pmruntime will handle split " " behavior with flag==2 */ + kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0); op_sibling_splice(o, NULL, 0, kid); } - OpTYPE_set(kid, OP_PUSHRE); - /* target implies @ary=..., so wipe it */ - kid->op_targ = 0; - scalar(kid); + + assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT); + if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /g modifier is meaningless in split"); } - if (!OpHAS_SIBLING(kid)) - op_append_elem(OP_SPLIT, o, newDEFSVOP()); + /* eliminate the split op, and move the match op (plus any children) + * into its place, then convert the match op into a split op. i.e. + * + * SPLIT MATCH SPLIT(ex-MATCH) + * | | | + * MATCH - A - B - C => R - A - B - C => R - A - B - C + * | | | + * R X - Y X - Y + * | + * X - Y + * + * (R, if it exists, will be a regcomp op) + */ - kid = OpSIBLING(kid); - assert(kid); - scalar(kid); + op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */ + sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */ + op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */ + OpTYPE_set(kid, OP_SPLIT); + kid->op_flags = (o->op_flags | (kid->op_flags & OPf_KIDS)); + kid->op_private = o->op_private; + op_free(o); + o = kid; + kid = sibs; /* kid is now the string arg of the split */ - if (!OpHAS_SIBLING(kid)) - { - op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0))); - o->op_private |= OPpSPLIT_IMPLIM; + if (!kid) { + kid = newDEFSVOP(); + op_append_elem(OP_SPLIT, o, kid); } - assert(OpHAS_SIBLING(kid)); + scalar(kid); kid = OpSIBLING(kid); + if (!kid) { + kid = newSVOP(OP_CONST, 0, newSViv(0)); + op_append_elem(OP_SPLIT, o, kid); + o->op_private |= OPpSPLIT_IMPLIM; + } scalar(kid); if (OpHAS_SIBLING(kid)) @@ -11217,7 +11352,7 @@ Perl_ck_join(pTHX_ OP *o) SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) ) : newSVpvs_flags( "STRING", SVs_TEMP ); Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "/%"SVf"/ should probably be written as \"%"SVf"\"", + "/%" SVf "/ should probably be written as \"%" SVf "\"", SVfARG(msg), SVfARG(msg)); } } @@ -11461,7 +11596,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (proto >= proto_end) { SV * const namesv = cv_name((CV *)namegv, NULL, 0); - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf, SVfARG(namesv)), SvUTF8(namesv)); return entersubop; } @@ -11623,7 +11758,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; default: oops: { - Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, + Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf, SVfARG(cv_name((CV *)namegv, NULL, 0)), SVfARG(protosv)); } @@ -11641,7 +11776,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) { SV * const namesv = cv_name((CV *)namegv, NULL, 0); - yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf, SVfARG(namesv)), SvUTF8(namesv)); } return entersubop; @@ -11709,7 +11844,7 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) case 'L': return newSVOP( OP_CONST, 0, Perl_newSVpvf(aTHX_ - "%"IVdf, (IV)CopLINE(PL_curcop) + "%" IVdf, (IV)CopLINE(PL_curcop) ) ); case 'P': return newSVOP(OP_CONST, 0, @@ -12155,7 +12290,7 @@ Perl_ck_length(pTHX_ OP *o) } if (name) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "length() used on %"SVf" (did you mean \"scalar(%s%"SVf + "length() used on %" SVf " (did you mean \"scalar(%s%" SVf ")\"?)", SVfARG(name), hash ? "keys " : "", SVfARG(name) ); @@ -12494,6 +12629,7 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p) case OP_PADAV: case OP_PADHV: (*scalars_p) += 2; + /* if !top, could be e.g. @a[0,1] */ if (top && (o->op_flags & OPf_REF)) return (o->op_private & OPpLVAL_INTRO) ? AAS_MY_AGG : AAS_LEX_AGG; @@ -12514,6 +12650,7 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p) if (cUNOPx(o)->op_first->op_type != OP_GV) return AAS_DANGEROUS; /* @{expr}, %{expr} */ /* @pkg, %pkg */ + /* if !top, could be e.g. @a[0,1] */ if (top && (o->op_flags & OPf_REF)) return AAS_PKG_AGG; return AAS_DANGEROUS; @@ -12527,15 +12664,32 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p) return AAS_PKG_SCALAR; /* $pkg */ case OP_SPLIT: - if (cLISTOPo->op_first->op_type == OP_PUSHRE) { - /* "@foo = split... " optimises away the aassign and stores its - * destination array in the OP_PUSHRE that precedes it. - * A flattened array is always dangerous. + if (o->op_private & OPpSPLIT_ASSIGN) { + /* the assign in @a = split() has been optimised away + * and the @a attached directly to the split op + * Treat the array as appearing on the RHS, i.e. + * ... = (@a = split) + * is treated like + * ... = @a; */ + + if (o->op_flags & OPf_STACKED) + /* @{expr} = split() - the array expression is tacked + * on as an extra child to split - process kid */ + return S_aassign_scan(aTHX_ cLISTOPo->op_last, rhs, + top, scalars_p); + + /* ... else array is directly attached to split op */ (*scalars_p) += 2; - return AAS_DANGEROUS; + if (PL_op->op_private & OPpSPLIT_LEX) + return (o->op_private & OPpLVAL_INTRO) + ? AAS_MY_AGG : AAS_LEX_AGG; + else + return AAS_PKG_AGG; } - break; + (*scalars_p)++; + /* other args of split can't be returned */ + return AAS_SAFE_SCALAR; case OP_UNDEF: /* undef counts as a scalar on the RHS: @@ -12586,6 +12740,11 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p) break; } + /* XXX this assumes that all other ops are "transparent" - i.e. that + * they can return some of their children. While this true for e.g. + * sort and grep, it's not true for e.g. map. We really need a + * 'transparent' flag added to regen/opcodes + */ if (o->op_flags & OPf_KIDS) { OP *kid; for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) @@ -13025,6 +13184,27 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) && ( (o->op_private & OPpDEREF) == OPpDEREF_AV || (o->op_private & OPpDEREF) == OPpDEREF_HV); + /* This doesn't make much sense but is legal: + * @{ local $x[0][0] } = 1 + * Since scope exit will undo the autovivification, + * don't bother in the first place. The OP_LEAVE + * assertion is in case there are other cases of both + * OPpLVAL_INTRO and OPpDEREF which don't include a scope + * exit that would undo the local - in which case this + * block of code would need rethinking. + */ + if (is_deref && (o->op_private & OPpLVAL_INTRO)) { +#ifdef DEBUGGING + OP *n = o->op_next; + while (n && ( n->op_type == OP_NULL + || n->op_type == OP_LIST)) + n = n->op_next; + assert(n && n->op_type == OP_LEAVE); +#endif + o->op_private &= ~OPpDEREF; + is_deref = FALSE; + } + if (is_deref) { ASSUME(!(o->op_flags & ~(OPf_WANT|OPf_KIDS|OPf_MOD|OPf_PARENS))); @@ -13303,6 +13483,79 @@ S_maybe_multideref(pTHX_ OP *start, OP *orig_o, UV orig_action, U8 hints) } /* for (pass = ...) */ } +/* See if the ops following o are such that o will always be executed in + * boolean context: that is, the SV which o pushes onto the stack will + * only ever be used by later ops with SvTRUE(sv) or similar. + * If so, set a suitable private flag on o. Normally this will be + * bool_flag; but if it's only possible to determine booleaness at run + * time (e.g. sub f { ....; (%h || $y) }), then set maybe_flag instead. + */ + +static void +S_check_for_bool_cxt(pTHX_ OP*o, U8 bool_flag, U8 maybe_flag) +{ + OP *lop; + + assert((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR); + + lop = o->op_next; + + while (lop) { + switch (lop->op_type) { + case OP_NULL: + case OP_SCALAR: + break; + + /* these two consume the stack argument in the scalar case, + * and treat it as a boolean in the non linenumber case */ + case OP_FLIP: + case OP_FLOP: + if ( ((lop->op_flags & OPf_WANT) == OPf_WANT_LIST) + || (lop->op_private & OPpFLIP_LINENUM)) + { + lop = NULL; + break; + } + /* FALLTHROUGH */ + /* these never leave the original value on the stack */ + case OP_NOT: + case OP_XOR: + case OP_COND_EXPR: + case OP_GREPWHILE: + o->op_private |= bool_flag; + lop = NULL; + break; + + /* OR DOR and AND evaluate their arg as a boolean, but then may + * leave the original scalar value on the stack when following the + * op_next route. If not in void context, we need to ensure + * that whatever follows consumes the arg only in boolean context + * too. + */ + case OP_OR: + case OP_DOR: + case OP_AND: + if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) { + o->op_private |= bool_flag; + lop = NULL; + } + else if (!(lop->op_flags & OPf_WANT)) { + /* unknown context - decide at runtime */ + o->op_private |= maybe_flag; + lop = NULL; + } + break; + + default: + lop = NULL; + break; + } + + if (lop) + lop = lop->op_next; + } +} + /* mechanism for deferring recursion in rpeep() */ @@ -13338,8 +13591,6 @@ Perl_rpeep(pTHX_ OP *o) OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ int defer_base = 0; int defer_ix = -1; - OP *fop; - OP *sop; if (!o || o->op_opt) return; @@ -13769,10 +14020,10 @@ Perl_rpeep(pTHX_ OP *o) && kid->op_next->op_type == OP_REPEAT && kid->op_next->op_private & OPpREPEAT_DOLIST && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST - && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0) + && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0 + && oldop) { o = kid->op_next; /* repeat */ - assert(oldop); oldop->op_next = o; op_free(cBINOPo->op_first); op_free(cBINOPo->op_last ); @@ -14034,19 +14285,26 @@ Perl_rpeep(pTHX_ OP *o) break; } + case OP_RV2HV: + case OP_PADHV: + /* see if %h is used in boolean context */ + if ((o->op_flags & OPf_WANT) == OPf_WANT_SCALAR) + S_check_for_bool_cxt(aTHX_ o, OPpTRUEBOOL, OPpMAYBE_TRUEBOOL); + if (o->op_type != OP_PADHV) + break; + /* FALLTHROUGH */ case OP_PADAV: case OP_PADSV: - case OP_PADHV: - /* Skip over state($x) in void context. */ - if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO) - && (o->op_flags & OPf_WANT) == OPf_WANT_VOID) - { - oldop->op_next = o->op_next; - goto redo_nextstate; - } - if (o->op_type != OP_PADAV) - break; - /* FALLTHROUGH */ + /* Skip over state($x) in void context. */ + if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO) + && (o->op_flags & OPf_WANT) == OPf_WANT_VOID) + { + oldop->op_next = o->op_next; + goto redo_nextstate; + } + if (o->op_type != OP_PADAV) + break; + /* FALLTHROUGH */ case OP_GV: if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) { OP* const pop = (o->op_type == OP_PADAV) ? @@ -14126,25 +14384,12 @@ Perl_rpeep(pTHX_ OP *o) break; -#define HV_OR_SCALARHV(op) \ - ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \ - ? (op) \ - : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \ - && ( cUNOPx(op)->op_first->op_type == OP_PADHV \ - || cUNOPx(op)->op_first->op_type == OP_RV2HV) \ - ? cUNOPx(op)->op_first \ - : NULL) - case OP_NOT: - if ((fop = HV_OR_SCALARHV(cUNOP->op_first))) - fop->op_private |= OPpTRUEBOOL; break; case OP_AND: case OP_OR: case OP_DOR: - fop = cLOGOP->op_first; - sop = OpSIBLING(fop); while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; while (o->op_next && ( o->op_type == o->op_next->op_type @@ -14166,53 +14411,10 @@ Perl_rpeep(pTHX_ OP *o) o->op_next = ((LOGOP*)o->op_next)->op_other; } DEFER(cLOGOP->op_other); - o->op_opt = 1; - fop = HV_OR_SCALARHV(fop); - if (sop) sop = HV_OR_SCALARHV(sop); - if (fop || sop - ){ - OP * nop = o; - OP * lop = o; - if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) { - while (nop && nop->op_next) { - switch (nop->op_next->op_type) { - case OP_NOT: - case OP_AND: - case OP_OR: - case OP_DOR: - lop = nop = nop->op_next; - break; - case OP_NULL: - nop = nop->op_next; - break; - default: - nop = NULL; - break; - } - } - } - if (fop) { - if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID - || o->op_type == OP_AND ) - fop->op_private |= OPpTRUEBOOL; - else if (!(lop->op_flags & OPf_WANT)) - fop->op_private |= OPpMAYBE_TRUEBOOL; - } - if ( (lop->op_flags & OPf_WANT) == OPf_WANT_VOID - && sop) - sop->op_private |= OPpTRUEBOOL; - } - - break; case OP_COND_EXPR: - if ((fop = HV_OR_SCALARHV(cLOGOP->op_first))) - fop->op_private |= OPpTRUEBOOL; -#undef HV_OR_SCALARHV - /* GERONIMO! */ /* FALLTHROUGH */ - case OP_MAPWHILE: case OP_GREPWHILE: case OP_ANDASSIGN: @@ -14278,8 +14480,9 @@ Perl_rpeep(pTHX_ OP *o) && ( kid->op_targ == OP_NEXTSTATE || kid->op_targ == OP_DBSTATE )) || kid->op_type == OP_STUB - || kid->op_type == OP_ENTER); - nullop->op_next = kLISTOP->op_next; + || kid->op_type == OP_ENTER + || (PL_parser && PL_parser->error_count)); + nullop->op_next = kid->op_next; DEFER(nullop->op_next); } @@ -14405,7 +14608,7 @@ Perl_rpeep(pTHX_ OP *o) oldop = ourlast; o = oldop->op_next; goto redo; - + NOT_REACHED; /* NOTREACHED */ break; } @@ -14556,6 +14759,17 @@ Perl_rpeep(pTHX_ OP *o) NOOP; } else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS)) + /* if there are only lexicals on the LHS and no + * common ones on the RHS, then we assume that the + * only way those lexicals could also get + * on the RHS is via some sort of dereffing or + * closure, e.g. + * $r = \$lex; + * ($lex, $x) = (1, $$r) + * and in this case we assume the var must have + * a bumped ref count. So if its ref count is 1, + * it must only be on the LHS. + */ o->op_private |= OPpASSIGN_COMMON_RC1; } } @@ -14953,8 +15167,8 @@ Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, ) Perl_warner(aTHX_ packWARN(WARN_REDEFINE), is_const - ? "Constant subroutine %"SVf" redefined" - : "Subroutine %"SVf" redefined", + ? "Constant subroutine %" SVf " redefined" + : "Subroutine %" SVf " redefined", SVfARG(name)); }